(in-package :cl-user)
(require :cl-ppcre)
(require :iterate)
(use-package '(cl-ppcre iterate))
(declaim (optimize (speed 0) (safety 3) (debug 3)))
(defun chomp (string)
"Similar to Perl's chomp(), although it returns the new value of
STRING rather than the number of characters removed, and doesn't
modify its argument."
(string-right-trim #(#\Newline #\Return) string))
(defmacro when-let ((var value) &body body)
"Evaluate VALUE, and if the result is non-nil bind it to VAR
and evaluate BODY."
`(let ((,var ,value))
(when ,var ,@body)))
(defmacro perl-grep (sequence &body predicate-body)
"Like Perl's grep. Predicate is a body of code that can refer to IT
as the current element of the list."
`(remove-if-not #'(lambda (it)
,@predicate-body)
,sequence))
(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
"")))
(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))))
(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))
(loop for i from x upto y
do
)
(loop for i from y downto x
do
)
(do ((i x (1+ i)))
((> i y))
)
(loop for i from x upto y by 7
do
)
(format t "Infancy is: ~{~A~^ ~}~%"
(loop for i from 0 to 2 collect i))
(format t "Toddling is: ~{~A~^ ~}~%"
(loop for i from 3 to 4 collect i))
(format t "Childhood is: ~{~A~^ ~}~%"
(loop for i from 5 to 12 collect i))
(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)))))