;;;; -*- lisp -*- ;;;; @@PLEAC@@_NAME ;;;; @@SKIP@@ Common Lisp ;;;; @@PLEAC@@_WEB ;;;; @@SKIP@@ http://www.lisp.org/ ;;;; @@SKIP@@ http://www.sbcl.org/ ;;;; @@PLEAC@@_INTRO ;;;; @@SKIP@@ Newer submissions use SBCL, and make use of a number of ;;;; @@SKIP@@ SBCL and third-party libraries (see Appendix for ;;;; @@SKIP@@ details). ;;;; @@SKIP@@ In the code below, when the Perl code uses arrays in a ;;;; @@SKIP@@ way that *really* requires it (e.g., uses random ;;;; @@SKIP@@ access), we use CL arrays. Otherwise we usually use ;;;; @@SKIP@@ lists, which are more convenient. ;;;; @@PLEAC@@_APPENDIX (in-package :cl-user) (require :cl-ppcre) (require :iterate) (use-package '(cl-ppcre iterate)) (declaim (optimize (speed 0) (safety 3) (debug 3))) (defun chomp (string) "Similar to Perl's chomp(), although it returns the new value of STRING rather than the number of characters removed, and doesn't modify its argument." (string-right-trim #(#\Newline #\Return) string)) (defmacro when-let ((var value) &body body) "Evaluate VALUE, and if the result is non-nil bind it to VAR and evaluate BODY." `(let ((,var ,value)) (when ,var ,@body))) (defmacro perl-grep (sequence &body predicate-body) "Like Perl's grep. Predicate is a body of code that can refer to IT as the current element of the list." `(remove-if-not #'(lambda (it) ,@predicate-body) ,sequence)) ;; The following could be made more efficient by using a faster TEST ;; function if the keys appear to be simpler. (defun mkhash (&rest keys/values) "Utility for making new EQUAL hashes easily, similar to Perl's built-in funcionality." (let ((newhash (make-hash-table :test 'equal ; use EQUAL so strings work as keys :size (truncate (/ (length keys/values) 2))))) (loop for key in keys/values by #'cddr for value in (cdr keys/values) by #'cddr do (setf (gethash key newhash) value)) newhash)) ;; Section 12.1 has an example usage of this, including how ;; *EXPORT-TAGS* should be formatted. (defun import-tags (package-designator &rest tags) "Helps emulate Perl's EXPORT_TAGS functionality, which has no equivalent in standard CL." (let* ((current-package *package*) (*package* (find-package package-designator)) ;; Otherwise we'll find the *export-tags* from the "calling" ;; package. (export-tags (symbol-value (find-symbol "*EXPORT-TAGS*" *package*)))) (dolist (tag tags) (import (cadr (assoc tag export-tags)) current-package)))) ;; Like Perl's keys function. (defun hash-keys (hash) (loop for k being the hash-keys of hash collect k)) ;;;; @@SKIP@@ Common Lisp code makes use of the following for ;;;; @@SKIP@@ package/loading: ;;;; @@SKIP@@ (require :PACKAGENAME) ;;;; @@SKIP@@ SBCL code makes use of the following for package / ;;;; @@SKIP@@ library loading: ;;;; @@SKIP@@ (asdf:operate 'asdf:load-op :date-calc) ; load the package ;;;; @@SKIP@@ (use-package 'date-calc) ; import the symbols ;;;; @@SKIP@@ (load "time.lisp") ; replace with your location of the pdl library ;;;; @@SKIP@@ (use-package 'CyberTiggyr-Time) ; for printing times in various formats ;;;; @@SKIP@@ Packages / libraries used include: ;;;; @@SKIP@@ http://cybertiggyr.com/gene/pdl/ ;;;; @@SKIP@@ http://www.cliki.net/asdf ;;;; @@SKIP@@ http://www.cliki.net/cl-interpol ;;;; @@SKIP@@ http://www.cliki.net/cl-ppcre ;;;; @@SKIP@@ http://www.cliki.net/date-calc ;;;; @@SKIP@@ http://www.cliki.net/iterate ;;; @@PLEAC@@_1.0 ;;;----------------------------- (setf string "\\n") ; two characters, \ and an n (setf string "John 'Maddog' Orwant") ; literal single quotes ;;;----------------------------- ;; newlines may be inserted literally (setf string " ") ; a "newline" character ;; or by creating a string explicitly (setf string (make-string 1 :initial-element #\Newline)) ;; or by using format with a nil output stream (setf string (format nil "~%")) (setf string "John \"Maddog\" Orwant") ; literal double quotes ;;;----------------------------- (setf string "John 'Maddog' Orwant") ; literal single quotes ;;;----------------------------- (setf string " This is a multiline string, terminated by a double quotation mark. ") ;;;----------------------------- ;; There are no CL equivalents to Perl's other ways of quoting ;; strings (q//, etc). ;;;----------------------------- ;;; @@PLEAC@@_1.1 ;;;----------------------------- ;; assign a substring to a variable (setf value (subseq string offset (+ offset count))) (setf value (subseq string offset)) ;; edit a substring (setf string (concatenate 'string (subseq string 0 offset) newstring (subseq string (+ offset count)))) (setf string (concatenate 'string (subseq string 0 offset) newtail)) ;;;----------------------------- ;; get a 5-byte string, skip 3, then grab 2 8-byte strings, then the ;; rest (setf leading (subseq data 5) s1 (subseq data 8 8) s2 (subseq data 16 8) trailing (subseq data 24)) ;; split at five byte boundries (let ((length (length string))) (loop for idx from 0 upto length by 5 collect (subseq string idx (min length (+ idx 5))))) ;; chop string into individual characters (loop for idx from 0 upto (1- (length string)) collect (char string idx)) ;;;----------------------------- (defparameter *string* "This is what you have") ;;; +012345678901234567890 Indexing forwards (left to right) ;;; 109876543210987654321- Indexing backwards (right to left) (let ((first (subseq *string* 0 1)) ; "T" (start (subseq *string* 5 7)) ; "is" (rest (subseq *string* 13)) ; "you have" (last (subseq *string* (+ (length *string*) -1))) ; "e" (end (subseq *string* (+ (length *string*) -4))) ; "have" (piece (subseq *string* (+ (length *string*) -8) (+ (length *string*) -8 3)))) ; "you" (list first start rest last end piece)) ;; ("T" "is" "you have" "e" "have" "you") ;;;----------------------------- (defparameter *string* "This is what you have") (print *string*) ;; This is what you have ;; Change "is" to "wasn't" (setf *string* (concatenate 'string (subseq *string* 0 5) "wasn't" (subseq *string* (+ 5 2)))) ;; This wasn't what you have ;; Replace last 12 characters (setf *string* (concatenate 'string (subseq *string* 0 (+ (length *string*) -12)) "ondrous")) ;; This wasn't wondrous ;; Delete first character (setf *string* (subseq *string* 1)) ;; his wasn't wondrous ;; Delete last 10 characters (setf *string* (subseq *string* 0 (+ (length *string*) -10))) ;; his wasn' ;;;----------------------------- ;; you can test substrings with the :start and :end keyword parameters ;; of CL-PPCRE:SCAN (when (scan "pattern" *string* :start (- (length *string*) 10)) (format t "Pattern matches in last 10 characters~%")) ;; substitute "at" for "is", restricted to first five characters (concatenate 'string (regex-replace "is" *string* "at" :start 0 :end (min (length *string*) 5)) (when (> (length *string*) 5) (subseq *string* 5))) ;;;----------------------------- ;; exchange the first and last letters in a string (let ((a "make a hat")) ;; ROTATEF is CL's general-purpose swap macro (rotatef (char a 0) (char a (1- (length a)))) (princ a)) ;; take a ham ;;;----------------------------- ;; extract column with SUBSEQ (let* ((a "To be or not to be") (b (subseq a 6 12))) ; skip 6, grab 6 (format t "~A~%" b) ;; or not ;; forward 6, grab 2; backward 5, grab 2 (destructuring-bind (b c) `(,(subseq a 6 8) ,(subseq a 3 5)) (format t "~A~%~A~%" b c))) ;; or ;; be ;;;----------------------------- (defun cut2fmt (&rest positions) "Useless in CL, which lacks Perl's unpack(); here for completeness." (let ((template "") (lastpos 1)) (dolist (place positions) (setf template (format nil "~AA~D " template (- place lastpos))) (setf lastpos place)) (setf template (concatenate 'string template "A*")) template)) (let ((fmt (cut2fmt 8 14 20 26 30))) (format t "~A~%" fmt)) ;; A7 A6 A6 A6 A4 A* ;;;----------------------------- ;;; @@PLEAC@@_1.2 ;;;----------------------------- ;; use b if b is true, else c (setf a (or b c)) ;; set x to y unless x is already true (unless x (setf x y)) ;;;----------------------------- ;; use B if B is defined, otherwise C (setf a (if (boundp 'b) b c)) ;;;----------------------------- (setf foo (or bar "DEFAULT VALUE")) ;;;----------------------------- #+sbcl (defparameter ARGV (copy-seq (cdr *posix-argv*)) "Arguments from shell, Perl style") (setf dir (or (pop ARGV) "/tmp")) ;;;----------------------------- (setf dir (or (nth 0 ARGV) "/tmp")) ;;;----------------------------- (setf dir (if (plusp (length ARGV)) (pop ARGV) "/tmp")) ;;;----------------------------- (setf dir (if (plusp (length ARGV)) (nth 0 ARGV) "/tmp")) ;;;----------------------------- (setf count (make-hash-table)) (incf (gethash (or shell "/bin/sh") count 0)) ;;;----------------------------- ;; find the user name on Unix systems (setf user (or (posix-getenv "USER") (posix-getenv "LOGNAME") #+sbcl (let ((uid (sb-posix:getuid))) (or (sb-posix:passwd-name (sb-posix:getpwuid uid)) (format nil "Unknown uid number ~a" uid))) #-sbcl "Unknown uid")) ;;;----------------------------- (setf starting-point (or starting-point "Greenwich")) ;;;----------------------------- ;; Perl array-to-array assignment copies the array, hence the need for ;; COPY-SEQ below. (unless (plusp (length a)) (setf a (copy-seq b))) ; copy only if empty (setf a (copy-seq (if (plusp (length b)) b c))) ; assign b if nonempty, else c ;;;----------------------------- ;;; @@PLEAC@@_1.3 ;;;----------------------------- ;; There are several ways to swap variables in CL. ROTATEF is usually ;; the simplest choice. (rotatef VAR1 VAR2) (psetq VAR1 VAR2 VAR2 VAR1) (multiple-value-setq (VAR1 VAR2) (values VAR2 VAR1)) ;;;----------------------------- (setf temp a a b b temp) ;;;----------------------------- (let ((a "alpha") (b "omega")) (rotatef a b)) ; the first shall be last -- and versa vice ;;;----------------------------- (destructuring-bind (alpha beta production) ;; In CL one would normally use symbols here: ;; '(January March August) '("January" "March" "August") ;; move beta to alpha, ;; move production to beta, ;; move alpha to production (rotatef alpha beta production)) ;;;----------------------------- ;;; @@PLEAC@@_1.4 ;;----------------------------- (setq num (char-code char)) (setq char (code-char num)) ;;----------------------------- (setq char (format nil "~c" (code-char num))) (format t "Number ~d is character ~c~%" num (code-char num)) ;; Number 101 is character e ;;;----------------------------- (setq ASCII (map 'list #'char-code string)) (setq string (map 'string #'code-char ASCII)) ;;----------------------------- (setq ascii-value (char-code #\e)) ; now 101 (setq character (code-char 101)) ; now #\e ;;----------------------------- (format t "Number ~D is character ~C~%" 101 (code-char 101)) ;;----------------------------- (let ((ascii-character-numbers (map 'list #'char-code "sample"))) (format t "~{~A~^ ~}~%" ascii-character-numbers) ;; 115 97 109 112 108 101 (setf word (map 'string #'code-char ascii-character-numbers)) (setf word (map 'string #'code-char #(115 97 109 112 108 101))) ; same (format t "~A~%" word)) ;; sample ;;;----------------------------- (let* ((hal "HAL") (ibm (map 'string (lambda (char) (code-char (1+ (char-code char)))) ; add one to each ASCII value hal))) (format t "~A~%" ibm)) ; prints "IBM" ;;;----------------------------- ;;; @@PLEAC@@_1.5 ;;;----------------------------- (setq array (map 'list #'string string)) (setq array (loop for char across string collect (char-code char))) ;;;----------------------------- (do-matches-as-strings (match "(.)" string) ;; do something with MATCH ) ;;;----------------------------- (let ((seen (make-hash-table)) (string "an apple a day")) (loop for char across string do (incf (gethash char seen 0))) (let ((chars (loop for char being each hash-key of seen collect char))) (format t "unique chars are: ~{~C~}~%" (sort chars '< :key 'char-code)))) ;; unique chars are: adelnpy ;;;----------------------------- (let ((string "an apple a day")) (format t "sum is ~D~%" (reduce #'+ string :key #'char-code))) (let ((string "an apple a day")) (format t "sum is ~D~%" (loop for char across string summing (char-code char)))) ;;;----------------------------- (let ((string "an apple a day")) (format t "sum is ~D~%" (loop for char across string sum (char-code char)))) ;; prints "1248" if string was "an apple a day" ;;;----------------------------- ;; There's no equivalent to Perl's unpack(), this is about as close as ;; you can get. (setf sum (loop for char across string sum (char-code char))) ;;;----------------------------- ;; In CL it makes more sense to call this function from the REPL than ;; it does to put it into a separate script. E.g., ;; > (sum "/tmp/xyz" "~/foo/bar.txt") (defun sum (&rest files) (let ((sum 0)) (dolist (filename files) (with-open-file (file filename :element-type 'unsigned-byte) (do ((b (read-byte file nil :eof) (read-byte file nil :eof))) ((eql b :eof)) (incf sum b)))) (let ((r (+ (mod sum (expt 2 16)) (truncate (/ (mod sum (expt 2 32)) (expt 2 16)))))) (+ (mod r (expt 2 16)) (truncate (/ r (expt 2 16))))))) ;;;----------------------------- ;;CL-USER> (sum "/mach.sym") ;;24298 ;;;----------------------------- ;;%cksum -o 2 /mach.sym ;;24298 1203 /mach.sym ;;;----------------------------- (defun slowcat (number-or-filename &rest more-files) "The first argument can be a number of seconds to sleep between characters, otherwise it should be a file name." (let ((delay (if (numberp number-or-filename) number-or-filename 1)) (files (if (numberp number-or-filename) more-files (cons number-or-filename more-files)))) (dolist (filename files) (with-open-file (file filename) (do ((c (read-char file nil :eof) (read-char file nil :eof))) ((eql c :eof)) (format t "~C" c) (finish-output) (sleep (* delay 0.005))))))) ;;; @@PLEAC@@_1.6 ;;;----------------------------- (setq revbytes (reverse string)) ;;;----------------------------- (setq revwords (format nil "~{~A~^ ~}" (reverse (split " " string)))) (setq revwords (reverse (do* ((stringstream (make-string-input-stream string)) (result nil (cons next result)) (next (read stringstream nil 'eos) (read stringstream nil 'eos))) ((equal next 'eos) (reverse result))))) ;;;----------------------------- (setq gnirts (reverse string)) ; reverse letters in string (setq sdrow (reverse words)) ; reverse elements in words (setq confused (reverse (apply #'concatenate 'string words))) ; reverse letters in join("", @words) ;;;----------------------------- (setq string "Yoda said, \"can you see this?\"") (setq allwords (split " " string)) (setq revwords (format nil "~{~A~^ ~}" (reverse allwords))) (format t "~A~%" revwords) ;this?" see you "can said, Yoda ;;;----------------------------- (setq revwords (format nil "~{~A~^ ~}" (reverse (split " " string)))) ;;;----------------------------- (setq revwords (apply #'concatenate 'string (split "(\\s+)" string :with-registers-p t))) ;;;----------------------------- (defun palindrome-p (word) (string= word (reverse word))) (palindrome-p "reviver") ;; T ;;;----------------------------- (with-open-file (inf "/usr/share/dict/words") (loop for word = (read-line inf nil nil) while word when (and (string= word (reverse word)) (> (length word) 5)) do (format t "~a~%" word))) ;; deedeed ;; degged ;; hallah ;; kakkak ;; murdrum ;; redder ;; repaper ;; retter ;; reviver ;; rotator ;; sooloos ;; tebbet ;; terret ;;;----------------------------- ;;; @@PLEAC@@_1.7 ;;;----------------------------- ;;;----------------------------- (defun tab-expand (string &optional (tabstop 8)) (flet ((needed-spaces (target-string start end match-start match-end reg-starts reg-ends) (declare (ignore target-string start end reg-starts reg-ends)) (make-string (- (* (- match-end match-start) tabstop) (mod match-start tabstop)) :initial-element #\Space))) (regex-replace-all "\\t+" string #'needed-spaces))) (defun tab-unexpand (string &optional (tabstop 8)) (flet ((needed-tabs (target-string start end match-start match-end reg-starts reg-ends) (declare (ignore target-string start end reg-starts reg-ends)) (let ((match-length (- match-end match-start))) (concatenate 'string (make-string (floor match-length tabstop) :initial-element #\Tab) (make-string (mod match-length tabstop) :initial-element #\Space))))) (regex-replace-all " +" string #'needed-tabs))) ;;;----------------------------- (loop for line = (read-line *standard-input* nil nil) while line do (format t "~A~%" (tab-expand line))) ;;;----------------------------- (loop for line = (read-line *standard-input* nil nil) while line do (format t "~A~%" (tab-unexpand line))) ;;;----------------------------- ;;; @@PLEAC@@_1.8 ;;;----------------------------- (setf text "You owe $debt to me") ;;;----------------------------- (defun global-deref (match var-name) "Helper function to simulate Perl's string interpolation in regexps." (write-to-string (symbol-value (intern (string-upcase var-name))))) (setf text (regex-replace-all "\\$(\\w+)" text #'global-deref :simple-calls t)) ;;;----------------------------- (setq rows 24 cols 80) (setq text "I am $rows high and $cols long") (setq text (regex-replace-all "\\$(\\w+)" text #'global-deref :simple-calls t)) (format t "~A~%" text) ;; I am 24 high and 80 long ;;;----------------------------- (setf text "I am 17 years old") (setf text (regex-replace-all "(\\d+)" text (lambda (match num-str) (declare (ignore match)) (write-to-string (* 2 (parse-integer num-str)))) :simple-calls t)) ;;;----------------------------- (* 2 17) ;;;----------------------------- ;; expand variables in text, but put an error message in ;; if the variable isn't defined (flet ((deref-with-err (match word) (declare (ignore match)) (let ((word-sym (intern (string-upcase word)))) (if (boundp word-sym) (write-to-string (symbol-value word-sym)) (format nil "[NO VARIABLE: $~a]" word-sym))))) (setf text (regex-replace-all "\\$(\\w+)" text #'deref-with-err :simple-calls t))) ;;;----------------------------- ;;; @@PLEAC@@_1.9 ;;;----------------------------- (setf big (string-upcase little)) ; "bo peep" -> "BO PEEP" (setf little (string-downcase big)) ; "JOHN" -> "john" ;; Reminder: the following depends on CL-INTERPOL. (setf big #?"\U$(little)") ; "bo peep" -> "BO PEEP" (setf little #?"\L$(big)") ; "JOHN" -> "john" ;;;----------------------------- (setf big (string-upcase little :end 1) ; "bo" -> "Bo" (setf little (string-downcase BIG :end 1)) ; "BoPeep" -> "boPeep" (setf big #?"\u$(little)") ; "bo" -> "Bo" (setf little #?"\l$(big)") ; "BoPeep" -> "boPeep" ;;;----------------------------- (setf beast "dromedary") ;; Capitalize various parts of beast (setf capit (string-upcase beast :end 1)) ; Dromedary (setf capit #?"\u\L$(beast)") ; (same) (setf capall (string-upcase beast)) ; DROMEDARY (setf capall #?"\U$(beast)") ; (same) (setf caprest (string-downcase (string-upcase beast) :end 1)) ; dROMEDARY (setf caprest #?"\l\U$(beast)") ; (same) ;;;----------------------------- ;; capitalize each word's first character, downcase the rest (setf text "thIS is a loNG liNE") (format t "~A~%" (string-capitalize text)) ;; This Is A Long Line ;;;----------------------------- ;; string= is case-sensitive, string-equal is case-insensitive (when (string-equal a b) (format t "a and b are the same~%")) ;;;----------------------------- ;; It's considered bad form to perform bitwise operations on character ;; types, and breaks unicode-aware lisps. Trust the compiler to ;; optimize. (defun randcase (char) (if (< (random 100) 20) (char-upcase char) (char-downcase char))) ;;;----------------------------- ;;; @@PLEAC@@_1.10 ;;;----------------------------- (setf answer (concatenate 'string var1 (func) var2)) ;;;----------------------------- (setf answer (format nil "STRING ~{~A~} MORE STRING" list-expr)) (setf answer (format nil "STRING ~A MORE STRING" atomic-expr)) ;;;----------------------------- (setf phrase (format nil "I have ~D guanacos." (1+ n))) (setf phrase #?"I have ${(1+ n)} guanacos.") ; uses CL-INTERPOL ;;;----------------------------- (format t "I have ~D guanacos.~%" (1+ n)) ;;;----------------------------- (some-func (format nil "What you want is ~{~A~} items" (split ":" rec))) ;;;----------------------------- (let ((text (format nil "~ To: ~A From: Your Bank Cc: ~{~A~^, ~} Date: ~A (today) Dear ~A, Today, you bounced check number ~D to us. Your account is now closed. Sincerely, the management " naughty (get-manager-list naughty) (let (date-str (with-output-to-string (str) (run-program "/bin/date" nil :output str))) (subseq date-str 0 (1- (length date-str)))) naughty (+ 500 (random 100))))) (unless (send-mail text target) (error "Couldn't send mail"))) ;;;----------------------------- ;;; @@PLEAC@@_1.11 ;;;----------------------------- ;; all in one (setf var (regex-replace-all (create-scanner #?r"^\s+" :multi-line-mode t) "your text goes here " "")) ;; or with two steps (setf var "your text goes here ") (setf var (regex-replace-all (create-scanner #?r"^\s+" :multi-line-mode t) var "")) ;;----------------------------- (setf var (regex-replace-all (create-scanner #?r"^\s+" :multi-line-mode t) " The five varieties of camelids are the familiar camel, his friends the llama and the alpaca, and the rather less well-known guanaco and vicuña. " "")) ;;;----------------------------- (defun fix (string) (regex-replace-all (create-scanner #?r"^\s+" :multi-line-mode t) string "")) (format t "~A~%" (fix " My stuff goes here ") ;;;----------------------------- (setf quote (regex-replace-all (create-scanner #?r"\s+--") (regex-replace-all (create-scanner #?r"^\s+" :multi-line-mode t) " ...we will have peace, when you and all your works have perished--and the works of your dark master to whom you would deliver us. You are a liar, Saruman, and a corrupter of mens hearts. --Theoden in /usr/src/perl/taint.c " "") " --")) ;;----------------------------- (when *remember-the-main* (setf perl-main-C (dequote " @@@ int @@@ runops() { @@@ SAVEI32(runlevel); @@@ runlevel++; @@@ while ( op = (*op->op_ppaddr)() ) ; @@@ TAINT_NOT; @@@ return 0; @@@ } " ;; add more code here if you want ))) ;;;----------------------------- (defparameter *poem* (dequote " Now far ahead the Road has gone, And I must follow, if I can, Pursuing it with eager feet, Until it joins some larger way Where many paths and errands meet. And whither then? I cannot say. --Bilbo in /usr/src/perl/pp_ctl.c ")) (format t "Here's your poem:~%~%~A~%" *poem*) ;;;----------------------------- (defun dequote (string) ;; Can't get multiple values returned thru the OR, hence the use of ;; DESTRUCTURING-BIND instead of MULTIPLE-VALUE-BIND (destructuring-bind (white leader) ; common whitespace and common leading string (or (register-groups-bind ($1 $2) (#?r/^\s*(?:([^\w\s]+)(\s*).*\n)(?:\s*\1\2?.*\n)+$/ string) (list $2 (quote-meta-chars $1))) (list (scan-to-strings #?r"^(\s+)" string) "")) (regex-replace-all (create-scanner (format nil #?r"^\s*?~a(?:~a)?" leader white) :multi-line-mode t) string ""))) ;;;----------------------------- ;;; @@PLEAC@@_1.13 ;; backslash (setf var (regex-replace-all "([CHARLIST])" var "\\\1")) ;; double (setf var (regex-replace-all "([CHARLIST])" var "\\1\\1")) ;;;----------------------------- (setf string (regex-replace-all "%" string "%%")) ;;;----------------------------- (setf string "Mom said, \"Don't do that.\"") (setf string (regex-replace-all "(['\"])" string #?r"\\\1")) ;;;----------------------------- (setf string "Mom said, \"Don't do that.\"") (setf string (regex-replace-all "(['\"])" string #?r"\1\1")) ;;;----------------------------- (setf string (regex-replace-all #?r"([^A-Z])" string #?r"\\\1")) ;;;----------------------------- (setf string #?r"this \Qis a test!\E") (setf string "this is\\ a\\ test\\!") (setf string (concatenate 'string "this " (quote-meta-chars "is a test!"))) ;;;----------------------------- ;;; @@PLEAC@@_1.14 ;;;----------------------------- (setf string (regex-replace #?r/^\s+/ string "")) (setf string (regex-replace #?r/\s+$/ string "")) ;;;----------------------------- ;;; The closest thing to Perl's wantarray is CL's ability to return ;;; multiple values from a function. Unless the caller uses ;;; MULTIPLE-VALUE-BIND (or, in this case, MULTIPLE-VALUE-LIST), they ;;; will only "see" the first value. Note also that, normally, you'd ;;; use CL's built-in STRING-TRIM function for this. (defun trim (&rest strings) (values-list (loop for string in strings collect (regex-replace #?r/^\s+/ (regex-replace #?r/\s+$/ string "") "")))) (setf string (trim string)) (setf many (multiple-value-list (apply 'trim many))) ;;;----------------------------- ;; print what's typed, but surrounded by >< symbols (loop (let ((line (read-line))) (chomp line) (format t #?">$(line)<~%"))) ;;;----------------------------- ;;; @@PLEAC@@_1.15 ;;;----------------------------- (defun parse-csv (text) (let (fields) (cl-ppcre:do-register-groups (quoted unquoted) ("\"([^\"\\\\]*(?:\\\\.[^\"\\\\]*)*)\",?|([^,]+),?|," text) (push (or quoted unquoted) fields)) (nreverse fields))) ;;;----------------------------- ;; CL has no obvious equivalent to Text::ParseWords ;;;----------------------------- (defparameter *line* "XYZZY,\"\",\"O'Reilly, Inc\",\"Wall, Larry\",\"a \\\"glug\\\" bit,\",5,\"Error, Core Dumped\"") (let ((fields (parse-csv *line*))) (loop for i below (length fields) do (format t "~D : ~A~%" i (elt fields i)))) ;;0 : XYZZY ;;1 : ;;2 : O'Reilly, Inc ;;3 : Wall, Larry ;;4 : a \"glug\" bit, ;;5 : 5 ;;6 : Error, Core Dumped ;;;----------------------------- ;;; @@PLEAC@@_2.1 ;;;----------------------------- (if (every #'digit-char-p string) (progn ;; is a number ) (progn ;; is not )) ;;;----------------------------- ;;; Strings and numbers are separate data types in CL. These tests ;;; check whether a string represents a number (unless (every #'digit-char-p string) (format *error-output* "string has nondigits")) (unless (scan "^\\d+$" string) ; rejects -3 (format *error-output* "not a natural number")) (unless (scan "^-?\\d+$" string) ; rejects +3 (format *error-output* "not an integer")) (unless (scan "^[+-]?\\d+$" string) (format *error-output* "not an integer")) (unless (scan "^-?(?:\\d+(?:\\.\\d*)?|\\.\\d+)$" string) (format *error-output* "not an integer")) (unless (scan "^([+-]?)(?=\\d|\\.\\d)\\d*(\\.\\d*)?([Ee]([+-]?\\d+))?$" string) (format *error-output* "not a C float")) ;;;----------------------------- (defun getnum (string) "This function is not safe to call on untrusted input." (with-input-from-string (is (regex-replace #?"\s+$" (regex-replace #?"^\s+" string "") "")) (let ((num (read is nil nil nil))) (and ;; Make sure there's no junk following the number (eql (read-char is nil :eof nil) :eof) (numberp num) num)))) (defun is-numeric (string) (not (null (getnum string)))) ;;;----------------------------- ;;; @@PLEAC@@_2.2 ;;;----------------------------- (defun equal-to-accuracy (number1 number2 dp) "Return non-nil if NUMBER1 and NUMBER2 are equal to DP number of decimal places." (let* ((difference (abs (- number1 number2))) (delta (expt 10 (- dp)))) (< difference delta))) ;;;----------------------------- (let* ((wage 536) ; $5.36/hour (week (* 40 wage))) ; $214.40 (format t "One week's wage is: $~,2F~%" (/ week 100))) ;;One week's wage is: $214.40 ;;;----------------------------- ;;; @@PLEAC@@_2.3 ;;;----------------------------- (setf rounded (format nil "~FORMATF" unrounded)) ;;;----------------------------- (let* ((a 0.255) (b (/ (fround a 0.01) 100))) (format t "Unrounded: ~F~%Rounded: ~,2F~%" a b)) ;;Unrounded: 0.255 ;;Rounded: 0.26 ;;;----------------------------- (progn (format t "~&number~Tint~Tfloor~Tceil~%") (let ((as '(3.3 3.5 3.7 -3.3))) (dolist (a as) (format t "~@{~4,1F~^~T~}~%" a (ftruncate a) (ffloor a) (fceiling a))))) ;;number int floor ceil ;; 3.3 3.0 3.0 4.0 ;; 3.5 3.0 3.0 4.0 ;; 3.7 3.0 3.0 4.0 ;;-3.3 -3.0 -4.0 -3.0 ;;;----------------------------- ;;; @@PLEAC@@_2.4 ;;;----------------------------- (defun dec2bin (dec) (format nil "~2R" dec)) ;;;----------------------------- (defun bin2dec (bin) "BIN is a string containing only #\1 and #\0 characters. Returns its integer equivalent." (read (make-string-input-stream (concatenate 'string "#b" bin)) t nil nil)) ;;;----------------------------- (setf num (bin2dec "0110110")) ; $num is 54 (setf binstr (dec2bin 54)) ; binstr is "110110" ;;;----------------------------- ;;; @PLEAC@@_2.5 ;;;----------------------------- (loop for i from x upto y do ;; i is set to every integer from X to Y, inclusive ) (loop for i from y downto x do ;; i is set to every integer from Y to X, inclusive ) (do ((i x (1+ i))) ((> i y)) ;; i is set to every integer from X to Y, inclusive ) (loop for i from x upto y by 7 do ;; i is set to every integer from X to Y, stepsize = 7 ) ;;;----------------------------- (format t "Infancy is: ~{~A~^ ~}~%" (loop for i from 0 to 2 collect i)) (format t "Toddling is: ~{~A~^ ~}~%" (loop for i from 3 to 4 collect i)) (format t "Childhood is: ~{~A~^ ~}~%" (loop for i from 5 to 12 collect i)) ;;Infancy is: 0 1 2 ;;Toddling is: 3 4 ;;Childhood is: 5 6 7 8 9 10 11 12 ;;;----------------------------- ;;; @@PLEAC@@_2.6 ;;;----------------------------- ;;; CL has a built in FORMAT directive (used below) to print out ;;; numbers as roman numerals, but doesn't have a built-in mechanism ;;; to convert back. Here are some rough CL equivalents of Perl's ;;; Roman package. (defun romanchar->num (x) (case (char-downcase x) (#\m 1000) (#\d 500) (#\c 100) (#\l 50) (#\x 10) (#\v 5) (#\i 1) (t 0))) (defun isroman (string) (every #'(lambda (c) (plusp (romanchar->num c))) string)) (defun arabic (string) (let ((digits (map 'list #'romanchar->num string))) (reduce #'+ (mapcar #'(lambda (digit next-digit) (if (< digit next-digit) (- digit) digit)) digits (append (rest digits) '(0)))))) (setf roman (format nil "~@R" arabic)) ; convert to roman numerals (when (isroman roman) (setf arabic (arabic roman))) ; convert from roman numerals ;;;----------------------------- (setf roman-fifteen (format nil "~@R" 15)) (format t "Roman for fifteen is ~A~%" roman-fifteen) (setf arabic-fifteen (arabic roman-fifteen)) (format t "Converted back, ~A is ~A~%" roman-fifteen arabic-fifteen) ;;Roman for fifteen is XV ;;Converted back, XV is 15 ;;;----------------------------- ;;; @@PLEAC@@_2.7 ;;;----------------------------- (setf random (+ (random (+ y (- x) 1)) x) ;;;----------------------------- (setf random (+ (random 51) 25)) (format t "~A~%" random) ;; If you wanted to use floats... (+ (random 51.0) 25.0) ;;;----------------------------- (setf elt (aref array (random (length array)))) ;;;----------------------------- (setf chars "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz012345789!@$%^&*") (setf password (coerce (loop repeat 8 collect (aref chars (random (length chars)))) 'string)) ;;;----------------------------- ;;; @@PLEAC@@_2.8 ;;;----------------------------- ;; CL intentionally does not have an equivalent of Perl's srand(); you ;; can call MAKE-RANDOM-STATE but its inner workings are not exposed. (setf *random-state* (make-random-state t)) ;;;----------------------------- ;;; @@PLEAC@@_2.9 ;;;----------------------------- ;; In CL, RANDOM is supposed to return a truly random, ;; uniformly-distributed value. (setf random (random)) ;;;----------------------------- ;;; @@PLEAC@@_2.10 ;;;----------------------------- ;; Note: (random 1.0) is the same as calling Perl's rand() with no ;; arguments. (defun gaussian-rand () (do* ((u1 (1- (* 2 (random 1.0))) (1- (* 2 (random 1.0)))) (u2 (1- (* 2 (random 1.0))) (1- (* 2 (random 1.0)))) (w (+ (* u1 u1) (* u2 u2)) (+ (* u1 u1) (* u2 u2)))) ((< w 1.0) (let* ((w2 (sqrt (/ (* -2 (log w)) w))) (g2 (* u1 w2)) (g1 (* u2 w2))) ;; No need for wantarray in CL because functions can return ;; multiple values. (values g1 g2))))) ;;;----------------------------- (defun weight-to-dist (weights) "Takes a hash mapping key to weight and returns a hash mapping key to probability. WEIGHTS is an alist." (let ((dist (make-hash-table)) (total (loop for (key . ignored-value) in weights sum key))) (loop for (key . weight) in weights do (setf (gethash key dist) (/ weight total))) dist)) (defun weighted-rand (dist) "Takes a hash mapping key to probability, and returns the corresponding element." (loop for rand = (random 1.0) do (loop for key being the hash-keys of dist using (hash-value weight) do (decf rand weight) (when (minusp rand) (return-from weighted-rand key))))) ;;;----------------------------- ;; gaussian_rand as above (let* ((mean 25) (sdev 2) (salary (+ (* (gaussian-rand) sdev) mean))) (format t "You have been hired at $~,2F~%" salary)) ;;;----------------------------- ;;; @@PLEAC@@_2.11 ;;;----------------------------- (defun deg2rad (degrees) (* (/ degrees 180) pi)) (defun rad2deg (radians) (* (/ radians pi) 180)) ;;;----------------------------- (setf radians (deg2rad degrees)) (setf degrees (rad2deg radians)) ;;;----------------------------- ;; deg2rad and rad2deg defined either as above (defun degree-sine (degrees) (let ((radians (deg2rad degrees))) (sin radians))) ;;;----------------------------- ;;; @@PLEAC@@_2.12 ;;;----------------------------- ;; tangent is built in to CL (tan theta) ;;;----------------------------- (setf y (acos 3.7)) ;;;----------------------------- (setf y (tan (/ pi 2))) ;;;----------------------------- ;;; @@PLEAC@@_2.13 ;;;----------------------------- (setf log-e (log value)) ;;;----------------------------- (setf log-10 (log value 10)) (setf log-base-whatever (log value base)) ;;;----------------------------- ;; In CL, don't need custom log_base function as LOG already does it ;;;----------------------------- (setf answer (log 10000 10)) (format t "log10(10,000) = ~D~%" answer) ;; log10(10,000) = 4.0 ;;;----------------------------- (format t "log2(1024) = ~A~%" (log 1024 2)) ;; log2(1024) = 10.0 ;;;----------------------------- ;;; @@PLEAC@@_2.14 ;;;----------------------------- ;;;----------------------------- (defun mmult (m1 m2) (check-type m1 (array * (* *))) (check-type m2 (array * (* *))) (let* ((m1-rows (array-dimension m1 0)) (m1-columns (array-dimension m1 1)) (m2-rows (array-dimension m2 0)) (m2-columns (array-dimension m2 1))) (unless (= m1-columns m2-rows) (error 'simple-type-error :format-control "IndexError: matrices don't match: ~A != ~A" :format-args (list m1-columns m2-rows))) (let ((result (make-array (list m1-rows m2-columns)))) (dotimes (i m1-rows) (dotimes (j m2-columns) (setf (aref result i j) (loop for k from 0 below m1-columns summing (* (aref m1 i k) (aref m2 k j)))))) result))) (defun range (n) (loop for i from 0 below n collect i)) ;; This isn't really necessary in CL, but is here to match the Perl ;; function. (defun veclen (vector) (check-type vector simple-vector) (array-dimension vector 0)) ;; This isn't really necessary in CL, but is here to match the Perl ;; function. (defun matdim (matrix) (values (array-dimension matrix 0) (array-dimension matrix 1))) ;;;----------------------------- ;; Can't find an obvious equivalent to PDL (yet) ;;;----------------------------- (setf x #2a((3 2 3) (5 9 8)) y #2a((4 7) (9 3) (8 1))) (setf z (mmult x y)) ;;;----------------------------- ;;; @@PLEAC@@_2.15 ;;;----------------------------- ;; Complex numbers are built in to CL so there is no need to compute ;; their product by hand. ;;;----------------------------- ;; c = a * b using built-in CL functionality (setf c (* a b)) ;;;----------------------------- ;; Again, no need to do complex number stuff by hand. ;;;----------------------------- (setf a #c(3 5)) (setf b #c(2 -2)) (setf c (* a b)) (format t "c = ~D+~Di~%" (realpart c) (imagpart c)) ;; c = 16+4i ;;;----------------------------- (setf c (* #c(3 5) #c(2 -2))) (setf d #c(3 4)) (let ((sqrt-d (sqrt d))) (format t "sqrt(3+4i) = ~D+~Di~%" (realpart sqrt-d) (imagpart sqrt-d))) ;; sqrt(3+4i) = 2.0+1.0i ;;;----------------------------- ;;; @@PLEAC@@_2.16 ;;;----------------------------- (defun hex (string) (parse-integer string :radix 16 :start 2)) ; PARSE-INTEGER dislikes "0x" (defun oct (string) (parse-integer string :radix 8)) (setf number (hex hexadecimal)) (setf number (oct octal)) ;;;----------------------------- (format t "Gimme a number in decimal, octal, or hex: ") (setf num (read-line)) (when num (let ((num (chomp num))) (format t "~D ~:*~8R ~:*~X" (cond ((scan "^0x" num) (hex num)) ((scan "^0" num) (oct num)) (t (parse-integer num)))))) ;;;----------------------------- (format t "Enter file permission in octal: ") (setf permissions (read-line)) (unless permissions (error "Exiting...")) (let ((permissions (chomp permissions))) (format t "The decimal value is ~A~%" (oct permissions))) ;;;----------------------------- ;;; @@PLEAC@@_3.1 ;;;----------------------------- ;; use GET-DECODED-TIME to fetch the time (multiple-value-bind (second minute hour date month year day-of-week dst-p tz) (get-decoded-time) year) ; prints out year using standard library ;; alternatively date-calc provides overlapping functionality (multiple-value-bind (year month day h m s) (today-and-now) ; imported from date-calc year) ; date-calc approach ;; how to print out current date as "YYYY-MM-DD" (in approved ISO 8601 fashion) (multiple-value-bind (year month day) (today) ;imported from date-calc (format t "The current date is ~A-~2,'0d-~2,'0d" year month day)) ;; Alternatively, you could use the format-time function from the ;; CyberTiggyr-Time package: (format-time t "%Y-%m-%d" (get-universal-time)) ;; As you can see, format-time operates on epoch time ;;; @@PLEAC@@_3.2 ;;;----------------------------- ;; to encode time into universal time using date-calc (multiple-value-bind (second minute hour date month year day-of-week dst-p tz) (get-decoded-time) (encode-universal-time second minute hour date month year)) ;; The last two return values for get-decoded-time correspond to ;; daylight savings and the timezone. Both are useful for ;; timezone-related arithmetic. ;;; @@INCOMPLETE@@ ;; An example of a GMT computation with and without daylight savings ;; is appropriate here since the built-in perl functions handle this. ;;; @@PLEAC@@_3.3 ;;;----------------------------- (let ((time (get-universal-time))) ; get epoch seconds (multiple-value-bind (second minute hour day month year day-of-week dst-p tz) (decode-universal-time time) ; decode and... (list day month year hour minute second))) ; return ;;; @@PLEAC@@_3.4 ;;;----------------------------- ;; when using universal time you add or subtract seconds ;; here we add one hour (let ((firstdate (encode-universal-time 0 12 6 23 11 2006)) (onehour (* 60 60 1))) (+ onehour firstdate)) ;; or you could use date-calc function ;; here we'll add one day (add-delta-ymdhms 2006 11 24 18 12 0 0 0 1 0 0 0) ;;; @@PLEAC@@_3.5 ;;;----------------------------- ;; We'll use the epoch seconds to perform subtraction, ;; then divide by seconds per day (let ((first (encode-universal-time 52 45 20 13 12 1901)) (second (encode-universal-time 7 14 3 19 1 2038))) (float (/ (- second first) (* 60 60 24)))) ;; method two uses delta-days from the date-calc package: (delta-days 1901 12 13 2038 1 19) ;; delta-days does not yet have the granularity of seconds, minutes or hours. ;;; @@PLEAC@@_3.6 ;;;----------------------------- ;; The week of the year is computed as follows: (week-number 2006 12 1) ; week-of-year is imported from date-calc ;; similar functions exist for day of week, day of year, etc. ;;; @@PLEAC@@_3.7 ;;;----------------------------- (parse-time "2006-08-20") ;; PARSE-TIME can recognize many of the commonly found date formats ; format-time comes with several ways to format... (format-time t *format-time-date* (get-universal-time)) ; results in: 25 Nov 2006 (format-time t *format-time-iso8601-short* (get-universal-time)) ; results in: 20061125T172917 -5 (format-time t "%Y-%m-%d" (get-universal-time)) ; results in: 2006-11-25 ;;; @@PLEAC@@_4.0 ;;;----------------------------- (setf nested '("this" "that" "the" "other") (setf nested '("this" "that" ("the" "other"))) ;;;----------------------------- (setf tune '("The" "Star-Spangled" "Banner")) ;;; @@PLEAC@@_4.1 ;;;----------------------------- (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) ;;;----------------------------- ;;; @@PLEAC@@_4.2 ;;;----------------------------- (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. ;;;----------------------------- ;; @@INCLUDE@@ include/commonlisp/ch04/commify_series.lisp ;;;----------------------------- ;;; @@PLEAC@@_4.3 ;;;----------------------------- ;; 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) ;;;----------------------------- ;;; @@PLEAC@@_4.4 ;;;----------------------------- (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"). ;;;----------------------------- ;;; @@PLEAC@@_4.5 ;;;----------------------------- ;; 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))) ;;;----------------------------- ;;; @@PLEAC@@_4.6 ;;;----------------------------- (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*) ;; PERL-GREP defined in Appendix (setf uniqu (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*) ;;;----------------------------- ;;; @@PLEAC@@_4.7 ;;;----------------------------- ;; 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))) ;;;----------------------------- ;;; @@PLEAC@@_4.8 ;;;----------------------------- (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. ;;;----------------------------- ;;; @@PLEAC@@_4.9 ;;;----------------------------- ;; 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 ;;;----------------------------- ;;; @@PLEAC@@_4.10 ;;;----------------------------- ;; 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))) ;;;----------------------------- ;;; @@PLEAC@@_4.11 ;;;----------------------------- ;; 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))) ;;;----------------------------- ;;; @@PLEAC@@_4.12 ;;;----------------------------- (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 ))) ;;;----------------------------- ;;; @@PLEAC@@_4.13 ;;;----------------------------- (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)) ;;;----------------------------- ;;; @@PLEAC@@_4.14 ;;;----------------------------- (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) ;;;----------------------------- ;;; @@PLEAC@@_4.16 ;;;----------------------------- ;;; 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)))) ;;;----------------------------- ;;; @@PLEAC@@_4.17 ;;;----------------------------- (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) ;;; @@PLEAC@@_4.19 ;;;----------------------------- (defun factorial (n) (loop for result = 1 then (* result i) for i from 1 to n finally (return result))) (factorial 500) ; => 1220136... (1135 digits total) (defun map-vector-permutations (function vector) (labels ((permute (end) (if (= end 0) (funcall function vector) (dotimes (i end) (rotatef (aref vector (1- end)) (aref vector i)) (permute (1- end)) (rotatef (aref vector (1- end)) (aref vector i)))))) (permute (length vector)))) (map-vector-permutations #'print #(1 2 3)) (defun map-list-permutations (function list) (labels ((permute (tail) (if (null tail) (funcall function list) (loop for subtail on tail do (rotatef (car tail) (car subtail)) (permute (cdr tail)) (rotatef (car tail) (car subtail)))))) (permute list))) (map-list-permutations #'print '(1 2 3)) ;;; permute words in each line of input stream (loop for line = (read-line *standard-input* nil nil) while line do (map-list-permutations (lambda (words) (format t "~{~A~^ ~}~%" words)) (split "\\s+" line))) ;;; (let ((memo (make-hash-table))) (setf (gethash 0 memo) 1) (defun factorial (n) (or (gethash n memo) (setf (gethash n memo) (* n (factorial (1- n))))))) (defun nth-pattern (n length) (loop for i from length downto 1 for (new-n elem) = (multiple-value-list (truncate n i)) collect elem do (setf n new-n))) (defun pattern-permutation (pattern) (loop with source = (cons nil (loop for i from 0 below (length pattern) collect i)) for i in pattern for pred = (nthcdr i source) for (elem . rest) = (cdr pred) collect elem do (setf (cdr pred) rest))) (defun nth-permutation (n length) (pattern-permutation (nth-pattern n length))) ;;; @@PLEAC@@_5.0 ;;;----------------------------- (setf age (make-hash-table :test 'equal)) (setf (gethash "Nat" age) 24 (gethash "Jules" age) 25 (gethash "Josh" age) 17) ;;----------------------------- (mapcar #'(lambda (l) (setf (gethash (car l) age) (cdr l))) '(("Nat" . 24) ("Jules" . 25) ("Josh" . 17))) ;;----------------------------- (defparameter *food-color* (make-hash-table :test 'equal)) (mapcar #'(lambda (l) (setf (gethash (car l) *food-color*) (cdr l))) '(("Apple" . "red") ("Banana" . "yellow") ("Lemon" . "yellow") ("Carrot" . "orange"))) ;;;----------------------------- (mapcar #'(lambda (l) (setf (gethash (car l) *food-color*) (cdr l))) '((Apple . "red") (Banana . "yellow") (Lemon . "yellow") (Carrot . "orange"))) ;;;----------------------------- ; @@PLEAC@@_5.1 ;;;----------------------------- (setf (gethash key hash) value) ;;;----------------------------- ;; *FOOD-COLOR* defined per the introduction (setf (gethash "Raspberry" *food-color*) "pink") (format t "Known foods:~%~{~A~%~}" (loop for f being the hash-keys of *food-color* collect f)) ;;Known foods: ;;Apple ;;Banana ;;Lemon ;;Carrot ;;;----------------------------- ;;; @@PLEAC@@_5.2 ;;;----------------------------- ;; does HASH have a value for KEY ? (if (nth-value 1 (gethash key hash)) (progn ;; it exists ) (progn ;; it doesn't )) ;;;----------------------------- ;; *FOOD-COLOR* per the introduction (dolist (name '("Banana" "Martini")) (format t "~A is a ~A.~%" name (if (nth-value 1 (gethash name *food-color*)) "food" "drink"))) ;;Banana is a food. ;;Martini is a drink. ;;;----------------------------- (setf age (make-hash-table :test 'equal)) (setf (gethash "Toddler" age) 3) (setf (gethash "Unborn" age) 0) (setf (gethash "Phantasm" age) nil) (dolist (thing '("Toddler" "Unborn" "Phantasm" "Relic")) (format t "~a: " thing) (multiple-value-bind (defined exists) (gethash thing age) (when exists (format t "Exists ") (when defined (format t "Defined ") ;; 0 is "true" in CL, so explicitly mimic Perl (unless (zerop defined) (format t "True "))))) (format t "~%")) ;;Toddler: Exists Defined True ;;Unborn: Exists Defined ;;Phantasm: Exists ;;Relic: ;;;----------------------------- ;;; @@INCOMPLETE@@ ;;; @@PLEAC@@_5.3 ;;;----------------------------- ;; remove KEY and its value from HASH (remhash key hash) ;;;----------------------------- ;; *FOOD-COLOR* as per Introduction (defun print-foods () (let ((foods (hash-keys *food-color*))) ; HASH-KEYS defined in Appendix (format t "Keys: ~{~A~^ ~}~%Values: ~{~A~^ ~}~%" foods (loop for food in foods collect (or (gethash food *food-color*) "(undef)"))))) (format t "Initially~%") (print-foods) (format t "~%With Banana undef~%") (setf (gethash "Banana" *food-color*) (format t "~%With Banana deleted~%") (remhash "Banana" *food-color*) (print-foods) ;; Initially ;; Keys: Apple Banana Lemon Carrot ;; Values: red yellow yellow orange ;; ;; With Banana undef ;; Keys: Apple Banana Lemon Carrot ;; Values: red (undef) yellow orange ;; ;; With Banana deleted ;; Keys: Apple Lemon Carrot ;; Values: red yellow orange ;;;----------------------------- (mapc #'(lambda (key) (remhash key *food-color*)) '("Banana" "Apple" "Cabbage")) ;;;----------------------------- ;;; @@PLEAC@@_5.4 ;;;----------------------------- (loop for key being the hash-keys of hash using (hash-value value) ;; do something with KEY and VALUE ) ;;;----------------------------- (maphash #'(lambda (key value) ;; do something with KEY and VALUE ) hash) ;;;----------------------------- ;; *FOOD-COLOR* per the introduction (loop for food being the hash-keys of *food-color* using (hash-value color) do (format t "~A is ~A.~%" food color)) ;; Apple is red. ;; Banana is yellow. ;; Lemon is yellow. ;; Carrot is orange. ;;;----------------------------- (maphash #'(lambda (food color) (format t "~A is ~A.~%" food color)) *food-color*) ;; Apple is red. ;; Banana is yellow. ;; Lemon is yellow. ;; Carrot is orange. ;;;----------------------------- ;; No equivalent ;;;----------------------------- (loop for food in (sort (hash-keys *food-color*) 'string-lessp) do (format t "~A is ~A~%" food (gethash food *food-color*))) ;; Apple is red ;; Banana is yellow ;; Carrot is orange ;; Lemon is yellow ;;;----------------------------- ;; Not sure what the following Perl is supposed to do: ;;while ( ($k,$v) = each %food_color ) { ;; print "Processing $k\n"; ;; keys %food_color; # goes back to the start of %food_color ;;} ;;;----------------------------- (use-package :cl-ppcre) (use-package :iterate) ;; The following handles the case that the Perl handles where there is ;; no filename (and it then opens '-'. To do the same thing you'd do ;; something like: (countfrom *standard-input*) and this method would ;; automatically get triggered instead of the one requiring a ;; filename. (defmethod countfrom ((stream stream)) (let ((from (make-hash-table :test 'equal))) (with-open-stream (input stream) (iter (for line in-stream input using 'read-line) (register-groups-bind (person) ("^From: (.*)\\s" line) (incf (gethash person from 0))))) (loop for person in (sort (hash-keys from) 'string-lessp) do (format t "~A: ~A~%" person (gethash person from))))) ;; This method is a bit of a hack in that it shouldn't really assume ;; that the string designates a filename, but for the purposes of this ;; example that seems ok. Note that it just calls OPEN directly ;; without WITH-OPEN-FILE because it knows that the STREAM version of ;; this method will always close it. (defmethod countfrom ((filename string)) (countfrom (open filename))) ;;;----------------------------- ;;; @@PLEAC@@_6.0 ;;;----------------------------- ;; Note that the following do not modify STRING, which may be ;; different from how the Perl snippet works. (use-package :cl-ppcre) ; assumed by all of section 6.0's code (scan pattern string) (regex-replace pattern string replacement) ;;;----------------------------- (scan "sheep" meadow) ; Non-nil if MEADOW contains "sheep" (not (scan "sheep" meadow)) ; Non-nil if MEADOW doesn't contain "sheep" (regex-replace "old" meadow "new") ; Replace "old" with "new" in MEADOW ;;;----------------------------- ;; Fine bovines demand fine toreadors. ;; Muskoxen are a polar ovibovine species. ;; Grooviness went out of fashion decades ago. ;;;----------------------------- ;; Ovines are found typically in oviaries. ;;;----------------------------- (when (scan (create-scanner "\\bovines?\\b" :case-insensitive-mode t) meadow) (format t "Here be sheep!")) ;;;----------------------------- (setf my-string "good food") (setf my-string (regex-replace "o*" my-string "e")) ;;;----------------------------- ;; Not sure how to reproduce the same output. The above ;; REGEX-REPLACE just prepends "e" every time (but I'm not ;; sure that's wrong). ;;;----------------------------- (with-input-from-string (s "ababacaca ") (let ((match (scan-to-strings "(a|ba|b)+(a|ac)+" (read-line s)))) (format t "~A~%" match))) ;; ababa ;;;----------------------------- ;;% echo ababacaca | ;; awk 'match($0,/(a|ba|b)+(a|ac)+/) { print substr($0, RSTART, RLENGTH) }' ;;ababacaca ;;;----------------------------- ;; Since there is no magic $_ variable in CL, using MY-STRING as an ;; example. (register-groups-bind (num) ("(\\d+)" some-string) (format t "Found number ~A~%" num)) ;;;----------------------------- ;; Again, MY-STRING is a placeholder for $_. (defparameter *numbers* (mapcar #'parse-integer (all-matches-as-strings "(\\d+)" my-string))) ;;;----------------------------- (defparameter *digits* "1234567890") (defparameter *nonlap* (all-matches-as-strings "(\\d\\d\\d)" *digits*)) (defparameter *yeslap* (all-matches-as-strings "(?=\\d\\d\\d)" *digits*)) (format t "Non-overlapping: ~{~A~^ ~}~%Overlapping: ~{~A~^ ~}~%" *nonlap* *yeslap*) ;; Non-overlapping: 123 456 789 ;; Overlapping: ;; Note that CL-PPCRE seems to treat ?= differently from Perl, hence ;; the lack of output for Overlapping. ;;;----------------------------- ;; CL-PPCRE doesn't support $` etc after a match (it does for ;; REGEX-REPLACE but that wouldn't work here. ;;;----------------------------- ;;; @@PLEAC@@_6.1 ;;;----------------------------- (setf dst (regex-replace "that" src "this")) ;;;----------------------------- ;; No difference from previous. ;;;----------------------------- ;; strip to basename (defparameter *progname* (regex-replace "^.*/" (car *posix-argv*) "")) ;; Make All Words Title-Cased ;; Unfortunately \u and \L aren't supported by CL-PPCRE (AFAICT), but ;; CL does have built-in support for capitalization. (defparameter *capword* (string-capitalize *word*)) ;; /usr/man/man3/foo.1 changes to /usr/man/cat3/foo.1 (defparameter *catpage* (regex-replace "man(?=\\d)" *manpage* "cat")) ;;;----------------------------- (defparameter *bindirs* '("/usr/bin" "/bin" "/usr/local/bin")) (defparameter *libdirs* (mapcar #'(lambda (dir) (regex-replace "bin" dir "lib")) *bindirs*)) (format t "~{~A~^ ~}~%" *libdirs*) ;; /usr/lib /lib /usr/local/lib ;;;----------------------------- (setf a (regex-replace-all "x" b "y")) ; copy B and then change A ;; CL-PPCRE doesn't support returning the count of changed characters. ;;;----------------------------- ;;; @@PLEAC@@_6.2 ;;;----------------------------- (when (scan "^[A-Za-z]+$" var) ;; it is purely alphabetic ) ;;;----------------------------- (when (scan "^[^\\W\\d_]+$" var) ;; it is purely alphabetic ) ;;;----------------------------- ;; This seems to work without setting the locale. Not sure why but ;; there ya' go. (let ((data '("silly" "façade" "coöperate" "niño" "Renée" "Molière" "hæmoglobin" "naïve" "tschüß" "random!stuff#here"))) (loop for word in data do (if (scan "^[^\W\d_]+$" word) (format t "~A: alphabetic~%" word) (format t "~A: line noise~%" word)))) ;;silly: alphabetic ;;façade: line noise ;;coöperate: alphabetic ;;niño: alphabetic ;;Renée: alphabetic ;;Molière: alphabetic ;;hæmoglobin: alphabetic ;;naïve: alphabetic ;;tschüß: alphabetic ;;random!stuff#here: line noise ;;;----------------------------- ;;; @@PLEAC@@_6.3 ;;;----------------------------- ;; "\\S+" ; as many non-whitespace bytes as possible ;; "[A-Za-z'-]+" ; as many letters, apostrophes, and hyphens ;;;----------------------------- ;; "\\b([A-Za-z]+)\\b" ; usually best ;; "\\s([A-Za-z]+)\\s" ; fails at ends or w/ punctuation ;;;----------------------------- ;;; @@PLEAC@@_6.4 ;;;----------------------------- ;; It makes more sense for this just to be a function in CL rather ;; than a separate "script". (defun hostname->address (hostname) (format nil "~{~A~^.~}" (or (ignore-errors (concatenate 'list (sb-bsd-sockets:host-ent-address (sb-bsd-sockets:get-host-by-name hostname)))) (list "???")))) (defun resname (stream) (let ((matcher (create-scanner " ( # capture the hostname in $1 (?: # these parens for grouping only (?! [-_] ) # lookahead for neither underscore nor dash [\\w-] + # hostname component \\. # and the domain dot ) + # now repeat that whole thing a bunch of times [A-Za-z] # next must be a letter [\\w-] + # now trailing domain part ) # end of $1 capture" :extended-mode t))) (iter (for line in-stream stream using 'read-line) (format t "~A" (regex-replace-all matcher line #'(lambda (target-string start end match-start match-end reg-starts reg-ends) (declare (ignore start end reg-starts reg-ends)) (let ((hostname (subseq target-string match-start match-end))) (concatenate 'string hostname " [" (hostname->address hostname) "]")))))))) ;;;----------------------------- (regex-replace-all (create-scanner " # replace \\# # a pound sign (\\w+) # the variable name \\# # another pound sign" :extended-mode t) my-string ; using this instead of implicit $_ #'(lambda (target-string start end match-start match-end reg-starts reg-ends) (declare (ignore start end reg-starts reg-ends)) (let ((symb (string-upcase (subseq target-string (elt reg-starts 0) (elt reg-ends 0))))) (format nil "~A" (symbol-value (intern symb)))))) ;;;----------------------------- ;; I'm not sure there's any way to do this in CL. There's ;; no guarantee that a local variable hasn't been optimized ;; away, for example. EVAL operates in the null lexical ;; environment, so can't be used for this purpose. ;;;----------------------------- ;;; @@PLEAC@@_7.0 ;;;----------------------------- (with-open-file (input "/usr/local/widgets/data") ;; No need for "die" like call here b/c WITH-OPEN-FILE will do it ;; automatically. (iter (for line in-stream input using 'read-line) (when (scan "blue" line) (format t "~A~%" line))) ;; No need for explicit CLOSE here b/c WITH-OPEN-FILE will do it ;; automatically. ) ;;;----------------------------- (let ((var *standard-input*)) (mysub var logfile)) ;;;----------------------------- ;; The Perl example here is showing the "object-oriented" style of ;; file manipulation. In CL it isn't any different than the above. ;; However we will use this opportunity to demonstrate how to ;; "manually" open/close a file without WITH-OPEN-FILE. (let ((input (open "/usr/local/widgets/data"))) (iter (for line in-stream input using 'read-line) (setf line (chomp line)) (when (scan "blue" line) (format t "~A~%" line))) ;; Don't do this, either use WITH-OPEN-FILE or use UNWIND-PROTECT as ;; illustrated later. (close line)) ;;;----------------------------- (unwind-protect (progn (iter (for line in-stream *standard-input* using 'read-line) (unless (scan "\\d" line) (warn "No digit found.~%")) (format t "Read: ~A~%" line))) ;; Not normally a good idea to do the following; just matching the ;; Perl. (close *standard-output*)) ;;;----------------------------- ;; No need for explicit die, OPEN will throw an exception. (defparameter *logfile* (open "/tmp/log" :direction :output)) ;;;----------------------------- (close *fh*) ; no need for die() ;;;----------------------------- (let ((*standard-output* *logfile*)) ; switch to *LOGFILE* for output (format t "Countdown initiated ...~%")) ;; return to original output (format t "You have 30 seconds to reach minimum safety distance.~%") ;;;----------------------------- ;;; @@PLEAC@@_7.1 ;;;----------------------------- ;; For reading is the default, no need for "<" or equivalent. No need ;; for explicit die()-like call either. Note also that you should use ;; WITH-OPEN-FILE instead of a raw OPEN wherever possible. (defparameter *source* (open path)) (defparameter *sink* (open path :direction :output)) ;;;----------------------------- #+sbcl (progn (defparameter *source* (sb-posix:open path sb-posix:o-rdonly)) (defparameter *sink* (sb-posix:open path sb-posix:o-wronly))) ;;;----------------------------- ;; There is no equivalent of Perl's "object-oriented" file interface ;; (arguably, the standard mechanism is already object-oriented). ;;;----------------------------- #+sbcl (progn (defparameter *filehandle* (sb-posix:open name flags)) (defparameter *filehandle* (sb-posix:open name flags perms))) ;;;----------------------------- (defparameter *fh* (open path)) #+sbcl (defparameter *fh* (sb-posix:open path sb-posix:o-rdonly)) ;;;----------------------------- (defparameter *fh* (open path :direction :output)) #+sbcl (defparameter *fh* (sb-posix:open path (logior sb-posix:o-wronly sb-posix:o-trunc sb-posix:o-creat) #o600)) ;;;----------------------------- #+sbcl (progn (defparameter *fh* (sb-posix:open path (logior sb-posix:o-wronly sb-posix:o-excl sb-posix:o-creat))) (defparameter *fh* (sb-posix:open path (logior sb-posix:o-wronly sb-posix:o-excl sb-posix:o-creat) #o600))) ;;;----------------------------- (defparameter *fh* (open path :direction :output :if-exists :append :if-does-not-exist :create)) #+sbcl (progn (defparameter *fh* (sb-posix:open path (logior sb-posix:o-wronly sb-posix:o-append sb-posix:o-creat))) (defparameter *fh* (sb-posix:open path (logior sb-posix:o-wronly sb-posix:o-append sb-posix:o-creat) #o600))) ;;;----------------------------- (defparameter *fh* (sb-posix:open path (logior sb-posix:o-wronly sb-posix:o-append))) ;;;----------------------------- (defparameter *fh* (open path :direction :io :if-exists :overwrite)) #+sbcl (defparameter *fh* (sb-posix:open path sb-posix:o-rdwr)) ;;;----------------------------- #+sbcl (progn (defparameter *fh* (sb-posix:open path (logior sb-posix:o-rdwr sb-posix:o-creat))) (defparameter *fh* (sb-posix:open path (logior sb-posix:o-rdwr sb-posix:o-creat) #o600))) ;;;----------------------------- #+sbcl (progn (defparameter *fh* (sb-posix:open path (logior sb-posix:o-rdwr sb-posix:o-excl sb-posix:o-creat))) (defparameter *fh* (sb-posix:open path (logior sb-posix:o-rdwr sb-posix:o-excl sb-posix:o-creat) #o600))) ;;;----------------------------- ;;; @@PLEAC@@_7.2 ;;;----------------------------- ;; The machinations that the Perl example is doing is dealing with the ;; fact that Perl normally ignores leading whitespace in a filename. ;; This shouldn't be necessary in CL (since the filename doesn't also ;; contain the input mode, as it does in Perl), but the following ;; example illustrates how to do the same thing anyway. (setf *filename* (regex-replace "^(\\s)" *filename* "./$1")) ;; I'm not sure what the \0 being appended in the Perl example is for, ;; but SBCL, at least, doesn't seem to even allow NUL in a namestring ;; (filename), so it's not shown here. (defparameter *handle* (open *filename*)) ;;;----------------------------- #+sbcl (defparameter *handle* (sb-posix:open *filename* sb-posix:o-rdonly)) ;;;----------------------------- (defparameter *filename* (second *posix-argv*)) (defparameter *input* (open *filename*)) ;;;----------------------------- (defparameter *output* (open *filename* :direction :output)) ;;;----------------------------- #+sbcl (defparameter *output* (sb-posix:open *filename* (logior sb-posix:o-wronly sb-posix:o-trunc))) ;;;----------------------------- (setf *file* (regex-replace "^(\\s)" *file* "./$1")) (defparameter *output* (open *file* :direction :output)) ;;;----------------------------- ;;; @@PLEAC@@_7.3 ;;;----------------------------- ;;; @@INCOMPLETE@@ ;;; @@INCOMPLETE@@ ;;; @@PLEAC@@_7.4 ;;;----------------------------- ;; You should not normally do this in CL. However the example below ;; does roughly the same thing as the Perl and is a crude example of ;; how you can handle exceptions in CL. (handler-case (let ((file (open *path*))) ;; use FILE ) ;; Catch "all" exceptions (CONDITION is the base class of all ;; "exceptions" in CL). (condition (msg) (format *error-output* "~&Couldn't open ~A for reading : ~A~%" *path* msg))) ;;;----------------------------- ;;; @@PLEAC@@_7.6 ;;;----------------------------- (defparameter *data* " Your data goes here ") (loop for line in (split #\Newline *data*) do (progn ;; process the line )) ;;;----------------------------- ;; The Perl example here would be the same as the above. ;;;----------------------------- ;; There's no equivalent to how DATA is used here. E.g., there's no ;; standard way to get the currently executing "script" file. ;;;----------------------------- ;;; @@PLEAC@@_7.18 ;;;----------------------------- (loop for filehandle in *filehandles* ; *FILEHANDLES* is list of STREAM objects do (princ stuff-to-print filehandle)) ;;;----------------------------- ;;; @@INCOMPLETE@@ ;;; @@PLEAC@@_8.2 ;;;----------------------------- ;; Should we count the last line, if it does not end with a newline? ;; This version counts: (with-open-file (stream #p"numbers.html") (loop for line = (read-line stream nil) while line count t)) ;; and this does not: (with-open-file (stream #p"numbers.html") (loop for (line missing-newline-p) = (multiple-value-list (read-line stream nil)) while line count (not missing-newline-p))) ;;; @@INCOMPLETE@@ ;;; @@PLEAC@@_10.0 ;;;----------------------------- (defparameter *greeted* 0) ; global variable (defun hello () (incf *greeted*) (format t "hi there!~%")) ;;;----------------------------- (hello) ; call subroutine hello with no arguments/parameters ;;;----------------------------- ;;; @@PLEAC@@_10.1 ;;;----------------------------- ;; It would be strange to declare arguments using &rest when you know ;; there are exactly two, in CL, but you could, if you wanted to ;; emulate what the Perl example does. (defun hypotenuse (&rest args) (sqrt (+ (expt (elt args 0) 2) (expt (elt args 1) 2)))) (setf diag (hypotenuse 3 4)) ; DIAG is 5.0 ;;;----------------------------- (defun hypotenuse (side1 side2) (sqrt (+ (expt side1 2) (expt side2 2)))) ;;;----------------------------- (format t "~D~%" (truncate (hypotenuse 3 4))) ; prints 5 (let ((a '(3 4))) (format t "~D~%" (truncate (apply 'hypotenuse a)))) ; prints 5 ;;;----------------------------- (setf both (append men women)) (setf both `(,@men ,@women)) ; alternative way of doing the same thing ;;;----------------------------- (setf nums '(1.4 3.5 6.7)) (setf ints (apply 'int-all nums)) ; NUMS unchanged (defun int-all (&rest retlist) (loop for n in retlist collect (truncate n))) ;;;----------------------------- (setf nums '(1.4 3.5 6.7)) (trunc-em nums) ; NUMS now (1 3 6) (defun trunc-em (reals) (map-into reals 'truncate reals)) ; truncate each element of arg list ;;;----------------------------- ;;; @@PLEAC@@_10.2 ;;;----------------------------- (defun somefunc () (let (variable ; VARIABLE is invisible outside SOMEFUNC another an-array a-hash) ; declaring many variables at once ;; ... )) ;;;----------------------------- (destructuring-bind (name age) *posix-argv* ;; Use NAME, AGE here ) (setf start (fetch-time)) ;;;----------------------------- (destructuring-bind (a b) pair (let ((c (fetch-time))) ;; ... )) (defun check-x (x) (let ((y "whatever")) (run-check) (when condition (format t "got ~A~%" x)))) ;;;----------------------------- (defun save-array (&rest arguments) ;; There's probably a better way to do this. (setf *global-array* (append *global-array* (copy-seq arguments)))) ;;;----------------------------- ;;; @@PLEAC@@_10.3 ;;;----------------------------- (let (variable) (defun mysub () ;; ... accessing VARIABLE )) ;;;----------------------------- (let ((variable 1)) (defun othersub () ;; ... accessing VARIABLE )) ;;;----------------------------- (let ((counter 0)) (defun next-counter () (incf counter))) ;;;----------------------------- (let ((counter 42)) (defun next-counter () (incf counter)) (defun prev-counter () (decf counter))) ;;;----------------------------- ;;; @@PLEAC@@_10.4 ;;;----------------------------- ;; There is no standard equivalent of Perl's caller(), in CL. ;; Functions can get inlined (among other things), so it's not even ;; clear what something like caller() should actually return, anyway. ;;;----------------------------- ;;; @@PLEAC@@_10.5 ;;;----------------------------- (array-diff array1 array2) ; params are already references ;;;----------------------------- (setf a #(1 2)) (setf b #(5 8)) (setf c (add-vecpair a b)) (format t "~{~A~^ ~}~%" (map 'list 'identity c)) ;; 6 10 ;; This function would be simpler with lists instead of arrays, or the ;; use of the SERIES package. We're using arrays because the Perl ;; does. (defun add-vecpair (x y) ; assumes both vectors the same length (map-into (make-array (length x)) '+ x y)) ;;;----------------------------- ;; Normally one would use CHECK-TYPE or ASSERT here, but this example ;; is trying to match the Perl. (unless (and (typep x 'vector) (typep y 'vector)) (error "usage: add_vecpair VECTOR1 VECTOR2")) ;;;----------------------------- ;;; @@PLEAC@@_10.6 ;;;----------------------------- ;; There is no equivalent to Perl's wantarray() in CL. The most ;; similar language feature is CL's ability to return multiple values, ;; which the caller may choose to ignore. ;;;----------------------------- ;;; @@PLEAC@@_10.7 ;;;----------------------------- (thefunc :increment "20s" :start "+5m" :finish "+30m") (thefunc :start "+5m" :finish "+30m") (thefunc :finish "+30m") (thefunc :start "+5m" :increment "15s") ;;;----------------------------- ;; &allow-other-keys is used to emulate the Perl example's use of @_ ;; in the %args hash. (defun thefunc (&key (increment "10s") finish start &allow-other-keys) (when (scan "m$" increment) ;; ... )) ;;;----------------------------- ;;; @@PLEAC@@_10.8 ;;;----------------------------- ;; Use of gensym here is unusual, just trying to mimic the Perl (there ;; is probably a better way to do that, too). Also, normally you'd do ;; MULTIPLE-VALUE-BIND. (multiple-value-setq (a #.(gensym) c) (func)) ;;;----------------------------- ;; I don't know of a quicker built-in way to do exactly what the Perl ;; is doing here. There is NTH-VALUE but it only returns one value. (let ((results (multiple-value-list (func)))) (setf a (elt results 0) c (elt results 2))) ;; However you can easily define a macro that does roughly the same ;; thing. (defmacro nth-values ((&rest positions) &body body) (let ((results (gensym "results-"))) `(let ((,results (multiple-value-list ,@body))) (values ,@(mapcar #'(lambda (pos) `(elt ,results ,pos)) positions))))) (multiple-value-setq (a c) (nth-values (0 2) (func))) ;;;----------------------------- #+sbcl (multiple-value-setq (dev ino dummy dummy uid) (sb-unix:unix-stat filename)) ;;;----------------------------- #+sbcl (multiple-value-setq (dev ino #.(gensym) #.(gensym) uid) (sb-unix:unix-stat filename)) ;;;----------------------------- ;; Using the non-standard NTH-VALUES macro defined above. #+sbcl (multiple-value-setq (dev ino uid gid) (nth-values (0 1 4 5) (sb-unix:unix-stat filename))) ;;;----------------------------- ;;; @@PLEAC@@_10.9 ;;;----------------------------- (multiple-value-setq (array hash) (somefunc)) (defun somefunc () (let ((array (make-array ...)) (hash (make-hash-table ...))) ;; ... (values array hash))) ;;;----------------------------- (defun fn () ;; ... (values a b c)) ; assuming a, b and c are all hashes ;;;----------------------------- (multiple-value-setq (h0 h1 h2) (fn)) ; unlike Perl example, not "wrong" (setf list-of-hashes (multiple-value-list (fn))) ; eg: (gethash "keystring" (elt list-of-hashes 2)) (multiple-value-setq (r0 r1 r2) (fn)) ; everything's a reference, no difference from previous ;;;----------------------------- ;;; @@PLEAC@@_10.10 ;;;----------------------------- ;; In CL everything returns a value. ;;;----------------------------- (defun empty-retval ()) ; returns nil ;; If you want to distinguish between returning "empty" vs "undefined" ;; then you can return return a second value indicating which. (defun empty-retval () (values nil nil)) ;;;----------------------------- (let ((a (yourfunc))) (when a ;; ... )) ;;;----------------------------- ;; The following are all the same, just mirroring the Perl here. (let ((a (sfunc))) (unless a (error "sfunc failed"))) (let ((a (afunc))) (unless a (error "afunc failed"))) (let ((a (hfunc))) (unless a (error "hfunc failed"))) ;;;----------------------------- ;; Note: this is for illustrating the use of OR and ERROR, there is no ;; built-in ioctl or strerror in CL. (or (ioctl ...) (error "can't ioctl: ~A" strerror)) ;;;----------------------------- ;;; @@PLEAC@@_10.11 ;;;----------------------------- (setf results (myfunc 3 5)) ;;;----------------------------- ;; Unlike Perl, you can't call functions without using outer parens ;; (unless you develop macros to let you do so in specific ;; circumstances) (setf results (myfunc 3 5)) ;;;----------------------------- ;;;----------------------------- (setf results `(,@(myfunc 3) 5)) ;;;----------------------------- (defun lock-sh () 1) (defun lock-ex () 2) (defun lock-un () 4) ;;;----------------------------- (defun mypush (list &rest remainder) ;; ... ) ;;;----------------------------- (mypush (if (> x 10) a b) 3 5) ; unlike Perl, not wrong ;;;----------------------------- ;; Params are already passed as references in CL ;;;----------------------------- (defun hpush (href &rest keys-and-values) (loop for k in keys-and-values by #'cddr for v in (cdr keys-and-values) by #'cddr do (setf (gethash k href) v)) href) ; return this for caller's convenience (hpush pieces "queen" 9 "rook" 5) ;;;----------------------------- ;;; @@PLEAC@@_10.12 ;;;----------------------------- (error "some message") ; raise exception ;;;----------------------------- (multiple-value-bind (result condition) (ignore-errors (eval (func))) (when condition (warn "func raised an exception: ~A" condition))) ;;;----------------------------- (multiple-value-bind (result condition) (ignore-errors (eval (setf val (func)))) (when condition (warn "func blew up: ~A" condition))) ;;;----------------------------- (multiple-value-bind (result condition) (ignore-errors (eval (setf val (func)))) (when condition (warn "func blew up: ~A" condition))) ;;;----------------------------- (multiple-value-bind (result condition) (ignore-errors (eval (setf val (func)))) (when (and condition (not (scan "Full moon" ;; There's probably a better way to ;; do this. (format nil "~A" condition)))) (warn "func blew up: ~A" condition))) ;;;----------------------------- ;; No equivalent to wantarray(). ;;;----------------------------- ;;; @@PLEAC@@_10.13 ;;;----------------------------- (defparameter *age* 18) ; global variable (when CONDITION (let ((*age* 23)) (func) ; sees temporary value of 23 )) ; restore old value at block exit ;;;----------------------------- (setf para (get-paragraph fh)) (defun get-paragraph (fh) ;; Skip leading newlines. (loop for peek = (peek-char nil fh nil nil) while (and peek (eql peek #\Newline)) do (read-char fh nil nil)) (chomp (coerce (loop for c = (read-char fh nil :eof) until (or (eq c :eof) (and (eql c #\Newline) (eql (peek-char nil fh nil #\Newline) #\Newline))) collect c) 'string))) ;;;----------------------------- (setf contents (get-motd)) (defun get-motd () (with-open-file (motd "/etc/motd") ; will do die()-like stuff automatically (coerce (loop for c = (read-char motd nil :eof) until (eq c :eof) collect c) 'string))) ;;;----------------------------- ;;;----------------------------- ;; Note: in the spirit of the Perl, this section should be done using ;; LET and DECLARE SPECIAL but I couldn't get that to work. (defparameter *nums* '(0 1 2 3 4 5)) (defun my-second () ; don't redefine CL's standard SECOND function (format t "~{~A~^ ~}~%" *nums*)) (defun my-first () (let ((*nums* (copy-list *nums*))) (setf (elt *nums* 3) 3.14159) (my-second))) (my-second) ;; 0 1 2 3 4 5 (my-first) ;; 0 1 2 3.14159 4 5 ;;;----------------------------- ;; No obvious equivalent to %SIG ;;;----------------------------- ;;;----------------------------- ;;; @@INCOMPLETE@@ ;;; @@PLEAC@@_10.14 ;;;----------------------------- (fmakunbound 'grow) ; not sure this is necessary, but more like the Perl (setf (symbol-function 'grow) #'expand) (grow) ; calls EXPAND ;;;----------------------------- (setf one:var two:table) ; make ONE:VAR alias for TWO:TABLE (setf (symbol-function 'one:big) #'two:small) ; make ONE:BIG alias for TWO:SMALL ;;;----------------------------- (let ((fred #'barney)) ; temporarily alias FRED to BARNEY ;; ... ) ;;;----------------------------- (setf string (red "careful here")) (format t "~A" string) ;; careful here ;;;----------------------------- (defun red (string) (concatenate 'string "" string "")) ;;;----------------------------- (defmacro color-font (color) `(defun ,(intern (string-upcase color)) (string) (concatenate 'string "" string ""))) (color-font "red") (color-font "green") (color-font "blue") (color-font "purple") ;; etc ;;;----------------------------- (defmacro color-fonts (&rest colors) (append '(progn) (loop for color in colors collect `(color-font ,color)))) (color-fonts "red" "green" "blue" "yellow" "orange" "purple" "violet") ;;;----------------------------- ;;; @@PLEAC@@_10.16 ;;;----------------------------- (defun outer (arg) (let* ((x (+ arg 35)) ;; You're much less likely to do this accidentally in CL, but ;; I'm trying to match the spirit of the Perl example. (inner (block nil (return (* x 19))))) ; WRONG (+ x (inner)))) ;;;----------------------------- (defun outer (arg) (let ((x (+ arg 35))) (flet ((inner () (* x 19))) (+ x (inner))))) ;;;----------------------------- ;;; @@PLEAC@@_10.17 ;;;----------------------------- (defgeneric cmp (a b) (:documentation "Vaguely like Perl's cmp() function.")) (defmethod cmp ((a string) (b string)) (cond ((string= a b) 0) ((string-lessp a b) -1) (t 1))) (defmethod cmp ((a number) (b number)) (cond ((= a b) 0) ((< a b) -1) (t 1))) (defmethod cmp (a b) 0) (defun bysub1 (&rest filenames) (let ((sub (make-array 0 :fill-pointer 0)) (msgs (make-array 0 :fill-pointer 0))) (dolist (filename filenames) (with-open-file (file filename) ;; GET-PARAGRAPH defined in section 10.13 (loop for paragraph = (get-paragraph file) until (string-equal paragraph "") do (when (scan (create-scanner #?r"^From" :multi-line-mode t) paragraph) (vector-push-extend (or (register-groups-bind (subject) ((create-scanner #?r/^Subject:\s*(?:Re:\s*)*(.*)/ :case-insensitive-mode t :multi-line-mode t) paragraph) (string-downcase subject)) "") sub)) (vector-push-extend paragraph msgs)))) (let ((indices (make-array (length msgs) :initial-contents (loop for i below (length msgs) collect i)))) (sort indices #'(lambda (a b) (case (if (and (< a (length sub)) (< b (length sub))) (cmp (aref sub a) (aref sub b)) 0) (0 (< a b)) (-1 t)))) (map nil #'(lambda (i) (format t "~A~%" (aref msgs i))) indices)))) ;; bysub2 illustrates a Perl-specific idiom and will be skipped. (defun print-hash-table (hashtable) "Useful for debugging." (loop for key being the hash-keys of hashtable using (hash-value value) do (format t "~A: ~A~%" key value))) (defun bysub3 (&rest filenames) (let ((msgs (make-array 0 :fill-pointer 0))) (dolist (filename filenames) (with-open-file (file filename) (loop for paragraph = (get-paragraph file) until (string-equal paragraph "") do (when (scan (create-scanner #?r"^From" :multi-line-mode t) paragraph) (vector-push-extend (mkhash ; MKHASH defined in appendix :subject (register-groups-bind (subject) ((create-scanner #?r/^Subject:\s*(?:Re:\s*)*(.*)/ :case-insensitive-mode t :multi-line-mode t) paragraph) (string-downcase subject)) :number (fill-pointer msgs) :text "") msgs)) (let ((mail-record (aref msgs (1- (fill-pointer msgs))))) (setf (gethash :text mail-record) (concatenate 'string (gethash :text mail-record) paragraph)))))) (map nil #'(lambda (msg) (format t "~A" (gethash :text msg))) (sort msgs #'(lambda (a b) (let ((subject-a (gethash :subject a)) (subject-b (gethash :subject b))) (case (cmp subject-a subject-b) (0 (< (gethash :number a) (gethash :number b))) (-1 t)))))))) ;; Can be downloaded using ASDF-INSTALL (require :metatilities) (defun datesort (&rest filenames) (let ((msgs (make-array 0 :fill-pointer 0))) (dolist (filename filenames) (with-open-file (file filename) (loop for paragraph = (get-paragraph file) until (string-equal paragraph "") do (when (scan (create-scanner #?r"^From" :multi-line-mode t) paragraph) (vector-push-extend (mkhash :subject (register-groups-bind (subject) ((create-scanner #?r/^Subject:\s*(?:Re:\s*)*(.*)/ :case-insensitive-mode t :multi-line-mode t) paragraph) (string-downcase subject)) :number (fill-pointer msgs) ;; Need IGNORE-ERRORS because PARSE-DATE-AND-TIME can ;; signal conditions :date (ignore-errors (metatilities:parse-date-and-time (register-groups-bind (date) ((create-scanner #?r/^Date:\s*(.*)/ :multi-line-mode t) paragraph) (car (split #?r"\s+\(" date))))) :text "") msgs)) (let ((mail-record (aref msgs (1- (fill-pointer msgs))))) (setf (gethash :text mail-record) (concatenate 'string (gethash :text mail-record) paragraph)))))) (map nil #'(lambda (msg) (format t "~A" (gethash :text msg))) (sort msgs #'(lambda (a b) (case (cmp (gethash :subject a) (gethash :subject b)) (-1 t) (0 (case (cmp (gethash :date a) (gethash :date b)) (-1 t) (0 (< (gethash :number a) (gethash :number b))))))))))) ;;; @@PLEAC@@_11.0 ;;;----------------------------- ;; In CL you don't need extra syntax to treat variables (symbols) as ;; references, they already work that way. (format t "~A" sref) ; prints the value that the reference SREF refers to (setf sref 3) ; assigns SREF's referent ;;;----------------------------- ;; The Perl subsection here isn't any different from the above, in CL. ;;print ${$sref}; # prints the scalar $sref refers to ;;${$sref} = 3; # assigns to $sref's referent ;;;----------------------------- ;; We're calling this MY-AREF instead of AREF to avoid confusion with ;; CL's built-in AREF function. (setf my-aref array) ; no special synatx needed to get reference ;;;----------------------------- ;; Not sure what the Perl here is trying to show. Probably has no ;; realistic equivalent in CL. ;; $pi = \3.14159; ;; $$pi = 4; # runtime error ;;;----------------------------- (setf my-aref #(3 4 5)) ; new array (no "anonymous" distinction in CL) ;; MKHASH defined in appendix, not standard CL (setf href (mkhash "How" "Now" "Brown" "Cow")) ;;;----------------------------- (makunbound 'my-aref) (setf my-aref #(1 2 3)) (format t "~A" my-aref) ;; #(1 2 3) ;;;----------------------------- ;; Perl doesn't support "rectangular" multi-dimensional arrays (i.e., ;; a continuous block of memory with all cells preallocated), instead ;; it supports "jagged" arrays (i.e., arrays of references to other ;; arrays). CL supports rectangular arrays by default, but there's ;; nothing stopping you from using jagged arrays instead, since CL ;; arrays can contain anything. In this example we'll assume jagged ;; arrays, to match the Perl example's semantics. ;; You could go like this, but it is a lot of typing and is confusing ;; to read. (setf (aref (aref (aref (aref a 4) 23) 53) 21) "fred") (format t "~A" (aref (aref (aref (aref a 4) 23) 53) 21)) ;; fred ;; An AREF-like macro to handle jagged arrays will save typing/errors. (defmacro perl-aref (array &rest subscripts) "Allows AREF-like access to arrays-of-refrences (as opposed to true multidimensional arrays.)" (labels ((make-arefs (array subscripts) (if subscripts (make-arefs `(aref ,array ,(car subscripts)) (cdr subscripts)) array))) (make-arefs array subscripts))) (setf (perl-aref a 4 23 53 21) "fred") (format t "~A" (perl-aref a 4 23 53 21)) ;; fred ;; Each of the following will print out the entire substructure. (format t "~A" (perl-aref a 4 23 53)) (format t "~A" (perl-aref a 4 23)) (format t "~A" (perl-aref a 4)) ;;;----------------------------- (setf op-cit (or (cite ibid) (error "couldn't make a reference"))) ;;;----------------------------- ;; MKHASH defined in appendix (setf nat (mkhash "Name" "Leonhard Euler" "Address" (format nil "1729 Ramanujan Lane~%Mathworld, PI 31416") "Birthday" #x5bb5580)) ;;;----------------------------- ;;; @@PLEAC@@_11.1 ;;;----------------------------- (setf my-aref array) (setf anon-array #(1 3 5 7 9)) (setf anon-copy (copy-seq my-array)) (setf implicit-creation (copy-seq #(2 4 6 8 10))) ; not sure this is what the Perl means ;;;----------------------------- (vector-push-extend 11 anon-array) ; ANON-ARRAY must have fill pointer (unlike above) ;;;----------------------------- (setf two (aref implicit-creation 0)) ;;;----------------------------- (setf last-idx (1- (length my-aref))) (setf num-items (length my-aref)) ;;;----------------------------- ;; check wehther SOMEREF contains a simple array reference (check-type someref simple-vector) ; CHECK-TYPE does a die() implicitly, if necessary (format t "~{~A~^ ~}~%" (coerce array-ref 'list)) ;; SORT modifies the original array so we use STABLE-SORT to be more ;; like the Perl example. (setf order (stable-sort array-ref '<)) ;; Only works if ARRAY-REF has a fill-pointer (setf array-ref (make-array 0 :adjustable t :fill-pointer 0)) ; for example (vector-push-extend item array-ref) ;;;----------------------------- (defun array-ref () ;; This is probably the closest to what the Perl would return. (make-array 0 :adjustable t :fill-pointer 0)) (setf aref1 (array-ref)) (setf aref2 (array-ref)) ;;;----------------------------- (format t "~A" (aref array-ref n)) ; access item in position N, works on any array (format t "~A" (svref array-ref n)) ; access item in position N, possibly fastest, only ; works on type SIMPLE-VECTOR (single-dimensional arrays) (format t "~A" (elt array-ref n)) ; same, works on any sequence type, but possibly slower ;;;----------------------------- (setf pie #(0 1 2 3 4 5 6 7 8 9)) (make-array 3 :displaced-to pie :displaced-index-offset 3) ; array slice ;;;----------------------------- (setf (subseq pie 3 6) #("blackberry" "blueberry" "pumpkin")) ; note 6 instead of 5, not a typo ;;;----------------------------- (setf sliceref (make-array 3 :displaced-to pie :displaced-index-offset 3)) ; not wrong ;;;----------------------------- (map nil #'(lambda (item) ;; ITEM has data ) array-ref) (dotimes (idx (array-dimension array-ref 0)) ;; (svref array-ref idx) has data ) ;;;----------------------------- ;;; @@PLEAC@@_11.2 ;;;----------------------------- ;; Note: HASH must be creaed with :TEST 'EQUAL (push "new value" (gethash "KEYNAME" hash)) ;;;----------------------------- (loop for string being the hash-keys of hash do (format t "~A: ~A~%" string (gethash string hash))) ;;;----------------------------- (setf (gethash "a key" hash) #(3 4 5)) ; anonymous array (setf (gethash "a key" hash) '(3 4 5)) ; ...or a list would work too ;;;----------------------------- (setf values (gethash "a key" hash)) ;;;----------------------------- (push value (gethash "a key" hash)) ;;;----------------------------- (setf residents (gethash number phone2name)) ; will be NIL if not found ;;;----------------------------- ;; The Perl example would translate to the same thing as the previous ;; subsection in CL (since GETHASH returns NIL when there is no value, ;; and NIL is the empty list). However, to match the "sprit" of the ;; Perl example (and return an empty array instead of an empty list), ;; you could do the following, which takes advantage of the fact that ;; GETHASH returns a second value indicating whether or not the hash ;; key actually has a value. (setf residents (multiple-value-bind (value exists) (gethash number phone2name) (if exists value #()))) ;;;----------------------------- ;;; @@PLEAC@@_11.3 ;;;----------------------------- (setf href hash) (setf anon-hash (mkhash "key1" "value1" "key2" "value2" ...)) ; MKHASH defined in appendix ;; Couldn't find anything like this in standard CL. Someone please ;; correct me if I'm wrong. (defun copy-hash-table (hash-table) "Make shallow copy of HASH." (let ((newhash (make-hash-table :test (hash-table-test hash-table) :size (hash-table-size hash-table)))) (loop for key being the hash-keys of hash-table using (hash-value value) do (setf (gethash key newhash) (gethash key hash-table))) newhash)) (setf anonymous-hash-copy (copy-hash-table hash)) ;;;----------------------------- (setf hash href) (setf value (gethash key href)) (setf slice (loop for key in (list key1 key2 key3) collect (gethash key href))) (setf keys (loop for key being the hash-keys of href collect key)) ;;;----------------------------- (check-type someref hash-table) ; CHECK-TYPE does a die() implicitly, if necessary ;;;----------------------------- (dolist (href (list env inc)) ; ENV and INC don't exist in CL, just matching the Perl (loop for key being the hash-keys of href using (hash-value value) do (format t "~A => ~A~%" key value))) ;;;----------------------------- (setf values (loop for key in '("key1" "key2" "key3") collect (gethash key hash-ref))) ;; The following will NOT work like the Perl example, VAL is a copy of ;; the hash value because numeric values are copied. (dolist val (loop for key in '("key1" "key2" "key3") collect (gethash key hash-ref)) (incf val 7)) ; does NOT modify hash table at all ;; You'd have to do something like this instead. (loop for key in '("key1" "key2" "key3") do (incf (gethash key hash-ref 0) 7)) ;;;----------------------------- ;;; @@PLEAC@@_11.4 ;;;----------------------------- ;; If you want to be able to call the function using the alias like ;; "normal" (i.e., as the first element of a form) SETF its ;; SYMBOL-FUNCTION: (setf (symbol-function 'cref) #'func) (setf (symbol-function 'cref) #'(lambda (...))) ;; If you do the following instead, you'll have to use APPLY and/or ;; FUNCALL. (setf 'cref2 #'func) (setf 'cref2 #'(lambda (...))) ;;;----------------------------- (setf returned (cref ...)) ;; If you have a list of arguments (more like the Perl example): (setf returned (apply 'cref arguments)) ;; Or you can use FUNCALL (not that you really need to in this case) (setf returned (funcall 'cref ...)) ;; If you didn't use SYMBOL-FUNCTION, then you can do the following: (setf returned (apply cref arguments)) ; note the lack of a ' in front of CREF (setf returned (funcall cref ...)) ; ditto ;;;----------------------------- (defun thefunc () ;; ... ) (setf funcname "THEFUNC") ; upper-case to pick up correct symbol name (funcall (intern funcname)) ;;;----------------------------- ;; MKHASH defined in appendix (defparameter *commands* (mkhash "happy" #'joy "sad" #'sullen "done" #'(lambda () (error "See ya!")) "mad" #'angry)) (format t "How are you?") (let* ((string (chomp (read-line))) ; CHOMP defined in appendix (command (gethash string *commands*))) (if command (funcall command) (format t "No such command: ~A~%" string))) ;;;----------------------------- (defun counter-maker () (let ((start 0)) #'(lambda () (prog1 start ; return value of START prior to increment (incf start))))) (setf (symbol-function 'counter) (counter-maker)) (loop repeat 5 do (format t "~A~%" (counter))) ;;;----------------------------- (setf (symbol-function 'counter1) (counter-maker) (symbol-function 'counter2) (counter-maker)) (loop repeat 5 do (format t "~A~%" (counter1))) (format t "~A ~A~%" (counter1) (counter2)) ;; 0 ;; 1 ;; 2 ;; 3 ;; 4 ;; 5 0 ;;;----------------------------- (defun timestamp () (let ((start-time (get-universal-time))) #'(lambda () (- (get-universal-time) start-time)))) (setf (symbol-function 'early) (timestamp)) (sleep 20) (setf (symbol-function 'later) (timestamp)) (sleep 10) (format t "It's been ~D seconds since early.~%" (early)) (format t "It's been ~D seconds since later.~%" (later)) ;; It's been 30 seconds since early. ;; It's been 10 seconds since later. ;;;----------------------------- ;;; @@PLEAC@@_11.5 ;;;----------------------------- ;; Although you can't get a reference directly to the scalar that a ;; symbol points to (at least, not if it's a number or character), you ;; can just refer to the symbol itself, for largely the same effect. (setf scalar-ref 'scalar) ; get reference to symbol ;;;----------------------------- ;; Not sure what this was trying to demonstrate. ;;undef $anon_scalar_ref; ;;$$anon_scalar_ref = 15; ;;;----------------------------- ;; There's no way to do this in CL that I know of. ;;$anon_scalar_ref = \15; ;;;----------------------------- (format t "~A" (symbol-value scalar-ref)) ; dereference it (setf (symbol-value scalar-ref) (concatenate 'string (symbol-value scalar-ref) "string")) ;;;----------------------------- ;; This is a BAD idea in CL. Symbols are relatively expensive, there ;; is no guarantee that name collisions won't happen, possible memory ;; leak issues, etc. (let ((symbol-number -1)) (defun new-anon-symbol () (intern (format nil "_NEWANONSYM~D" (incf symbol-number))))) ;;;----------------------------- (setf sref (new-anon-symbol) (symbol-value sref) 3) (format t "Three = ~A~%" (symbol-value sref)) (setf my-array (vector (new-anon-symbol) (new-anon-symbol))) (setf (symbol-value (svref my-array 0)) 6.02e23 (symbol-value (svref my-array 1)) "avocado") (format t "ARRAY contains: ~{~A~^, ~}~%" (map 'list 'symbol-value array)) ;;;----------------------------- (setf var (with-output-to-string (output) (sb-ext:run-program "uptime" nil :search t :output output))) (setf vref 'var) (when (scan "load" (symbol-value vref))) (setf (symbol-value vref) (chomp (symbol-value vref))) ;;;----------------------------- ;; check whether SOMEREF contains a reference to a symbol, which we're ;; using instead of Perl's scalar references. (check-type someref 'symbol) ; does the die() for us ;;;----------------------------- ;;; @@PLEAC@@_11.6 ;;;----------------------------- (setf array-of-scalar-refs (vector 'a 'b)) ;;;----------------------------- ;; Note that because #() quotes its contents, A and B refer to the ;; symbols A and B, not their values, which is the closest ;; approximation to what the Perl is doing. (setf array-of-scalar-refs #(a b)) ;;;----------------------------- (setf (symbol-value (aref array-of-scalar-refs 1)) 12) ; B = 12 ;;;----------------------------- (setq a 1 b 2 c 3 d 4) ; initialize (setf my-array (vector 'a 'b 'c 'd)) ; refs to each symbol (setf my-array #(a b c d)) ; same thing! (setf my-array (loop repeat 4 collect (new-anon-symbol))) ; allocate 4 anon symbols (incf (symbol-value (aref my-array 2)) 9) ; C now 12 (symbol-macrolet ((element (symbol-value (aref my-array (1- (length my-array)))))) (setf element (* element 5)) ; D now 20 (setf element (* element 5))) ; D now 100 (let ((tmp (aref my-array (1- (length my-array))))) ; using temporary (setf (symbol-value tmp) (* 5 (symbol-value tmp)))) ; D now 500 ;;;----------------------------- ;; Note that PI is built in to CL. (map 'nil #'(lambda (sref) "Replace with spherical volumes." (symbol-macrolet ((element (symbol-value sref))) (setf element (* (expt element 3) (* 4/3 pi))))) my-array) ;;;----------------------------- ;;; @@PLEAC@@_11.7 ;;;----------------------------- (setf c1 (mkcounter 20) c2 (mkcounter 77)) (format t "next c1: ~d~%" (funcall (gethash "NEXT" c1))) ; 21 (format t "next c2: ~d~%" (funcall (gethash "NEXT" c2))) ; 78 (format t "next c1: ~d~%" (funcall (gethash "NEXT" c1))) ; 22 (format t "last c1: ~d~%" (funcall (gethash "PREV" c1))) ; 21 (format t "old c2: ~d~%" (funcall (gethash "RESET" c2))) ; 77 ;;;----------------------------- (defun mkcounter (start) (let* ((count start) (bundle ;; MKHASH defined in appendix (mkhash "NEXT" #'(lambda () (incf count)) "PREV" #'(lambda () (decf count)) "GET" #'(lambda () count) "SET" #'(lambda (new-count) (setf count new-count)) "BUMP" #'(lambda (delta) (incf count delta)) "RESET" #'(lambda () (setf count start))))) (setf (gethash "LAST" bundle) (gethash "PREV" bundle)) bundle)) ;;;----------------------------- ;;; @@PLEAC@@_11.8 ;;;----------------------------- ;; Methods in CL are generic functions that can be specialized on any ;; of their arguments. The technique tha