(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 bind it to `VAR'. When `VALUE' evaluates to some
non-NIL value, evaluate `BODY' in the same binding scope."
`(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))
(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 :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))
(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))
(export-tags (symbol-value (find-symbol "*EXPORT-TAGS*" *package*))))
(dolist (tag tags)
(import (cadr (assoc tag export-tags))
current-package))))
(defun hash-keys (hash)
(loop for k being the hash-keys of hash collect k))
(setf string "\\n") (setf string "John 'Maddog' Orwant") (setf string "
") (setf string (make-string 1 :initial-element #\Newline))
(setf string (format nil "~%"))
(setf string "John \"Maddog\" Orwant") (setf string "John 'Maddog' Orwant") (setf string "
This is a multiline string, terminated by a
double quotation mark.
")
(setf value (subseq string offset (+ offset count)))
(setf value (subseq string offset))
(setf string (concatenate 'string
(subseq string 0 offset)
newstring
(subseq string (+ offset count))))
(setf string (concatenate 'string
(subseq string 0 offset)
newtail))
(setf leading (subseq data 5)
s1 (subseq data 8 8)
s2 (subseq data 16 8)
trailing (subseq data 24))
(let ((length (length string)))
(loop for idx from 0 upto length by 5
collect (subseq string idx (min length (+ idx 5)))))
(loop for idx from 0 upto (1- (length string))
collect (char string idx))
(defparameter *string* "This is what you have")
(let ((first (subseq *string* 0 1)) (start (subseq *string* 5 7)) (rest (subseq *string* 13)) (last (subseq *string* (+ (length *string*) -1))) (end (subseq *string* (+ (length *string*) -4))) (piece (subseq *string*
(+ (length *string*) -8)
(+ (length *string*) -8 3)))) (list first start rest last end piece))
(defparameter *string* "This is what you have")
(print *string*)
(setf *string* (concatenate 'string
(subseq *string* 0 5)
"wasn't"
(subseq *string* (+ 5 2))))
(setf *string* (concatenate 'string
(subseq *string* 0 (+ (length *string*) -12))
"ondrous"))
(setf *string* (subseq *string* 1))
(setf *string* (subseq *string* 0 (+ (length *string*) -10)))
(when (scan "pattern" *string* :start (- (length *string*) 10))
(format t "Pattern matches in last 10 characters~%"))
(concatenate 'string
(regex-replace "is" *string* "at"
:start 0
:end (min (length *string*) 5))
(when (> (length *string*) 5)
(subseq *string* 5)))
(let ((a "make a hat"))
(rotatef (char a 0) (char a (1- (length a))))
(princ a))
(let* ((a "To be or not to be")
(b (subseq a 6 12))) (format t "~A~%" b)
(destructuring-bind (b c) `(,(subseq a 6 8) ,(subseq a 3 5))
(format t "~A~%~A~%" b c)))
(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))
(setf a (or b c))
(unless x (setf x y))
(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))
(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"))
(unless (plusp (length a))
(setf a (copy-seq b))) (setf a (copy-seq (if (plusp (length b))
b
c)))
(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)) (destructuring-bind (alpha beta production)
'("January" "March" "August")
(rotatef alpha beta production))
(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))
(setq ASCII (map 'list #'char-code string))
(setq string (map 'string #'code-char ASCII))
(setq ascii-value (char-code #\e)) (setq character (code-char 101)) (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)
(setf word (map 'string #'code-char ascii-character-numbers))
(setf word (map 'string #'code-char #(115 97 109 112 108 101))) (format t "~A~%" word))
(let* ((hal "HAL")
(ibm (map 'string
(lambda (char)
(code-char (1+ (char-code char)))) hal)))
(format t "~A~%" ibm))
(setq array (map 'list #'string string))
(setq array (loop for char across string
collect (char-code char)))
(do-matches-as-strings (match "(.)" string)
)
(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))))
(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))))
(setf sum (loop for char across string
sum (char-code char)))
(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)))))))
(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)))))))
(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))
(setq sdrow (reverse words))
(setq confused (reverse (apply #'concatenate 'string words))) (setq string "Yoda said, \"can you see this?\"")
(setq allwords (split " " string))
(setq revwords (format nil "~{~A~^ ~}" (reverse allwords)))
(format t "~A~%" revwords)
(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")
(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)))
(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)))
(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)
(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)
(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)))
(setf big (string-upcase little)) (setf little (string-downcase big)) (setf big #?"\U$(little)") (setf little #?"\L$(big)") (setf big (string-upcase little :end 1) (setf little (string-downcase BIG :end 1)) (setf big #?"\u$(little)") (setf little #?"\l$(big)") (setf beast "dromedary")
(setf capit (string-upcase beast :end 1)) (setf capit #?"\u\L$(beast)") (setf capall (string-upcase beast)) (setf capall #?"\U$(beast)") (setf caprest (string-downcase (string-upcase beast) :end 1)) (setf caprest #?"\l\U$(beast)") (setf text "thIS is a loNG liNE")
(format t "~A~%" (string-capitalize text))
(when (string-equal a b)
(format t "a and b are the same~%"))
(defun randcase (char)
(if (< (random 100) 20)
(char-upcase char)
(char-downcase char)))
(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.") (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")))
(setf var (regex-replace-all
(create-scanner #?r"^\s+" :multi-line-mode t)
"your text
goes here
" ""))
(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;
@@@ }
"
)))
(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)
(destructuring-bind (white leader) (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
"")))
(defvar *default-line-width* 72)
(defun partition (list max-part-len item-offset-len)
"Partitions supplied `LIST' into list of item lists where every sublist is of
maximum `MAX-PART-LEN' size. (`ITEM-OFFSET-LEN' is added to every item while
calculating item lengths.)"
(destructuring-bind (parts part part-len)
(reduce
(lambda (accum item)
(destructuring-bind (parts part part-len) accum
(let ((item-len (+ (length item) item-offset-len)))
(if (< max-part-len (+ part-len item-len))
(list (cons (nreverse part) parts) (list item) item-len)
(list parts (cons item part) (+ part-len item-len))))))
list :initial-value (list nil nil 0))
(declare (ignore part-len))
(nreverse (if part (cons part parts) parts))))
(defun wrap-paragraph (string &optional line-width)
(with-output-to-string (out)
(dolist (words
(partition
(ppcre:split "\\s+" string)
(1+ (or line-width *default-line-width*))
1))
(format out "~&~{~A~^ ~}" words))))
(defun wrap-paragraphs (string &optional line-width)
(format nil "~{~A~^~%~%~}"
(mapcar (lambda (paragraph) (wrap-paragraph paragraph line-width))
(ppcre:split "([\\r]?\\n){2,}" string))))
(wrap-paragraphs "foo0 foo1 foo2 foo3 foo5 foo6 foo7 foo8
foo9 bar0
bar1 bar2
bar3 bar4 bar5 bar6
bar7
bar8 bar9 baz0
baz1 baz2 baz3 baz4 baz5 baz6 baz7 baz8 baz9" 14)
(setf var (regex-replace-all "([CHARLIST])" var "\\\1"))
(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!")))
(setf string (regex-replace #?r/^\s+/ string ""))
(setf string (regex-replace #?r/\s+$/ string ""))
(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)))
(loop
(let ((line (read-line)))
(chomp line)
(format t #?">$(line)<~%")))
(defun parse-csv (text)
(let (fields)
(cl-ppcre:do-register-groups (quoted unquoted)
("\"([^\"\\\\]*(?:\\\\.[^\"\\\\]*)*)\",?|([^,]+),?|," text)
(push (or quoted unquoted) fields))
(nreverse fields)))
(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))))
(defun system-users ()
(with-open-file (in "/etc/passwd")
(loop for line = (read-line in nil nil)
while line collect (ppcre:split ":" line))))
(defun soundex (string)
(soundex:soundex
(with-output-to-string (out)
(loop for char across string
when (alphanumericp char)
do (format out "~C" char)))))
(defun lookup-user (user)
(let ((user-code (soundex user)))
(dolist (user-spec (system-users))
(dolist (user-name (ppcre:split "\\s+" (elt user-spec 4)))
(unless (mismatch user-code (soundex user-name))
(format t "User: ~S. (Matched Token: ~S.)~%"
(elt user-spec 0) user-name))))))
(defun prompt-read (prompt)
(format *query-io* "~A: " prompt)
(force-output *query-io*)
(read-line *query-io*))
(defun prompt-lookup-user ()
(lookup-user (prompt-read "Lookup user")))
(defvar *replacements*
'(("analysed" . "analyzed")
("built-in" . "builtin")
("chastized" . "chastised")
("commandline" . "command-line")
("de-allocate" . "deallocate")
("dropin" . "drop-in")
("hardcode" . "hard-code")
("meta-data" . "metadata")
("multicharacter" . "multi-character")
("multiway" . "multi-way")
("non-empty" . "nonempty")
("non-profit" . "nonprofit")
("non-trappable" . "nontrappable")
("pre-define" . "predefine")
("preextend" . "pre-extend")
("re-compiling" . "recompiling")
("reenter" . "re-enter")
("turnkey" . "turn-key")))
(let ((scanner
(ppcre:create-scanner
(format nil "(~{~A~^|~})" (mapcar #'car *replacements*)))))
(defun apply-replacements (string)
(ppcre:regex-replace-all
scanner string
(lambda (target-string start end match-start match-end reg-starts reg-ends)
(declare (ignore start end reg-starts reg-ends))
(cdr (find (make-array (- match-end match-start)
:element-type (array-element-type target-string)
:displaced-to target-string
:displaced-index-offset match-start)
*replacements* :test #'string-equal :key #'car))))))
(defun replace-stream (in out)
(loop for line = (read-line in nil nil)
while line do (format out "~&~A" (apply-replacements line))))
(with-input-from-string
(stream
(format nil "~{~&~A~}"
'("If I have analysed these built-in"
"results correctly in a chastized manner"
"from commandline")))
(with-output-to-string (out)
(replace-stream stream out)))
(defvar *ps-fields*
'((flags . integer)
(uid . integer)
(pid . integer)
(ppid . integer)
(pri . integer)
(nice . integer)
(size . integer)
(rss . integer)
(wchan . string)
(stat . string)
(tty . string)
(time . string)
(command . string)))
(defun format-ps-fields (fields)
(mapcar
(lambda (field-type field)
(ecase field-type
(integer (parse-integer field :junk-allowed t))
(string field)))
(mapcar #'cdr *ps-fields*)
fields))
(defun ps ()
(with-input-from-string
(in
(trivial-shell:shell-command
(format nil "ps -o ~{~(~A~)~^,~}" (mapcar #'car *ps-fields*))))
(let ((header (read-line in nil nil))
(lines (loop for line = (read-line in nil nil)
while line collect line)))
(values (mapcar #'format-ps-fields
(mapcar
(let ((limit (length *ps-fields*)))
(lambda (line) (ppcre:split "\\s+" line :limit limit)))
lines))
header lines))))
(defmacro ps-grep (expr)
(alexandria:with-unique-names (header-printed-p entries entry header lines line)
`(let (,header-printed-p)
(multiple-value-bind (,entries ,header ,lines) (ps)
(loop for ,entry in ,entries
for ,line in ,lines
when (destructuring-bind ,(mapcar #'car *ps-fields*) ,entry
(declare (ignorable ,@(mapcar #'car *ps-fields*)))
,expr)
do (unless ,header-printed-p
(format t "~A~%" ,header)
(setq ,header-printed-p t))
(format t "~A~%" ,line))))))
(ps-grep (and (< 2220 rss) (= flags 1)))
(if (every #'digit-char-p string)
(progn
)
(progn
))
(unless (every #'digit-char-p string)
(format *error-output* "string has nondigits"))
(unless (scan "^\\d+$" string) (format *error-output* "not a natural number"))
(unless (scan "^-?\\d+$" string) (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
(eql (read-char is nil :eof nil) :eof)
(numberp num)
num))))
(defun is-numeric (string)
(not (null (getnum string))))
(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) (week (* 40 wage))) (format t "One week's wage is: $~,2F~%" (/ week 100)))
(setf rounded (format nil "~FORMATF" unrounded))
(let* ((a 0.255)
(b (/ (fround a 0.01) 100)))
(format t "Unrounded: ~F~%Rounded: ~,2F~%" a b))
(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)))))
(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")) (setf binstr (dec2bin 54))
(defun seq (start end)
(loop for i from start to end collect i))
(format t "Infancy is: ~{~A~^ ~}~%" (seq 0 2))
(format t "Toddling is: ~{~A~^ ~}~%" (seq 3 4))
(format t "Childhood is: ~{~A~^ ~}~%" (seq 5 12))
(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)) (when (isroman roman) (setf arabic (arabic roman))) (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)
(setf random (+ (random (+ y (- x) 1)) x)
(setf random (+ (random 51) 25))
(format t "~A~%" random)
(+ (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))
(setf *random-state* (make-random-state t))
(setf random (random))
(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)))
(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)))))
(let* ((mean 25)
(sdev 2)
(salary (+ (* (gaussian-rand) sdev) mean)))
(format t "You have been hired at $~,2F~%" salary))
(defun deg2rad (degrees)
(* (/ degrees 180) pi))
(defun rad2deg (radians)
(* (/ radians pi) 180))
(setf radians (deg2rad degrees))
(setf degrees (rad2deg radians))
(defun degree-sine (degrees)
(let ((radians (deg2rad degrees)))
(sin radians)))
(tan theta)
(setf y (acos 3.7))
(setf y (tan (/ pi 2)))
(setf log-e (log value))
(setf log-10 (log value 10))
(setf log-base-whatever (log value base))
(setf answer (log 10000 10))
(format t "log10(10,000) = ~D~%" answer)
(format t "log2(1024) = ~A~%" (log 1024 2))
(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))
(defun veclen (vector)
(check-type vector simple-vector)
(array-dimension vector 0))
(defun matdim (matrix)
(values (array-dimension matrix 0)
(array-dimension matrix 1)))
(setf x #2a((3 2 3)
(5 9 8))
y #2a((4 7)
(9 3)
(8 1)))
(setf z (mmult x y))
(setf c (* a b))
(setf a #c(3 5))
(setf b #c(2 -2))
(setf c (* a b))
(format t "c = ~D+~Di~%" (realpart c) (imagpart c))
(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)))
(defun hex (string)
(parse-integer string
:radix 16
:start 2))
(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)))
(defun comma-separated (input &optional (n-digits 3))
(coerce
(first
(reduce
(lambda (char accum)
(format *trace-output* "~S, ~S~%" accum char)
(destructuring-bind (chars pos) accum
(list
(if (and (not (zerop pos)) (zerop (mod pos n-digits)))
(cons char (cons #\, chars))
(cons char chars))
(1+ pos))))
(coerce (format nil "~A" input) 'list)
:initial-value (list nil 0)
:from-end t))
'string))
(setq *pluralization-regexps*
'(("ss$" . "sses")
("([psc]h)$" . "\\1es")
("z$" . "zes")
("ff$" . "ffs")
("f$" . "ves")
("ey$" . "eys")
("y$" . "ies")
("ix$" . "ices")
("([sx])$" . "\\1es")
("$" . "s")))
(defun pluralize (noun)
(dolist (regexp *pluralization-regexps*)
(multiple-value-bind (result foundp)
(ppcre:regex-replace (car regexp) noun (cdr regexp))
(when foundp (return result)))))
(format t "~{~{One ~A, two ~A.~}~%~}"
(mapcar
(lambda (noun) (list noun (pluralize noun)))
'("fish" "fly" "ox" "species" "genus" "phylum" "cherub" "radius"
"jockey" "index" "matrix" "mythos" "phenomenon" "formula")))
(defun factorize (n)
(let ((factors (make-hash-table))
(m n))
(loop for i from 2
while (<= (1+ (* i 2)) m)
do (loop while (zerop (mod m i))
do (setq m (/ m i))
(setf (gethash i factors)
(1+ (gethash i factors 0)))))
(unless (or (= 1 m) (= n m))
(setf (gethash m factors) 1))
(format t "~A = ~{~{~A^~A~}~^ * ~}~%"
n (loop for factor being each hash-key of factors
collect (list factor (gethash factor factors))))))
(get-universal-time)
(multiple-value-list (get-decoded-time))
(defun day-of-the-year (&optional universal-time)
(let* ((decoded-time (multiple-value-list
(decode-universal-time
(or universal-time
(get-universal-time)))))
(day (elt decoded-time 3))
(month (elt decoded-time 4))
(year (elt decoded-time 5)))
(loop for m from 2 to month
do (incf day
(elt
(multiple-value-list
(decode-universal-time
(- (encode-universal-time 0 0 0 1 m year)
(* 60 60 24))))
3)))
day))
(format t "Today is day ~A of the current year.~%" (day-of-the-year))
(day-of-the-year (encode-universal-time 59 59 23 31 12 2009))
(format t "Today is day ~A of the current year.~%" (day-of-the-year))
(defmacro define-time-formatters (&body formatter-specs)
`(list
,@(mapcar
(lambda (formatter-spec)
`(cons
,(first formatter-spec)
(lambda (second minute hour day month year dow daylight-p zone)
(declare (ignorable second minute hour day month year dow daylight-p zone))
,@(rest formatter-spec))))
formatter-specs)))
(defvar *time-formatters*
(define-time-formatters
(#\a (elt #("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun") dow))
(#\b (elt #("Jan" "Feb" "Mar"
"Apr" "May" "Jun"
"Jul" "Aug" "Sep"
"Oct" "Nov" "Dec")
month))
(#\d (format nil "~2,'0D" day))
(#\H (format nil "~2,'0D" hour))
(#j (day-of-the-year
(encode-universal-time
second minute hour day month year dow zone)))
(#\m (format nil "~2,'0D" month))
(#\M (format nil "~2,'0D" minute))
(#\S (format nil "~2,'0D" second))
(#\w dow)
(#\Y year)
(#\z zone)))
(defun strftime (format &optional universal-time)
(with-output-to-string (out)
(loop for curr-index from 0
for prev-special-p = nil then curr-special-p
for curr-char across format
for curr-special-p = (char-equal #\% curr-char)
do (cond
((or (and prev-special-p curr-special-p)
(not (or prev-special-p curr-special-p)))
(format out "~C" curr-char))
(prev-special-p
(format
out "~A"
(if (not (< curr-index (length format)))
(error "Missing directive at position ~D." curr-index)
(or (alexandria:when-let
(formatter
(find curr-char *time-formatters*
:test #'char-equal :key #'car))
(apply
(cdr formatter)
(multiple-value-list
(decode-universal-time
(or universal-time (get-universal-time))))))
(error "Invalid directive ~S at position ~D."
curr-char curr-index)))))))))
(strftime "%d %b, %Y, %a")
(let* ((today (get-universal-time))
(yesterday (- today (* 60 60 24))))
(format t "Today : ~A (~A)~%Yesterday: ~A (~A)~%"
(strftime "%Y-%m-%d %H:%M:%S" today) today
(strftime "%Y-%m-%d %H:%M:%S" yesterday) yesterday))
(multiple-value-bind
(second minute hour date month year day-of-week dst-p tz)
(get-decoded-time)
year)
(multiple-value-bind (year month day h m s)
(today-and-now) year)
(multiple-value-bind (year month day)
(today) (format t "The current date is ~A-~2,'0d-~2,'0d" year month day))
(format-time t "%Y-%m-%d" (get-universal-time))
(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))
(let ((time (get-universal-time))) (multiple-value-bind
(second minute hour day month year day-of-week dst-p tz)
(decode-universal-time time) (list day month year hour minute second)))
(let ((firstdate
(encode-universal-time 0 12 6 23 11 2006))
(onehour (* 60 60 1)))
(+ onehour firstdate))
(add-delta-ymdhms 2006 11 24 18 12 0 0 0 1 0 0 0)
(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))))
(delta-days 1901 12 13 2038 1 19)
(week-number 2006 12 1)
(parse-time "2006-08-20")
(format-time t *format-time-date* (get-universal-time))
(format-time t *format-time-iso8601-short* (get-universal-time))
(format-time t "%Y-%m-%d" (get-universal-time))
(setf nested '("this" "that" "the" "other")
(setf nested '("this" "that" ("the" "other")))
(setf tune '("The" "Star-Spangled" "Banner"))
(setf a '("quick" "brown" "fox")
(setf a '("Why" "are" "you" "teasing" "me?"))
(setf lines (regex-replace-all (create-scanner "^\\s*(.+)" :multi-line-mode t )
" The boy stood on the burning deck,
It was as hot as glass.
" "\\1"))
(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)))
(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."))
(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))
(defparameter *lists*
'(("just one thing")
("Mutt" "Jeff")
("Peter" "Paul" "Mary")
("To our parents" "Mother Theresa" "God")
("pastrami" "ham and cheese" "peanut butter and jelly" "tuna")
("recycle tired, old phrases" "ponder big, happy thoughts")
("recycle tired, old phrases"
"ponder big, happy thoughts"
"sleep and dream peacefully")))
(defun commify_series (list)
(let ((sepchar (if (find-if #'(lambda (string)
(find #\, string))
list)
"; " ", ")))
(case (length list)
(0 "")
(1 (car list))
(2 (format nil "~{~a~^ and ~}" list))
(t (concatenate 'string
(format nil
"~{~}"
(concatenate 'string "~a~^" sepchar)
(butlast list))
(format nil " and ~a" (car (last list))))))))
(mapc #'(lambda (list)
(format t "The list is: ~a.~%" (commify_series list)))
*lists*)
(adjust-array my-array (1+ new-last-element-index-number))
(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)
(adjust-array *people* (1- (length *people*)))
(what-about-that-array)
(adjust-array *people* 10001)
(what-about-that-array)
(setf (aref *people* 10000) nil)
(dolist (item list)
)
(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) until (eq line :eof)
do
(dolist (chunk (split "\\s+" (chomp line))) (format t "~A" (reverse chunk)))) (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
(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))
(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)))))))
(perl-foreach (scalar my-list my-array my-hash)
(setf it (regex-replace "^\\s+" it ""))
(setf it (regex-replace "\\s+$" it "")))
(map 'array #'(lambda (item)
)
arrayref)
(loop for item across arrayref
do )
(map-into arrayref #'(lambda (item)
)
arrayref)
(iter (for i index-of-vector arrayref)
)
(dolist (item list)
)
(defparameter *fruits* #("Apple" "Blackberry"))
(setf fruit-ref *fruits*)
(loop for fruit across fruit-ref
do (format t "~A tastes good in a pie.~%" fruit))
(loop for i below (length fruit-ref)
do (format t "~A tastes good in a pie.~%" (svref fruit-ref i)))
(setf (gethash :felines *namelist*) *rogue-cats*)
(dolist (cat (gethash :felines *namelist*))
(format t "~A purrs hypnotically..~%" cat))
(format t "--More--~%You are controlled.~%")
(loop for i below (length (gethash :felines *namelist*))
do (format t "~A purrs hypnotically..~%" (elt (gethash :felines *namelist*) i)))
(defparameter *seen* (make-hash-table :test 'equal))
(defparameter *uniq* '())
(dolist (item my-list)
(unless (gethash item *seen*)
(setf (gethash item *seen*) 1)
(push item *uniq*)))
(clrhash *seen*)
(dolist (item my-list)
(when (= (incf (gethash item *seen* 0)) 1)
(push item *uniq*)))
(clrhash *seen*)
(dolist (item my-list)
(when (= (incf (gethash item *seen* 0)) 1)
(some-func item)))
(clrhash *seen*)
(dolist (item my-list)
(incf (gethash item *seen* 0)))
(setf *uniq* (loop for k being the hash-keys of *seen* collect k))
(clrhash *seen*)
(setf *uniq* (perl-grep my-list (= 1 (incf (gethash it *seen* 0)))))
(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)
(setf who (regex-replace "\\s.*$" who ""))
(incf (gethash who *ucnt* 0)))) (defparameter *users* (sort (loop for k being the hash-keys of *ucnt* collect k) #'string=))
(format t "users logged in: ~{~A~^ ~}~%" *users*)
(defparameter *seen* (make-hash-table :test 'equal)) (defparameter *a-only* '())
(loop for item in b do (setf (gethash item *seen*) 1))
(dolist (item a)
(unless (gethash item *seen*)
(push item *a-only*)))
(dolist (item a)
(unless (gethash item *seen*)
(push item *a-only*))
(setf (gethash item *seen*) 1)) (setf (gethash "key1" my-hash) 1)
(setf (gethash "key2" my-hash) 2)
(loop
for key in '("key1" "key2")
and value in '(1 2)
do (setf (gethash key my-hash) value))
(loop
for key in b
do (setf (gethash key my-hash) nil))
(loop
for key in b
do (setf (gethash key my-hash) (loop repeat (length b) collect 1)))
(defparameter *a* '(1 3 5 6 7 8))
(defparameter *b* '(2 3 5 7 9))
(defvar *union*)
(defvar *isect*)
(defvar *diff*)
(defparameter *union-hash* (make-hash-table))
(defparameter *isect-hash* (make-hash-table))
(defparameter *count* (make-hash-table))
(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))
(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*)) (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*))))
(setf array1 (append array1 array2))
(setf array1 `(,@array1 ,@array2))
(let ((members '("Time" "Flies"))
(initiates '("An" "Arrow")))
(setf members (append members initiates))
(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))
(setf reversed (reverse *array*))
(do ((i (1- (array-dimension *array* 0)) (1- i)))
((minusp i))
)
(setf ascending (stable-sort users 'string-lessp))
(setf descending (reverse ascending))
(setf descending (reverse (stable-sort users 'string-lessp)))
(setf front (subseq my-array 0 n))
(setf my-array (subseq my-array n))
(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)))))))
(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*)
)
(defparameter *beverages* #(Dew Jolt Cola Sprite Fresca))
(let ((pair (pop2 *beverages*)))
)
(setf (aref line 5) my-list)
(setf got (pop2 (aref line 5)))
(let ((match (find item *sequence*)))
(cond
(match
)
(t
)))
(let ((match-idx (position item *sequence*)))
(cond
(match-idx
)
(t
)))
(defstruct employee name category) (format t "Highest paid engineer is: ~A~%"
(employee-name (find 'engineer *employees* :key 'employee-category :from-end t)))
(let ((i
(loop for idx below (length *array*)
do (when criterion (return idx)))))
(if (< i (length *array*))
(progn
)
(progn
)))
(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)))
(setf engineers (remove "Engineer" employees :key #'employee-position :test-not 'string=))
(setf secondary-assistance (remove-if-not #'(lambda (applicant)
(and (>= (applicant-income applicant) 26000)
(< (applicant-income applicant) 30000)))
applicants))
(setf sorted (stable-sort unsorted '<))
(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)
(defvar *sample-list*
'((1 -1 0.1 "one")
(2 -2 0.2 "two")
(3 -3 0.3 "three")))
(sort (copy-list *sample-list*) #'< :key #'first)
(sort (copy-list *sample-list*) #'string< :key #'fourth)
(sort (copy-list *sample-list*) #'<
:key (lambda (list) (* (second list) (third list))))
(setf circular `(,@(last circular) ,@(nbutlast circular))) (setf circular `(,@(cdr circular) ,(car circular))) (defmacro grab-and-rotate (list)
`(prog1 (car ,list)
(setf ,list `(,@(cdr ,list) ,(car ,list)))))
(let ((processes '(1 2 3 4 5)))
(loop
(let ((process (grab-and-rotate processes)))
(format t "Handling process ~A~%" process)
(sleep 1))))
(defun fisher-yates-shuffle (vector)
"Randomly shuffle elements of VECTOR."
(loop for i from (1- (length vector)) downto 1
for j = (random i)
unless (= i j)
do (rotatef (aref vector i) (aref vector j)))
vector)
(fisher-yates-shuffle vector) (defun shuffle (vector)
"Return a fresh permuted copy of VECTOR."
(let* ((n-permutations (factorial (length vector)))
(permutation (nth-permutation (random n-permutations)
(length vector))))
(map 'vector (lambda (i) (aref vector i)) permutation)))
(defun naive-shuffle (vector)
(loop with n = (length vector)
for i from 0 below n
for j = (random n)
do (rotatef (aref vector i) (aref vector j)))
vector)
(defun print-matrix (matrix column-len)
(format t (format nil "~~{~~{~~@[~~~DA~~^ ~~]~~}~~%~~}" column-len) matrix))
(defun pop-matrix-column (matrix)
(when matrix
(let ((elt (caar matrix)))
(setf (car matrix) (cdar matrix))
(cons elt (pop-matrix-column (cdr matrix))))))
(defun transpose-matrix (matrix)
(when (car matrix)
(cons (pop-matrix-column matrix)
(transpose-matrix matrix))))
(defun parse-matrix-row (string &key count)
(when string (ppcre:split "\\s+" string :limit count)))
(defun parse-matrix (stream)
(let ((first-row (parse-matrix-row (read-line stream nil nil))))
(when first-row
(let* ((n-columns (length first-row))
(matrix
(cons first-row
(loop for row = (parse-matrix-row
(read-line stream nil nil)
:count n-columns)
while row collect row)))
(column-len
(reduce #'max matrix
:key (lambda (vals)
(reduce #'max vals :key #'length)))))
(print-matrix (transpose-matrix matrix) column-len)))))
(with-input-from-string
(in "awk cp ed login mount rmdir sum
basename csh egrep ls mt sed sync
cat date fgrep mail mv sh tar
chgrp dd grep mkdir ps sort touch
chmod df kill mknod pwd stty vi
chown echo ln more rm su")
(parse-matrix in))
(defun factorial (n)
(if (< n 2) 1 (* n (factorial (1- n)))))
(defun tco-factorial (n)
(labels ((iter (m acc)
(if (< n m) acc (iter (1+ m) (* m acc)))))
(iter 1 1)))
(tco-factorial (expt 2 8))
(defun permutations (items &key test &aux (test (or test #'eql)))
(if (null items) '(())
(mapcan
(lambda (item)
(mapcar (lambda (permutation) (cons item permutation))
(permutations (remove item items :test test) :test test)))
items)))
(permutations '("man" "bites" "dog") :test #'string-equal)
(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")))
(setf (gethash key hash) value)
(setf (gethash "Raspberry" *food-color*) "pink")
(format t "Known foods:~%~{~A~%~}"
(loop for f being the hash-keys of *food-color*
collect f))
(if (nth-value 1 (gethash key hash))
(progn
)
(progn
))
(dolist (name '("Banana" "Martini"))
(format t "~A is a ~A.~%"
name
(if (nth-value 1 (gethash name *food-color*))
"food" "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 ")
(unless (zerop defined)
(format t "True ")))))
(format t "~%"))
(remhash key hash)
(defun print-foods ()
(let ((foods (hash-keys *food-color*))) (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)
(mapc #'(lambda (key) (remhash key *food-color*)) '("Banana" "Apple" "Cabbage"))
(loop for key being the hash-keys of hash using (hash-value value)
)
(maphash #'(lambda (key value)
)
hash)
(loop for food being the hash-keys of *food-color* using (hash-value color)
do (format t "~A is ~A.~%" food color))
(maphash #'(lambda (food color)
(format t "~A is ~A.~%" food color))
*food-color*)
(loop for food in (sort (hash-keys *food-color*) 'string-lessp)
do (format t "~A is ~A~%" food (gethash food *food-color*)))
(use-package :cl-ppcre)
(use-package :iterate)
(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)))))
(defmethod countfrom ((filename string))
(countfrom (open filename)))
(defvar *table* (make-hash-table :test #'equal))
(dotimes (i 10)
(setf (gethash (format nil "~R" i) *table*) i))
(maphash (lambda (key val) (format t "~A~%" (cons key val))) *table*)
(defun make-ordered-hash-table (&rest make-hash-table-args)
(cons (apply #'make-hash-table make-hash-table-args) 0))
(defun setkey (table key val)
(setf (gethash key (car table)) (cons (incf (cdr table)) val)))
(defun remkey (table key)
(remhash key (car table)))
(defun getkey (table key &optional default)
(let* ((missing-key (gensym))
(val (gethash key (car table) missing-key)))
(if (eql missing-key val) default (cdr val))))
(defun keys (table)
(let (key-id-pairs)
(maphash
(lambda (key val) (push (cons key (car val)) key-id-pairs))
(car table))
(mapcar #'car (sort key-id-pairs #'< :key #'cdr))))
(defvar *table* (make-ordered-hash-table))
(dotimes (i 10)
(setkey *table* (/ (1+ i)) i))
(keys *table*)
(setkey *table* (/ 2) 20)
(setkey *table* (/ 4) 40)
(remkey *table* (/ 6))
(keys *table*)
(defvar *employee-table* (make-hash-table :test #'equal))
(defvar *employee-list*
'(("R&D" "Bob" "1000")
("R&D" "Trudy" "1001")
("R&D" "Alice" "1002")
("Sales" "Bob" "2001")
("Sales" "Jane" "2003")))
(dolist (employee *employee-list*)
(destructuring-bind (dept name phone) employee
(setf (gethash (list dept name) *employee-table*)
phone)))
(maphash (lambda (key val) (format t "~S => ~S~%" key val))
*employee-table*)
(defun reverse-hash-table (old-table &key test)
(let ((new-table
(make-hash-table
:test (or test (hash-table-test old-table))
:size (hash-table-size old-table))))
(maphash (lambda (key val)
(setf (gethash val new-table) key))
old-table)
new-table))
(defvar *table* (make-hash-table))
(dotimes (i 10) (setf (gethash (/ (1+ i)) *table*) i))
(maphash (lambda (key val) (format t "~S => ~S~%" key val))
*table*)
(maphash (lambda (key val) (format t "~S => ~S~%" key val))
(reverse-hash-table *table*))
(defun ordered-keys (table)
(sort
(loop for key being each hash-key of table
collect key)
#'<))
(defvar *table* (make-hash-table))
(dotimes (i 10)
(setf (gethash (/ (1+ i)) *table*) i))
(ordered-keys *table*)
(defun merge-hash-tables (&rest tables)
(let ((union
(make-hash-table
:test (first
(sort (mapcar #'hash-table-test tables) #'>
:key (lambda (test)
(ecase test
(eq 0)
(eql 1)
(equal 2)
(equalp 3)))))
:size (reduce #'max (mapcar #'hash-table-size tables)))))
(dolist (table tables)
(maphash (lambda (key val) (setf (gethash key union) val)) table))
union))
(defvar *table-x* (make-hash-table))
(defvar *table-y* (make-hash-table :test #'equal))
(dotimes (i 5)
(setf (gethash i *table-x*) (* 10 i)
(gethash (format nil "~R" i) *table-y*) i))
(defvar *table-u* (merge-hash-tables *table-x* *table-y*))
(maphash (lambda (key val) (format t "~10S => ~S~%" key val)) *table-u*)
(defun hash-table-keys (table)
(loop for key being each hash-key of table
collect key))
(defun key-intersection (u v)
(intersection
(hash-table-keys u) (hash-table-keys v)
:test (hash-table-test u)))
(defun key-difference (u v)
(set-difference
(hash-table-keys u) (hash-table-keys v)
:test (hash-table-test u)))
(defun hairy-key-frequency (tables &key (test 'eql))
(let ((frequency (make-hash-table :test test)))
(dolist (table tables)
(maphash
(lambda (key val)
(declare (ignore val))
(incf (gethash key frequency 0)))
table))
frequency))
(defmacro with-table-test-consistency ((tables test) &body body)
(alexandria:with-unique-names (table)
`(let ((,test (hash-table-test (first ,tables))))
(unless (every (lambda (,table) (eql (hash-table-test ,table) ,test))
(rest ,tables))
(error "Inconsistent test functions! (Expecting ~S.)" ,test))
,@body)))
(defun hairy-key-frequency-filter (tables pred)
(when tables
(with-table-test-consistency (tables test)
(let (accum)
(maphash
(lambda (key val) (when (funcall pred val) (push key accum)))
(hairy-key-frequency tables :test test))
accum))))
(defun hairy-key-intersection (&rest tables)
(hairy-key-frequency-filter tables (lambda (val) (< 1 val))))
(defun hairy-key-difference (&rest tables)
(hairy-key-frequency-filter tables (lambda (val) (< val 2))))
(let ((u (make-hash-table))
(v (make-hash-table)))
(dolist (i '(1 2 3 4 5)) (setf (gethash i u) t))
(dolist (i '(3 4 5 6 7)) (setf (gethash i v) t))
(list :simple (list :intersection (key-intersection u v)
:difference (key-difference u v))
:hairy (list :intersection (hairy-key-intersection u v)
:difference (hairy-key-difference u v))))
(defun consume-stream (stream &key (buffer-size 8192))
(let ((buffer
(make-sequence
`(vector ,(stream-element-type stream))
buffer-size)))
(loop for pos = (read-sequence buffer stream)
until (zerop pos) sum pos)))
(let* ((streams (mapcar #'open (list "/etc/passwd" "/etc/motd" "/etc/fstab"))))
(unwind-protect
(let ((table (make-hash-table)))
(dolist (stream streams)
(setf (gethash stream table) (pathname stream)))
(let (accum)
(maphash
(lambda (key val) (push (cons val (consume-stream key)) accum))
table)
accum))
(mapcar #'close streams)))
(defvar *relations*
'(("Cain" . "Adam")
("Abel" . "Adam")
("Seth" . "Adam")
("Enoch" . "Cain")
("Irad" . "Enoch")
("Mehujael" . "Irad")
("Methusael" . "Mehujael")
("Lamech" . "Methusael")
("Jabal" . "Lamech")
("Jubal" . "Lamech")
("Tubalcain" . "Lamech")))
(defun construct-relation-tree (rels)
(labels ((construct (parent)
(cons parent
(mapcar #'construct
(mapcar #'car
(remove parent rels
:key #'cdr
:test (complement #'string-equal)))))))
(mapcar #'construct
(remove-duplicates
(mapcar #'cdr
(remove-if
(lambda (pair)
(find (cdr pair) rels :test #'string-equal :key #'car))
rels))
:test #'string-equal))))
(construct-relation-tree *relations*)
(defun parse-file-dependencies (pathname)
(let (deps)
(with-open-file (in pathname)
(loop for line = (read-line in nil nil)
while line
do (ppcre:do-scans
(m-s m-e r-ss r-es
"\\s*#\\s*include\\s*[<\"]([^>\"]+)[>\"]" line)
(push (subseq line (elt r-ss 0) (elt r-es 0)) deps))))
deps))
(defun construct-file-relations (pathnames)
(mapcan
(lambda (child)
(mapcar (lambda (parent)
(cons
(format nil "~A.~A" (pathname-name child) (pathname-type child))
parent))
(parse-file-dependencies child)))
pathnames))
(construct-file-relations
'("/tmp/c/hello.c" "/tmp/c/hello.h" "/tmp/c/main.c"))
(construct-relation-tree
(construct-file-relations
'("/tmp/c/hello.c" "/tmp/c/hello.h" "/tmp/c/main.c")))
(defstruct hash-branch (weight 0) (tree nil))
(defun hash-tree-add (branch path weight)
(let ((branch (or branch (make-hash-branch))))
(prog1 branch
(incf (hash-branch-weight branch) weight)
(when path
(setf (hash-branch-tree branch)
(or (hash-branch-tree branch)
(make-hash-table :test #'equal)))
(setf (gethash (first path) (hash-branch-tree branch))
(hash-tree-add
(gethash (first path) (hash-branch-tree branch))
(rest path) weight))))))
(defun hash-tree->list-tree (branch)
(when branch
(cons (hash-branch-weight branch)
(let ((tree (hash-branch-tree branch))
(accum))
(when tree
(maphash
(lambda (key val)
(push (cons key (hash-tree->list-tree val)) accum))
tree)
accum)))))
(defun print-list-tree (branches &optional (depth 0))
(dolist (branch (sort (copy-list branches) #'> :key #'second))
(format t "~8D |" (second branch))
(loop repeat depth do (format t "--"))
(format t "-> ~A~%" (first branch))
(print-list-tree (cddr branch) (1+ depth))))
(defun du-output->size-path-pair (string)
(with-input-from-string (in string)
(loop for line = (read-line in nil nil)
while line
collect (ppcre:register-groups-bind (size path)
("^\(\[^\\s\]+\)\\s+\(\[^\\s\]+\)$" line)
(cons (parse-integer size)
(delete-if #'zerop (ppcre:split "/" path)
:key #'length))))))
(defun du-output->list-tree (string)
(let ((branch (make-hash-branch)))
(dolist (size-path-pair (du-output->size-path-pair string))
(hash-tree-add branch (cdr size-path-pair) (car size-path-pair)))
(rest (hash-tree->list-tree branch))))
(du-output->list-tree
(trivial-shell:shell-command "du -ab /tmp/c"))
(print-list-tree
(du-output->list-tree
(trivial-shell:shell-command "du -ab /tmp/c")))
(use-package :cl-ppcre) (scan pattern string)
(regex-replace pattern string replacement)
(scan "sheep" meadow) (not (scan "sheep" meadow)) (regex-replace "old" meadow "new") (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"))
(with-input-from-string (s "ababacaca
")
(let ((match (scan-to-strings "(a|ba|b)+(a|ac)+" (read-line s))))
(format t "~A~%" match)))
(register-groups-bind (num)
("(\\d+)" some-string)
(format t "Found number ~A~%" num))
(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*)
(setf dst (regex-replace "that" src "this"))
(defparameter *progname* (regex-replace "^.*/" (car *posix-argv*) ""))
(defparameter *capword* (string-capitalize *word*))
(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*)
(setf a (regex-replace-all "x" b "y"))
(when (scan "^[A-Za-z]+$" var)
)
(when (scan "^[^\\W\\d_]+$" var)
)
(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))))
(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 #'(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))))))
(with-open-file (input "/usr/local/widgets/data")
(iter (for line in-stream input using 'read-line)
(when (scan "blue" line)
(format t "~A~%" line)))
)
(let ((var *standard-input*))
(mysub var logfile))
(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)))
(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)))
(close *standard-output*))
(defparameter *logfile* (open "/tmp/log" :direction :output))
(close *fh*) (let ((*standard-output* *logfile*)) (format t "Countdown initiated ...~%"))
(format t "You have 30 seconds to reach minimum safety distance.~%")
(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)))
#+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)))
(setf *filename* (regex-replace "^(\\s)" *filename* "./$1"))
(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))
(handler-case
(let ((file (open *path*)))
)
(condition (msg)
(format *error-output* "~&Couldn't open ~A for reading : ~A~%" *path* msg)))
(defparameter *data* "
Your data goes here
")
(loop for line in (split #\Newline *data*)
do
(progn
))
(loop
for filehandle in *filehandles* do (princ stuff-to-print filehandle))
(with-open-file (stream #p"numbers.html")
(loop for line = (read-line stream nil)
while line
count t))
(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)))
(defparameter *greeted* 0) (defun hello ()
(incf *greeted*)
(format t "hi there!~%"))
(hello)
(defun hypotenuse (&rest args)
(sqrt (+ (expt (elt args 0) 2)
(expt (elt args 1) 2))))
(setf diag (hypotenuse 3 4)) (defun hypotenuse (side1 side2)
(sqrt (+ (expt side1 2)
(expt side2 2))))
(format t "~D~%" (truncate (hypotenuse 3 4)))
(let ((a '(3 4)))
(format t "~D~%" (truncate (apply 'hypotenuse a)))) (setf both (append men women))
(setf both `(,@men ,@women)) (setf nums '(1.4 3.5 6.7))
(setf ints (apply 'int-all nums)) (defun int-all (&rest retlist)
(loop for n in retlist collect (truncate n)))
(setf nums '(1.4 3.5 6.7))
(trunc-em nums) (defun trunc-em (reals)
(map-into reals 'truncate reals))
(defun somefunc ()
(let (variable another an-array a-hash) ))
(destructuring-bind (name age) *posix-argv*
)
(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)
(setf *global-array* (append *global-array* (copy-seq arguments))))
(let (variable)
(defun mysub ()
))
(let ((variable 1))
(defun othersub ()
))
(let ((counter 0))
(defun next-counter ()
(incf counter)))
(let ((counter 42))
(defun next-counter ()
(incf counter))
(defun prev-counter ()
(decf counter)))
(array-diff array1 array2) (setf a #(1 2))
(setf b #(5 8))
(setf c (add-vecpair a b))
(format t "~{~A~^ ~}~%" (map 'list 'identity c))
(defun add-vecpair (x y) (map-into (make-array (length x))
'+ x y))
(unless (and (typep x 'vector)
(typep y 'vector))
(error "usage: add_vecpair VECTOR1 VECTOR2"))
(thefunc :increment "20s" :start "+5m" :finish "+30m")
(thefunc :start "+5m" :finish "+30m")
(thefunc :finish "+30m")
(thefunc :start "+5m" :increment "15s")
(defun thefunc (&key (increment "10s") finish start &allow-other-keys)
(when (scan "m$" increment)
))
(multiple-value-setq (a #.(gensym) c) (func))
(let ((results (multiple-value-list (func))))
(setf a (elt results 0)
c (elt results 2)))
(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))
#+sbcl
(multiple-value-setq (dev ino uid gid) (nth-values (0 1 4 5) (sb-unix:unix-stat filename)))
(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)) (multiple-value-setq (h0 h1 h2) (fn)) (setf list-of-hashes (multiple-value-list (fn))) (multiple-value-setq (r0 r1 r2) (fn))
(defun empty-retval ()) (defun empty-retval ()
(values nil nil))
(let ((a (yourfunc)))
(when a
))
(let ((a (sfunc)))
(unless a
(error "sfunc failed")))
(let ((a (afunc)))
(unless a
(error "afunc failed")))
(let ((a (hfunc)))
(unless a
(error "hfunc failed")))
(or (ioctl ...) (error "can't ioctl: ~A" strerror))
(setf results (myfunc 3 5))
(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) (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)
(hpush pieces "queen" 9 "rook" 5)
(error "some message") (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"
(format nil "~A" condition))))
(warn "func blew up: ~A" condition)))
(defparameter *age* 18) (when CONDITION
(let ((*age* 23))
(func) )) (setf para (get-paragraph fh))
(defun get-paragraph (fh)
(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") (coerce (loop
for c = (read-char motd nil :eof)
until (eq c :eof)
collect c)
'string)))
(defparameter *nums* '(0 1 2 3 4 5))
(defun my-second () (format t "~{~A~^ ~}~%" *nums*))
(defun my-first ()
(let ((*nums* (copy-list *nums*)))
(setf (elt *nums* 3) 3.14159)
(my-second)))
(my-second)
(my-first)
(fmakunbound 'grow) (setf (symbol-function 'grow) #'expand)
(grow) (setf one:var two:table) (setf (symbol-function 'one:big) #'two:small) (let ((fred #'barney)) )
(setf string (red "careful here"))
(format t "~A" string)
(defun red (string)
(concatenate 'string "<FONT COLOR='red'>" string "</FONT>"))
(defmacro color-font (color)
`(defun ,(intern (string-upcase color)) (string)
(concatenate 'string "<FONT COLOR='" ,color "'>" string "</FONT>")))
(color-font "red")
(color-font "green")
(color-font "blue")
(color-font "purple")
(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")
(defun outer (arg)
(let* ((x (+ arg 35))
(inner (block nil
(return (* x 19))))) (+ x (inner))))
(defun outer (arg)
(let ((x (+ arg 35)))
(flet ((inner () (* x 19)))
(+ x (inner)))))
(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)
(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))))
(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 :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))))))))
(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)
: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)))))))))))
(format t "~A" sref) (setf sref 3) (setf my-aref array) (setf my-aref #(3 4 5)) (setf href (mkhash "How" "Now" "Brown" "Cow"))
(makunbound 'my-aref)
(setf my-aref #(1 2 3))
(format t "~A" my-aref)
(setf (aref (aref (aref (aref a 4) 23) 53) 21) "fred")
(format t "~A" (aref (aref (aref (aref a 4) 23) 53) 21))
(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))
(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")))
(setf nat (mkhash "Name" "Leonhard Euler"
"Address" (format nil "1729 Ramanujan Lane~%Mathworld, PI 31416")
"Birthday" #x5bb5580))
(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))) (vector-push-extend 11 anon-array) (setf two (aref implicit-creation 0))
(setf last-idx (1- (length my-aref)))
(setf num-items (length my-aref))
(check-type someref simple-vector)
(format t "~{~A~^ ~}~%" (coerce array-ref 'list))
(setf order (stable-sort array-ref '<))
(setf array-ref (make-array 0 :adjustable t :fill-pointer 0)) (vector-push-extend item array-ref)
(defun array-ref ()
(make-array 0 :adjustable t :fill-pointer 0))
(setf aref1 (array-ref))
(setf aref2 (array-ref))
(format t "~A" (aref array-ref n)) (format t "~A" (svref array-ref n)) (format t "~A" (elt array-ref n)) (setf pie #(0 1 2 3 4 5 6 7 8 9))
(make-array 3 :displaced-to pie :displaced-index-offset 3) (setf (subseq pie 3 6) #("blackberry" "blueberry" "pumpkin")) (setf sliceref (make-array 3 :displaced-to pie :displaced-index-offset 3)) (map nil
#'(lambda (item)
)
array-ref)
(dotimes (idx (array-dimension array-ref 0))
)
(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)) (setf (gethash "a key" hash) '(3 4 5)) (setf values (gethash "a key" hash))
(push value (gethash "a key" hash))
(setf residents (gethash number phone2name)) (setf residents (multiple-value-bind (value exists) (gethash number phone2name)
(if exists
value
#())))
(setf href hash)
(setf anon-hash (mkhash "key1" "value1" "key2" "value2" ...))
(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) (dolist (href (list env inc)) (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)))
(dolist val (loop for key in '("key1" "key2" "key3")
collect (gethash key hash-ref))
(incf val 7))
(loop for key in '("key1" "key2" "key3")
do (incf (gethash key hash-ref 0) 7))
(setf (symbol-function 'cref) #'func)
(setf (symbol-function 'cref) #'(lambda (...)))
(setf 'cref2 #'func)
(setf 'cref2 #'(lambda (...)))
(setf returned (cref ...))
(setf returned (apply 'cref arguments))
(setf returned (funcall 'cref ...))
(setf returned (apply cref arguments)) (setf returned (funcall cref ...)) (defun thefunc ()
)
(setf funcname "THEFUNC") (funcall (intern funcname))
(defparameter *commands*
(mkhash "happy" #'joy
"sad" #'sullen
"done" #'(lambda () (error "See ya!"))
"mad" #'angry))
(format t "How are you?")
(let* ((string (chomp (read-line))) (command (gethash string *commands*)))
(if command
(funcall command)
(format t "No such command: ~A~%" string)))
(defun counter-maker ()
(let ((start 0))
#'(lambda ()
(prog1 start (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))
(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))
(setf scalar-ref 'scalar) (format t "~A" (symbol-value scalar-ref)) (setf (symbol-value scalar-ref) (concatenate 'string (symbol-value scalar-ref) "string"))
(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-type someref 'symbol)
(setf array-of-scalar-refs (vector 'a 'b))
(setf array-of-scalar-refs #(a b))
(setf (symbol-value (aref array-of-scalar-refs 1)) 12) (setq a 1 b 2 c 3 d 4) (setf my-array (vector 'a 'b 'c 'd)) (setf my-array #(a b c d)) (setf my-array (loop repeat 4 collect (new-anon-symbol)))
(incf (symbol-value (aref my-array 2)) 9)
(symbol-macrolet ((element (symbol-value (aref my-array (1- (length my-array))))))
(setf element (* element 5)) (setf element (* element 5)))
(let ((tmp (aref my-array (1- (length my-array))))) (setf (symbol-value tmp) (* 5 (symbol-value tmp)))) (map 'nil
#'(lambda (sref)
"Replace with spherical volumes."
(symbol-macrolet ((element (symbol-value sref)))
(setf element (* (expt element 3)
(* 4/3 pi)))))
my-array)
(setf c1 (mkcounter 20)
c2 (mkcounter 77))
(format t "next c1: ~d~%" (funcall (gethash "NEXT" c1))) (format t "next c2: ~d~%" (funcall (gethash "NEXT" c2))) (format t "next c1: ~d~%" (funcall (gethash "NEXT" c1))) (format t "last c1: ~d~%" (funcall (gethash "PREV" c1))) (format t "old c2: ~d~%" (funcall (gethash "RESET" c2))) (defun mkcounter (start)
(let* ((count start)
(bundle
(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))
(setf (symbol-function 'mref) #'meth)
(mref "args" "go" "here")
(setf (symbol-funtion 'sref) #'meth)
(setf record (mkhash
:name "Jason"
:empno 132
:title "deputy peon"
:age 23
:salary 37000
:pals '("Norbert" "Rhys" "Phineas")))
(format t "I am ~A, and my pals are ~{~A~^, ~}~%"
(gethash :name record)
(gethash :pals record))
(defparameter *byname* (make-hash-table :test 'equal))
(setf (gethash (gethash :name record) *byname*) record)
(let ((rp (gethash "Aron" *byname*)))
(when rp
(format t "Aron is employee number ~D~%" (gethash :empno rp))))
(push "Theodore" (gethash :pals (gethash "Jason" *byname*)))
(format t "Jason now has ~D pals~%" (length (gethash :pals (gethash "Jason" *byname*))))
(maphash #'(lambda (name record)
(format t "~A is employee number ~D~%" name (gethash :empno record)))
*byname*)
(defparameter *employees* (make-array 0 :adjustable t))
(let ((empno (gethash :empno record)))
(unless (array-in-bounds-p *employees* empno)
(adjust-array *employees* (1+ empno) :initial-element nil))
(setf (aref *employees* empno) record))
(when-let (rp (aref *employees* 132))
(format t "employee 132 is ~A~%" (gethash :name rp)))
(symbol-macrolet ((salary (gethash :salary (gethash "Jason" *byname*))))
(setf salary (* salary 1.035)))
(setf peons (remove-if-not
#'(lambda (employee)
(and employee
(scan (create-scanner "peon" :case-insensitive-mode t)
(gethash :title employee))))
*employees*))
(setf peons (perl-grep *employees*
(and it
(scan (create-scanner "peon" :case-insensitive-mode t)
(gethash :title it)))))
(setf tsevens (remove-if-not
#'(lambda (employee)
(and employee
(= (gethash :age employee)
27)))
*employees*))
(defun hash-slice (hash &rest keys)
"Meant to emulate Perl's built-in hash slicing feature."
(loop for key in keys collect (gethash key hash)))
(dolist (rp (sort (loop for v being the hash-values of *byname* collect v)
'string-lessp
:key #'(lambda (hash) (gethash :age hash))))
(format t "~A is employee number ~D.~%" (gethash :name rp) (gethash :age rp))
(apply 'format t "~A is employee number ~D.~%" (hash-slice rp :name :age)))
(push record (aref *byage* (gethash :age record)))
(dotimes (age (length *byage*))
(when-let (records (aref *byage* age))
(format t "Age ~D: " age)
(dolist (rp records)
(format t "~A " (gethash :name rp)))
(format t "~%")))
(dotimes (age (length *byage*))
(when-let (records (aref *byage* age))
(format t "Age ~D: ~{~A~^, ~}~%" age (map 'list #'(lambda (employee)
(gethash :name employee))
(aref *byage* age)))))
(defparameter *list-of-records* nil)
(map nil #'(lambda (record)
(dolist (key (sort (loop for k being the hash-keys of record collect k)
'string-lessp :key 'symbol-name))
(format t "~A: ~A~%" key (gethash key record)))
(terpri)) *list-of-records*)
(dolist (filename filenames)
(with-open-file (file filename)
(loop
for paragraph = (get-paragraph file)
until (string-equal paragraph "")
do
(let ((fields
(split (create-scanner "^([^:]+):\\s*" :multi-line-mode t)
paragraph :with-registers-p t)))
(push (apply 'mkhash (cdr fields)) *list-of-records*)))))
(deftype tree () '(or null tree-node))
(defstruct (tree-node
(:conc-name #:tree-))
value
(left nil :type tree)
(right nil :type tree))
(defun tree-insert (tree value)
"Return TREE with destructively inserted VALUE."
(declare (type tree tree))
(if tree
(progn (if (< value (tree-value tree))
(setf (tree-left tree)
(tree-insert (tree-left tree) value))
(setf (tree-right tree)
(tree-insert (tree-right tree) value)))
tree)
(make-tree-node :value value)))
(defun print-tree-in-order (tree)
(when tree
(print-tree-in-order (tree-left tree))
(format t "~S " (tree-value tree))
(print-tree-in-order (tree-right tree))))
(defun print-tree-in-preorder (tree)
(when tree
(format t "~S " (tree-value tree))
(print-tree-in-preorder (tree-left tree))
(print-tree-in-preorder (tree-right tree))))
(defun print-tree-in-postorder (tree)
(when tree
(print-tree-in-postorder (tree-left tree))
(print-tree-in-postorder (tree-right tree))
(format t "~S " (tree-value tree))))
(defun search-tree (tree value)
"Return a subtree of TREE with the specified VALUE in root."
(when tree
(if (= (tree-value tree) value)
tree
(search-tree (if (< value (tree-value tree))
(tree-left tree)
(tree-right tree))
value))))
(defun test-trees ()
(let ((tree nil))
(dotimes (i 20)
(setf tree (tree-insert tree (random 1000))))
(format t "~&Pre order: ") (print-tree-in-preorder tree)
(format t "~&In order: ") (print-tree-in-order tree)
(format t "~&Postorder: ") (print-tree-in-postorder tree)
(terpri)
(loop do
(format t "~&Search? ")
(finish-output)
(let* ((eof (gensym)) (value (read *standard-input* nil eof)))
(when (eq value eof) (loop-finish))
(let ((found (search-tree tree value)))
(if found
(format t "Found ~S at ~S~%" value found)
(format t "No ~S in tree~%" value)))))))
(defpackage :alpha (:use :cl))
(in-package :alpha)
(setf name "first")
(defpackage :omega (:use :cl))
(in-package :omega)
(setf name "last")
(in-package :cl-user) (format t "Alpha is ~A, omega is ~A.~%" alpha::name omega::name)
(load "FileHandle.lisp") (load "FileHandle.fasl") (load "FileHandle") (require :FileHandle)
(eval-when (:compile-toplevel :load-toplevel :execute)
(require :FileHandle))
(defpackage :cards.poker
(:use :cl) (:export :shuffle :*card-deck*)) (in-package :cards.poker) (defparameter *card-deck* nil) (defun shuffle ())
(defpackage :your-module (:use :cl)
(:export ...)) (in-package :your-module)
(defparameter *version* 1.00)
(export '(...))
(defparameter *export-tags*
'(:TAG1 ( ... )
:TAG2 ( ... )))
(defpackage :my-package (:use cl)
(:use :your-module)) (defpackage :my-package (:use cl)
(:import-from :your-module ...)) (in-package :my-package)
(import '(your-module:symbol1 your-module:symbol2 ...)) (defpackage :my-package (:use cl)
(:import-from :your-module)) (export '(f1 f2 my-list))
(import '(your-module:op-func your-module:your-table your-module:f1))
(import-tags :your-module :DEFAULT)
(import 'your-module:your-table)
(defparameter *export-tags*
'((:functions (f1 f2 op-func))
(:variables (your-list your-table))))
(import-tags :your-module :functions)
(import 'your-module:your-table)
(eval-when (:compile-toplevel :load-toplevel :execute)
(multiple-value-bind (retval why-not)
(ignore-errors (require :mod)) (when why-not
(warn "couldn't load :mod: ~A" why-not))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(multiple-value-bind (retval why-not)
(ignore-errors (require :mod))
(if why-not
(warn "couldn't load :mod: ~A" why-not)
(use-package :mod))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(let ((dbs '(giant.eenie giant.meanie mouse.mynie moe))
found)
(dolist (module dbs)
(multiple-value-bind (_ why-not)
(ignore-errors (require module))
(unless why-not
(let (import-fn)
(let ((*package* (find-package module)))
(setf import-fn (symbol-function (find-symbol "MY-IMPORT")))
(funcall import-fn)))
(setf found t)
(return))))
(unless found (error "None of ~{~A~^ ~} loaded" dbs))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (and (= 3 (length *posix-argv*)) (= 2 (length (perl-grep *posix-argv* (scan "^\\d+$" it)))))
(error "usage: ~A num1 num2" (car *posix-argv*))))
(require :some.module)
(require :more.modules)
(when opt-b (require :math.bigint))
(defpackage :fcntl (:use cl))
(in-package :fcntl)
(defconstant +O-EXCL+ #x800)
(defconstant +O-CREAT+ #x200)
(defconstant +O-RDWR+ #x2)
(export '(+O-EXCL+ +O-CREAT+ +O-RDWR+))
(provide 'fcntl)
(defpackage :my-package
(:use cl)
(:import-from :fcntl +O-EXCL+ +O-CREAT+ +O-RDWR+))
(in-package :my-package)
(require :fcntl)
(import '(fcntl:+O-EXCL+ fcntl:+O-CREAT+ fcntl:+O-RDWR+))
(in-package cl-user)
(defun load-module (module)
(require module)
(import module)) (load-module :fcntl '(fcntl:+O-EXCL+ fcntl:+O-CREAT+ fcntl:+O-RDWR+))
(defun load-module (module symbols)
(require module)
(import symbols))
(defmacro autouse (pack symbols)
(list*
'progn
(loop
for symb in symbols
collect
`(defun ,symb (&rest args)
(require ',pack)
(apply (find-symbol ,(symbol-name symb) ',pack) args)))))
(defpackage :alpha (:use :cl))
(in-package :alpha)
(defparameter aa 10)
(export 'aa)
(defparameter x "azure")
(defpackage :beta (:use :cl))
(in-package :beta)
(defparameter bb 20)
(export 'bb)
(defparameter x "blue")
(in-package :cl-user) (import '(alpha:aa beta:bb))
(format t "~A, ~A, ~A, ~A, ~A~%" aa bb (if (boundp 'x) x "") alpha::x beta::x)
(defpackage :flipper
(:use cl cl-ppcre)
(:export flip-words flip-boundary))
(in-package :flipper)
(defvar *separatrix* #\Space)
(defun flip-boundary (&optional separatrix)
(prog1 *separatrix*
(when separatrix
(setf *separatrix* separatrix))))
(defun flip-words (line)
(let ((words (split *separatrix* line)))
(format nil (format nil "~~{~~A~~^~A~~}" *separatrix*) (reverse words))))
(setf this-pack #.*package*)
(setf that-pack *package*)
(format t "I am in package *package*~%") (defpackage :alpha (:use cl beta))
(in-package :alpha)
(runit "(setf line (read-line temp))")
(defpackage :beta
(:use cl)
(:export runit))
(in-package :beta)
(defun runit (codestr)
(in-package #.(package-name *package*))
(eval (read-from-string codestr)))
(defpackage :beta
(:use cl)
(:export runit))
(in-package :beta)
(defun runit (codestr)
(eval (read-from-string codestr)))
(defpackage :alpha (:use cl beta))
(in-package :alpha)
(runit (lambda () (setf line (read-line temp))))
(defpackage :beta
(:use cl)
(:export runit))
(in-package :beta)
(defun runit (coderef)
(funcall coderef))
(in-package cl-user)
(defparameter *fh* (open "/etc/services")) (multiple-value-setq (a b c) (values-list (nreadline 3 "*fh*")))
(defun nreadline (count handle)
(unless (plusp count) (error "COUNT must be > 0"))
(let ((handle (symbol-value (find-symbol (string-upcase handle)))))
(unless (open-stream-p handle)
(error "need open filehandle"))
(loop
repeat count
collect (read-line handle))))
(loop
for path in asdf:*central-registry*
for i from 0
do (format t "~D ~A~%" i path))
(pushnew "/projects/spectre/lib" asdf:*central-registry*)
(require :find-bin)
(pushnew find-bin::*bin* asdf:*central-registry*)
(shadowing-import find-bin::*bin*)
(pushnew (concatenate 'string *bin* "/../lib"))
(setf obj (make-instance 'data::encoder))
(let ((obj #(3 5)))
(format t "~A ~A~%" (type-of obj) (aref obj 1))
(setf obj (make-instance 'human::cannibal))
(format t "~A~%" (type-of obj)))
(setf (slot-value obj 'stomach) "Empty" (slot-value obj 'NAME) "Thag") (setf encoded (encode obj "data"))
(setf encoded (data::encode obj "data"))
(setf object (make-instance 'my-class))
(defmethod class-only-method ((class standard-class))
)
(defun class-only-method (class)
(check-type class standard-class)
)
(defmethod my-class-only-method ((class (eql (find-class 'my-class))))
)
(defun my-class-only-method (class)
(check-type class #.(find-class 'my-class))
)
(defparameter *lector* (make-instance 'human::cannibal))
(feed *lector* "Zak")
(move *lector* "New York")
(format *error-output* "stuff here~%")
(move (slot-value obj 'field))
(move (aref ary i))
(slot-value (move obj) 'field)
(aref (move ary) i)
(defmethod initialize-instance :after ((obj my-class) &rest init-args)
"Initialize an object of MY-CLASS"
(setf (slot-value obj 'SOMETHING) 'mumble
(slot-value obj 'SOMETHING-ELSE) 'bumble)
)
(defclass perl-object ()
((_hash :initform (make-hash-table)
:type hash-table))
(:documentation "Can be used as a mixin class to make your class
more Perl-like, or can be used directly."))
(defmethod slot-missing (class (instance perl-object) slot-name operation
&optional (new-value nil new-value-supplied-p))
(symbol-macrolet ((hash-place (gethash slot-name (slot-value instance '_hash))))
(if new-value-supplied-p
(setf hash-place new-value)
hash-place)))
(defclass my-perlish-class (perl-object)
(a b c))
(defun perl-new (class)
(assert (subtypep class 'perl-object))
(make-instance class))
(defun new ()
(let ((self (make-instance 'perl-object))) (setf (slot-value self 'START) (get-universal-time)
(slot-value self 'AGE) 0)
self))
(defun new (classname)
(assert (subtypep classname 'perl-object)) (let ((self (make-instance classname))) (setf (slot-value self 'START) (get-universal-time)
(slot-value self 'AGE) 0)
self)) (defun new (classname &rest initargs)
(assert (subtypep classname 'perl-object)) (let ((self (make-instance classname))) (apply '_init self initargs)
self))
(defmethod _init ((self my-perlish-class) &rest args)
(setf (slot-value self 'start) (get-universal-time)
(slot-value self 'age) 0)
(loop
for key in args by #'cddr
for value in (cdr args) by #'cddr
do
(setf (slot-value self key) value)))
(defmacro with-my-class ((my-obj &rest initargs) &body body)
`(let ((,my-obj (make-instance 'my-class ,@initargs)))
(unwind-protect
(progn ,@body)
(close ,my-obj))))
(defun get-name (self)
(slot-value self 'name))
(defun set-name (self value)
(setf (slot-value self 'name) value))
(defclass my-class ()
((name :accessor name)))
(setf (name my-obj) 'foo val (name my-obj))
(defclass my-class ()
((name :reader get-name :writer set-name)))
(set-name 'foo my-obj) (get-name my-obj)
(defclass my-class ()
(name))
(defmethod get-name ((my-obj my-class))
(slot-value my-obj 'name))
(defmethod set-name ((my-obj my-class) value)
(setf (slot-value my-obj 'name) value))
(defun age (obj &optional (value nil value-supplied-p))
(prog1 (slot-value obj 'age)
(when value-supplied-p
(setf (slot-value obj 'age) value))))
(age obj (1+ (age obj)))
(defclass person ()
((name :accessor name)
(age :accessor age)
(peers :accessor peers)))
(defparameter *him* (make-instance 'person))
(setf (slot-value *him* 'name) "Sylvester"
(slot-value *him* 'age) 23)
(defun person-name (self &optional (value nil value-supplied-p))
(if value-supplied-p
(progn
(and (scan "[^\\s\\w'-]" value) (warn "funny characters in name"))
(and (scan "\\d" value) (warn "numbers in name"))
(or (scan "\\S+(\\s+\\S+)+" value) (warn "prefer multiword name"))
(or (scan "\\S" value) (warn "name is blank"))
(setf (name self) (string-upcase value)))
(name self)))
(defmethod exclaim ((self person))
(with-accessors ((name name) (age age) (peers peers)) self
(format nil
"Hi, I'm ~A, age ~D, working with ~{~A~^, ~}"
name age peers)))
(defmethod happy-birthday ((self person))
(incf (age self)))
(defclass person ()
((gender :accessor gender :initarg :gender)))
(let ((body-count 0))
(defun population ()
body-count)
(defmethod initialize-instance :after ((self person) &rest initargs)
(declare (ignore initargs))
(incf body-count))
(defmethod destroy ((self person))
(declare (ignore self))
(decf body-count))
)
(defvar *people* nil)
(loop repeat 10 do (push (make-instance 'person) *people*))
(format t "There are ~D people alive.~%" (population))
(defparameter *him* (make-instance 'person :gender :male))
(defparameter *her* (make-instance 'person :gender :female))
(fixed-array-max-bounds 100) (defparameter *alpha* (make-instance 'fixed-array))
(format t "Bound on *alpha* is ~D~%" (max-bounds *alpha*))
(defparameter *beta* (make-instance 'fixed-array))
(max-bounds *beta* 50) (format t "Bound on *alpha* is ~D~%" (max-bounds *alpha*))
(defclass fixed-array () ())
(let ((bounds 7))
(macrolet ((bounds-body ()
`(if value-supplied-p
(setf bounds value)
bounds)))
(defmethod max-bounds ((fixed-array fixed-array) &optional (value nil value-supplied-p))
(bounds-body))
(defun fixed-array-max-bounds (&optional (value nil value-supplied-p))
(bounds-body))
))
(defclass fixed-array () (max-bounds-ref))
(let ((bounds-sym (gensym "BOUNDS-"))) (eval-when (:compile-toplevel :load-toplevel :execute)
(setf (symbol-value bounds-sym) 7))
(defmethod initialize-instance :after ((self fixed-array) &rest initargs)
(declare (ignore initargs))
(setf (slot-value self 'max-bounds-ref) bounds-sym))
(defmethod max-bounds ((fixed-array fixed-array) &optional (value nil value-supplied-p))
(if value-supplied-p
(setf (symbol-value (slot-value fixed-array 'max-bounds-ref)) value)
(symbol-value (slot-value fixed-array 'max-bounds-ref))))
(defun fixed-array-max-bounds (&optional (value nil value-supplied-p))
(if value-supplied-p
(setf (symbol-value bounds-sym) value)
(symbol-value bounds-sym))))
(defstruct person
name
age
(peers nil :type list))
(defparameter *p* (make-person))
(setf (person-name *p*) "Jason Smythe") (setf (person-age *p*) 13) (setf (person-peers *p*) '("Wilbur" "Ralph" "Fred"))
(format t "At age ~D, ~A's first friend is ~A.~%"
(person-age *p*)
(person-name *p*)
(car (person-peers *p*)))
(defstruct person name age)
(defstruct family
(head (make-person) :type person)
address
(members nil :type list))
(defparameter *folks* (make-family))
(defparameter *dad* (family-head *folks*))
(setf (person-name *dad*) "John")
(setf (person-age *dad*) 34)
(format t "~A's age is ~D~%"
(person-name (family-head *folks*))
(person-age (family-head *folks*)))
(defmethod age ((person person) &optional (value nil value-supplied-p))
(if value-supplied-p
(progn
(setf (person-age person)
(if (stringp value)
(progn
(when (not (scan "^\\d+" value))
(warn "age `~A' isn't numeric" value))
(let ((age (parse-integer value :junk-allowed t)))
(when (> age 150)
(warn "age `~D' is unreasonable" age))
age))
value)))
(person-age person)))
(let ((gripe (if *should-warn* #'warn #'error)))
(when (not (scan "^\\d+" value))
(funcall gripe "age `~A' isn't numeric" value))
(let ((age (parse-integer value :junk-allowed t)))
(when (> age 150)
(funcall gripe "age `~D' is unreasonable" age))
age))
(defstruct card name color cost type release text)
(defmacro defstruct* (name slots)
`(defstruct ,name ,@slots))
(defstruct* card #.(mapcar #'identity '(name color cost type release text)))
(defstruct* hostent #.(mapcar #'identity '(name
(aliases nil :type list)
addrtype
length
(addr-list nil :type list))))
(defmacro hostent-addr (hostent-object)
`(hostent-addr-list ,hostent-object))
(setf ob1 (make-instance 'some-class))
(setf ob2 (make-instance (class-of ob1)))
(defun new-from-proto (proto)
(let ((self (make-instance (class-of proto))))
(setf (slot-value self 'start) (get-universal-time) (slot-value self 'age) 0)
self))
(let ((methname 'flicker)
(funcall methname obj 10))
(loop for m in '(start run stop)
do (funcall m obj))
(defparameter *fn-ref* #'(lambda (&rest args) (apply 'my-method args)))
(funcall *fn-ref* obj 10 "fred")
(my-method obj 10 "fred")
(when (typep (type-of obj) obj-target)
(when (find-method #'my-method '() (list (type-of obj) t t))
(apply #'my-method obj-target arguments)))
(typep obj 'http:message)
(setf has-io (typep fd 'io:handle))
(setf itza-handle (typep fd 'io:handle))
(setf his-print-method #'as-string)
(defclass person ()
((name :accessor name :initarg :name)
(age :accessor age :initarg :age)))
(let ((dude (make-instance 'person :name "Jason" :age 23)))
(format t "~A is age ~D.~%" (name dude) (age dude)))
(defclass employee (person)
())
(let ((empl (make-instance 'employee :name "Jason" :age 23)))
(format t "~A is age ~D.~%" (name empl) (age empl)))
(defmethod meth ((self my-class))
(call-next-method))
(meth self)
(defmethod initialize-instance :after ((self my-class) &rest initargs)
(with-slots (start age extra)
(setf (start self) (get-decoded-time) (age self) 0
(extra self) initargs (defparameter *obj* (make-instance 'widget :haircolor :red :freckles 121))
(defclass person (perl-object)
((ok-field :initform (mkhash 'name t 'age t 'peers t 'parent t)
:type hash-table
:allocation :class)))
(defmethod slot-missing (class (instance person) slot-name operation
&optional new-value)
(declare (ignore new-value operation))
(if (gethash slot-name (slot-value instance 'ok-field))
(call-next-method) (error "invalid attribute method ~A" slot-name)))
(let ((dad (make-instance 'person))
(kid (make-instance 'person)))
(setf (slot-value dad 'name) "Jason"
(slot-value dad 'age) 23
(slot-value kid 'name) "Rachel"
(slot-value kid 'age) 2
(slot-value kid 'parent) dad
)
(format t "Kid's parent is ~A~%" (slot-value (slot-value kid 'parent) 'name)))
(defpackage :person (:use cl))
(in-package person)
(defclass person ()
((name :accessor name)
(age :accessor age)
(peers :accessor peers)
(parent :accessor parent)))
(export '(person name age peers parent))
(defpackage :employee (:use cl))
(in-package employee)
(defclass employee (person:person)
((salary :accessor salary)
(age :accessor age)
(boss :accessor boss)))
(export '(employee salary age boss))
(setf (next node) node)
(defclass node ()
((next :accessor next :type node)
(prev :accessor prev :type node)
(value :accessor value)))
(defclass ring ()
((dummy :accessor dummy :type node)
(ring-count :accessor ring-count :type number :initform 0)))
(defmethod initialize-instance :after ((self ring) &rest init-args)
(declare (ignore init-args))
(let ((dummy (make-instance 'node)))
(setf (next dummy) dummy
(prev dummy) dummy
(value dummy) 'dummy) (setf (dummy self) dummy)))
(loop for i below 20
do (let ((r (make-instance 'ring)))
(loop repeat 1000
do (insert r i))))
(defmethod destroy ((ring ring))
(loop for node = (next (dummy ring)) then (next node)
until (eq node (dummy ring))
do (delete-node ring node))
(setf (prev (dummy ring)) nil
(next (dummy ring)) nil))
(defmethod delete-node ((ring ring) (node node))
(setf (next (prev node)) (next node)
(prev (next node)) (prev node))
(decf (ring-count ring)))
(defmethod ring-search ((ring ring) value &key (test 'eql))
"Find VALUE in the RING structure, returning a NODE."
(loop
for node = (next (dummy ring)) then (next node)
until (eq node (dummy ring))
do (when (funcall test (value node) value)
(return-from ring-search node)))
(dummy ring))
(defmethod insert ((ring ring) value)
"Insert VALUE into the RING structure."
(let ((node (make-instance 'node)))
(setf (value node) value
(next node) (next (dummy ring))
(prev (next (dummy ring))) node
(next (dummy ring)) node
(prev node) (dummy ring))
(incf (ring-count ring))))
(defmethod delete-value ((ring ring) value &key (test 'eql))
"Delete a node from the RING structure by VALUE."
(let ((node (ring-search ring value :test test)))
(unless (eq node (dummy ring))
(delete-node ring node))))
(defmethod print-object ((node node) stream)
(format stream "#<NODE ~A>" (value node)))
(defmethod print-object ((ring ring) stream)
(format stream "#<RING")
(do ((node (next (dummy ring)) (next node)))
((eq node (dummy ring)))
(format stream " ~A" node))
(format stream ">"))
(defmethod <=> ((s1 hash-table) (s2 hash-table))
(let ((s1 (gethash 'name s1))
(s2 (gethash 'name s2)))
(case (string-lessp s1 s2)
(nil (if (string= s1 s2)
0
1))
(t -1))))
(defpackage :time-number-internal (:use cl))
(defpackage :time-number)
(in-package time-number)
(cl:defclass time-number ()
((seconds :accessor seconds :initform 0 :initarg :seconds)
(minutes :accessor minutes :initform 0 :initarg :minutes)
(hours :accessor hours :initform 0 :initarg :hours)
))
(cl:defmethod + ((left time-number) (right time-number))
(time-number-internal::my-plus left right))
(cl:export 'time-number)
(in-package time-number-internal)
(defun my-plus (left right)
(let ((answer (make-instance 'time-number:time-number)))
(with-accessors ((answer-seconds seconds) (answer-minutes minutes) (answer-hours hours)) answer
(setf answer-seconds (+ (seconds left)
(seconds right))
answer-minutes (+ (minutes left)
(minutes right))
answer-hours (+ (hours left)
(hours right)))
(when (>= answer-seconds 60)
(setf answer-seconds (mod answer-seconds 60))
(incf answer-minutes))
(when (>= answer-minutes 60)
(setf answer-minutes (mod answer-minutes 60))
(incf answer-hours)))
answer))
(use-package :sb-bsd-sockets)
(defparameter *addresses* (host-ent-addresses (get-host-by-name name)))
(defun inet-ntoa (packed-address)
(format nil "~{~D~^.~}" (coerce packed-address 'list)))
(defparameter *address* (inet-ntoa (make-inet-address *name*)))
(use-package :sb-bsd-sockets)
(defparameter *name* (get-host-by-address #(192 48 96 9)))
(use-package :sb-bsd-sockets)
(defparameter *packed-address* (make-inet-address "208.146.140.1"))
(defparameter *ascii-address* (inet-ntoa *packed-address*)) (use-package :sb-bsd-sockets)
(let* ((packed (get-host-by-name *hostname*)) (address (host-ent-address packed)))
(format t "I will use ~A as the address for ~A~%" address *hostname*))
(use-package :sb-bsd-sockets)
(defparameter *name* (host-ent-name
(get-host-by-address (make-inet-address *address*))))
(defparameter *addresses* (host-ent-addresses (get-host-by-name *name*)))
(defparameter *found* (member *address* *addresses* :test 'equal :key 'inet-ntoa))