1. Strings

;;;-----------------------------
(setf string "\\n")                     ; two characters, \ and an n
(setf string "John 'Maddog' Orwant")    ; literal single quotes
;;;-----------------------------
;; newlines may be inserted literally
(setf string "                          
")                                      ; a "newline" character
;; or by creating a string explicitly
(setf string (make-string 1 :initial-element #\Newline))
;; or by using format with a nil output stream
(setf string (format nil "~%"))
(setf string "John \"Maddog\" Orwant")  ; literal double quotes
;;;-----------------------------
(setf string "John 'Maddog' Orwant")  ; literal single quotes
;;;-----------------------------
(setf string "
This is a multiline string, terminated by a
double quotation mark.
")
;;;-----------------------------
;; There are no CL equivalents to Perl's other ways of quoting
;; strings (q//, etc).
;;;-----------------------------

;;;-----------------------------
;; assign a substring to a variable
(setf value (subseq string offset (+ offset count)))
(setf value (subseq string offset))

;; edit a substring
(setf string (concatenate 'string 
                          (subseq string 0 offset) 
                          newstring
                          (subseq string (+ offset count))))
(setf string (concatenate 'string 
                          (subseq string 0 offset) 
                          newtail))
;;;-----------------------------
;; get a 5-byte string, skip 3, then grab 2 8-byte strings, then the
;; rest
(setf leading (subseq data 5)
      s1 (subseq data 8 8)
      s2 (subseq data 16 8)
      trailing (subseq data 24))

;; split at five byte boundries
(let ((length (length string)))
  (loop for idx from 0 upto length by 5
     collect (subseq string idx (min length (+ idx 5)))))

;; chop string into individual characters
(loop for idx from 0 upto (1- (length string))
      collect (char string idx))
;;;-----------------------------
(defparameter *string* "This is what you have")
;;;             +012345678901234567890  Indexing forwards  (left to right)
;;;              109876543210987654321- Indexing backwards (right to left)

(let ((first (subseq *string* 0 1))                        ; "T"
      (start (subseq *string* 5 7))                        ; "is"
      (rest (subseq *string* 13))                       ; "you have"
      (last (subseq *string* (+ (length *string*) -1))) ; "e"
      (end (subseq *string* (+ (length *string*) -4)))   ; "have"
      (piece (subseq *string*
                     (+ (length *string*) -8)
                     (+ (length *string*) -8 3)))) ; "you"
  (list first start rest last end piece))
;; ("T" "is" "you have" "e" "have" "you")
;;;-----------------------------
(defparameter *string* "This is what you have")
(print *string*)
;; This is what you have

;; Change "is" to "wasn't"
(setf *string* (concatenate 'string
                            (subseq *string* 0 5)
                            "wasn't"
                            (subseq *string* (+ 5 2))))
;; This wasn't what you have

;; Replace last 12 characters
(setf *string* (concatenate 'string
                            (subseq *string* 0 (+ (length *string*) -12))
                            "ondrous"))
;; This wasn't wondrous

;; Delete first character
(setf *string* (subseq *string* 1))
;; his wasn't wondrous

;; Delete last 10 characters
(setf *string* (subseq *string* 0 (+ (length *string*) -10)))
;; his wasn'
;;;-----------------------------
;; you can test substrings with the :start and :end keyword parameters
;; of CL-PPCRE:SCAN
(when (scan "pattern" *string* :start (- (length *string*) 10))
  (format t "Pattern matches in last 10 characters~%"))

;; substitute "at" for "is", restricted to first five characters
(concatenate 'string
              (regex-replace "is" *string* "at"
                             :start 0
                             :end (min (length *string*) 5))
              (when (> (length *string*) 5)
                (subseq *string* 5)))
;;;-----------------------------
;; exchange the first and last letters in a string
(let ((a "make a hat"))
  ;; ROTATEF is CL's general-purpose swap macro
  (rotatef (char a 0) (char a (1- (length a))))
  (princ a))
;; take a ham
;;;-----------------------------
;; extract column with SUBSEQ
(let* ((a "To be or not to be")
       (b (subseq a 6 12))) ; skip 6, grab 6
  (format t "~A~%" b)
;; or not

  ;; forward 6, grab 2; backward 5, grab 2
  (destructuring-bind (b c) `(,(subseq a 6 8) ,(subseq a 3 5))
    (format t "~A~%~A~%" b c)))
;; or
;; be
;;;-----------------------------
(defun cut2fmt (&rest positions)
  "Useless in CL, which lacks Perl's unpack(); here for completeness."
  (let ((template "")
        (lastpos 1))
    (dolist (place positions)
      (setf template (format nil "~AA~D " template (- place lastpos)))
      (setf lastpos place))
    (setf template (concatenate 'string template "A*"))
    template))
(let ((fmt (cut2fmt 8 14 20 26 30)))
  (format t "~A~%" fmt))
;; A7 A6 A6 A6 A4 A*
;;;-----------------------------

;;;-----------------------------
;; use b if b is true, else c
(setf a (or b c))

;; set x to y unless x is already true
(unless x (setf x y))
;;;-----------------------------
;; use B if B is defined, otherwise C
(setf a (if (boundp 'b) b c))
;;;-----------------------------
(setf foo (or bar "DEFAULT VALUE"))
;;;-----------------------------
#+sbcl 
(defparameter ARGV (copy-seq (cdr *posix-argv*)) "Arguments from shell, Perl style")

(setf dir (or (pop ARGV) "/tmp"))
;;;-----------------------------
(setf dir (or (nth 0 ARGV) "/tmp"))
;;;-----------------------------
(setf dir (if (plusp (length ARGV)) (pop ARGV) "/tmp"))
;;;-----------------------------
(setf dir (if (plusp (length ARGV)) (nth 0 ARGV) "/tmp"))
;;;-----------------------------
(setf count (make-hash-table))
(incf (gethash (or shell "/bin/sh") count 0))
;;;-----------------------------
;; find the user name on Unix systems
(setf user (or (posix-getenv "USER")
               (posix-getenv "LOGNAME")
               #+sbcl
               (let ((uid (sb-posix:getuid)))
                 (or (sb-posix:passwd-name (sb-posix:getpwuid uid))
                     (format nil "Unknown uid number ~a" uid)))
               #-sbcl
               "Unknown uid"))
;;;-----------------------------
(setf starting-point (or starting-point "Greenwich"))
;;;-----------------------------
;; Perl array-to-array assignment copies the array, hence the need for
;; COPY-SEQ below.
(unless (plusp (length a))
  (setf a (copy-seq b)))                ; copy only if empty
(setf a (copy-seq (if (plusp (length b))
                      b
                      c)))              ; assign b if nonempty, else c
;;;-----------------------------

;;;-----------------------------
;; There are several ways to swap variables in CL.  ROTATEF is usually
;; the simplest choice.
(rotatef VAR1 VAR2)
(psetq VAR1 VAR2 VAR2 VAR1)
(multiple-value-setq (VAR1 VAR2) 
  (values VAR2 VAR1))
;;;-----------------------------
(setf temp a
      a b
      b temp)
;;;-----------------------------
(let ((a "alpha")
      (b "omega"))
  (rotatef a b))           ; the first shall be last -- and versa vice
;;;-----------------------------
(destructuring-bind (alpha beta production)
    ;; In CL one would normally use symbols here:
    ;; '(January March August)
    '("January" "March" "August")
  ;; move beta       to alpha,
  ;; move production to beta,
  ;; move alpha      to production
  (rotatef alpha beta production))
;;;-----------------------------

;;-----------------------------
(setq num (char-code char))
(setq char (code-char num))
;;-----------------------------
(setq char (format nil "~c" (code-char num)))
(format t "Number ~d is character ~c~%" num (code-char num))
;; Number 101 is character e
;;;-----------------------------
(setq ASCII (map 'list #'char-code string))
(setq string (map 'string #'code-char ASCII))
;;-----------------------------
(setq ascii-value (char-code #\e))             ; now 101
(setq character (code-char 101))               ; now #\e
;;-----------------------------
(format t "Number ~D is character ~C~%" 101 (code-char 101))
;;-----------------------------
(let ((ascii-character-numbers (map 'list #'char-code "sample")))
  (format t "~{~A~^ ~}~%" ascii-character-numbers)
;; 115 97 109 112 108 101
  (setf word (map 'string #'code-char ascii-character-numbers))
  (setf word (map 'string #'code-char #(115 97 109 112 108 101))) ; same
  (format t "~A~%" word))
;; sample
;;;-----------------------------
(let* ((hal "HAL")
       (ibm (map 'string
                 (lambda (char)
                   (code-char (1+ (char-code char)))) ; add one to each ASCII value
                 hal)))
  (format t "~A~%" ibm))                ; prints "IBM"
;;;-----------------------------

;;;-----------------------------
(setq array (map 'list #'string string))

(setq array (loop for char across string
               collect (char-code char)))
;;;-----------------------------
(do-matches-as-strings (match "(.)" string)
  ;; do something with MATCH
  )
;;;-----------------------------
(let ((seen (make-hash-table))
      (string "an apple a day"))
  (loop for char across string do
       (incf (gethash char seen 0)))
  (let ((chars (loop for char being each hash-key of seen
                  collect char)))
    (format t "unique chars are: ~{~C~}~%" 
            (sort chars '< :key 'char-code))))
;; unique chars are:  adelnpy
;;;-----------------------------
(let ((string "an apple a day"))
  (format t "sum is ~D~%"
          (reduce #'+ string :key #'char-code)))
(let ((string "an apple a day"))
  (format t "sum is ~D~%"
          (loop for char across string
                summing (char-code char))))
;;;-----------------------------
(let ((string "an apple a day"))
  (format t "sum is ~D~%"
          (loop for char across string
             sum (char-code char))))
;; prints "1248" if string was "an apple a day"
;;;-----------------------------
;; There's no equivalent to Perl's unpack(), this is about as close as
;; you can get.
(setf sum (loop for char across string
             sum (char-code char)))
;;;-----------------------------
;; In CL it makes more sense to call this function from the REPL than
;; it does to put it into a separate script.  E.g.,
;;  > (sum "/tmp/xyz" "~/foo/bar.txt")
(defun sum (&rest files)
  (let ((sum 0))
    (dolist (filename files)
      (with-open-file (file filename :element-type 'unsigned-byte)
        (do ((b (read-byte file nil :eof)
                (read-byte file nil :eof)))
            ((eql b :eof))
          (incf sum b))))
    (let ((r (+ (mod sum (expt 2 16))
                (truncate (/ (mod sum (expt 2 32))
                             (expt 2 16))))))
      (+ (mod r (expt 2 16))
         (truncate (/ r (expt 2 16)))))))
;;;-----------------------------
;;CL-USER> (sum "/mach.sym")
;;24298
;;;-----------------------------
;;%cksum -o 2 /mach.sym
;;24298 1203 /mach.sym
;;;-----------------------------
(defun slowcat (number-or-filename &rest more-files)
  "The first argument can be a number of seconds to sleep between
characters, otherwise it should be a file name."
  (let ((delay (if (numberp number-or-filename) number-or-filename 1))
        (files (if (numberp number-or-filename) more-files (cons number-or-filename more-files))))
    (dolist (filename files)
      (with-open-file (file filename)
        (do ((c (read-char file nil :eof)
                (read-char file nil :eof)))
            ((eql c :eof))
          (format t "~C" c)
          (finish-output)
          (sleep (* delay 0.005)))))))

;;;-----------------------------
(setq revbytes (reverse string))
;;;-----------------------------
(setq revwords (format nil "~{~A~^ ~}"
                       (reverse (split " " string))))
(setq revwords (reverse
                (do* ((stringstream (make-string-input-stream string))
                      (result nil (cons next result))
                      (next (read stringstream nil 'eos)
                            (read stringstream nil 'eos)))
                     ((equal next 'eos)
                      (reverse result)))))
;;;-----------------------------
(setq gnirts (reverse string))          ; reverse letters in string

(setq sdrow (reverse words))            ; reverse elements in words

(setq confused (reverse (apply #'concatenate 'string words))) ; reverse letters in join("", @words)
;;;-----------------------------
(setq string "Yoda said, \"can you see this?\"")
(setq allwords (split " " string))
(setq revwords (format nil "~{~A~^ ~}" (reverse allwords)))
(format t "~A~%" revwords)
;this?" see you "can said, Yoda
;;;-----------------------------
(setq revwords (format nil "~{~A~^ ~}" (reverse (split " " string))))
;;;-----------------------------
(setq revwords (apply #'concatenate 'string
                      (split "(\\s+)" string :with-registers-p t)))
;;;-----------------------------
(defun palindrome-p (word)
  (string= word (reverse word)))
(palindrome-p "reviver")
;; T
;;;-----------------------------
(with-open-file (inf "/usr/share/dict/words")
  (loop for word = (read-line inf nil nil)
        while word
        when (and (string= word (reverse word)) 
                  (> (length word) 5))
        do (format t "~a~%" word)))
;; deedeed
;; degged
;; hallah
;; kakkak
;; murdrum
;; redder
;; repaper
;; retter
;; reviver
;; rotator
;; sooloos
;; tebbet
;; terret
;;;-----------------------------

;;;-----------------------------

;;;-----------------------------
(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)
;; I am 24 high and 80 long
;;;-----------------------------
(setf text "I am 17 years old")
(setf text (regex-replace-all "(\\d+)" text
                                       (lambda (match num-str)
                                         (declare (ignore match))
                                         (write-to-string
                                          (* 2 (parse-integer num-str))))
                                       :simple-calls t))
;;;-----------------------------
(* 2 17)
;;;-----------------------------
;; expand variables in text, but put an error message in
;; if the variable isn't defined
(flet ((deref-with-err (match word)
         (declare (ignore match))
         (let ((word-sym (intern (string-upcase word))))
           (if (boundp word-sym)
               (write-to-string (symbol-value word-sym))
               (format nil "[NO VARIABLE: $~a]" word-sym)))))
  (setf text (regex-replace-all "\\$(\\w+)" text
                                         #'deref-with-err
                                         :simple-calls t)))
;;;-----------------------------

;;;-----------------------------
(setf big (string-upcase little))       ; "bo peep" -> "BO PEEP"
(setf little (string-downcase big))     ; "JOHN"    -> "john"
;; Reminder: the following depends on CL-INTERPOL.
(setf big #?"\U$(little)")              ; "bo peep" -> "BO PEEP"
(setf little #?"\L$(big)")              ; "JOHN" -> "john"
;;;-----------------------------
(setf big (string-upcase little :end 1)    ; "bo"      -> "Bo"
(setf little (string-downcase BIG :end 1)) ; "BoPeep"    -> "boPeep"
(setf big #?"\u$(little)")                 ; "bo"      -> "Bo"
(setf little #?"\l$(big)")                 ; "BoPeep"    -> "boPeep"
;;;-----------------------------
(setf beast "dromedary")
;; Capitalize various parts of beast
(setf capit (string-upcase beast :end 1))      ; Dromedary
(setf capit #?"\u\L$(beast)")                  ; (same)
(setf capall (string-upcase beast))            ; DROMEDARY
(setf capall #?"\U$(beast)")                   ; (same)
(setf caprest (string-downcase (string-upcase beast) :end 1)) ; dROMEDARY
(setf caprest #?"\l\U$(beast)")                               ; (same)
;;;-----------------------------
;; capitalize each word's first character, downcase the rest
(setf text "thIS is a loNG liNE")
(format t "~A~%" (string-capitalize text))
;; This Is A Long Line
;;;-----------------------------
;; string= is case-sensitive, string-equal is case-insensitive
(when (string-equal a b)
  (format t "a and b are the same~%"))
;;;----------------------------- 
;; It's considered bad form to perform bitwise operations on character
;; types, and breaks unicode-aware lisps.  Trust the compiler to
;; optimize.
(defun randcase (char)
  (if (< (random 100) 20)
      (char-upcase char)
      (char-downcase char)))
;;;-----------------------------

;;;-----------------------------
(setf answer (concatenate 'string var1 (func) var2))
;;;-----------------------------
(setf answer (format nil "STRING ~{~A~} MORE STRING" list-expr))
(setf answer (format nil "STRING ~A MORE STRING" atomic-expr))
;;;-----------------------------
(setf phrase (format nil "I have ~D guanacos." (1+ n)))
(setf phrase #?"I have ${(1+ n)} guanacos.") ; uses CL-INTERPOL
;;;-----------------------------
(format t "I have ~D guanacos.~%" (1+ n))
;;;-----------------------------
(some-func (format nil "What you want is ~{~A~} items"
                   (split ":" rec)))
;;;-----------------------------
(let ((text (format nil "~
To: ~A
From: Your Bank
Cc: ~{~A~^, ~}
Date: ~A (today)

Dear ~A,

Today, you bounced check number ~D to us.
Your account is now closed.

Sincerely,
the management
"
                    naughty
                    (get-manager-list naughty)
                    (let (date-str (with-output-to-string (str)
                                     (run-program "/bin/date" nil
                                                  :output str)))
                      (subseq date-str 0 (1- (length date-str))))
                    naughty
                    (+ 500 (random 100)))))
  (unless (send-mail text target)
    (error "Couldn't send mail")))
;;;-----------------------------

;;;-----------------------------
;; all in one
(setf var (regex-replace-all
           (create-scanner #?r"^\s+" :multi-line-mode t)
"your text
goes here
" ""))

;; or with two steps
(setf var "your text
goes here
")
(setf var (regex-replace-all 
           (create-scanner #?r"^\s+" :multi-line-mode t)
           var
           ""))
;;-----------------------------
(setf var (regex-replace-all 
           (create-scanner #?r"^\s+" :multi-line-mode t)
"    The five varieties of camelids
    are the familiar camel, his friends
    the llama and the alpaca, and the
    rather less well-known guanaco
    and vicuña.
" ""))
;;;-----------------------------
(defun fix (string)
  (regex-replace-all
   (create-scanner #?r"^\s+" :multi-line-mode t)
   string
   ""))

(format t "~A~%" (fix "    My stuff goes here
")
;;;-----------------------------
(setf quote 
      (regex-replace-all
       (create-scanner #?r"\s+--")
       (regex-replace-all 
        (create-scanner #?r"^\s+" :multi-line-mode t)
"        ...we will have peace, when you and all your works have
        perished--and the works of your dark master to whom you would
        deliver us. You are a liar, Saruman, and a corrupter of mens
        hearts.  --Theoden in /usr/src/perl/taint.c
"
       "")
       "
--"))
;;-----------------------------
(when *remember-the-main*
  (setf perl-main-C (dequote
"        @@@ int
         @@@ runops() {
         @@@     SAVEI32(runlevel);
         @@@     runlevel++;
         @@@     while ( op = (*op->op_ppaddr)() ) ;
         @@@     TAINT_NOT;
         @@@     return 0;
         @@@ }
"
  ;; add more code here if you want
   )))
;;;-----------------------------
(defparameter *poem* (dequote
"       Now far ahead the Road has gone,
          And I must follow, if I can,
       Pursuing it with eager feet,
          Until it joins some larger way
       Where many paths and errands meet.
          And whither then? I cannot say.
                --Bilbo in /usr/src/perl/pp_ctl.c
"))

(format t "Here's your poem:~%~%~A~%" *poem*)
;;;-----------------------------
(defun dequote (string)
  ;; Can't get multiple values returned thru the OR, hence the use of
  ;; DESTRUCTURING-BIND instead of MULTIPLE-VALUE-BIND
  (destructuring-bind (white leader) ; common whitespace and common leading string
      (or (register-groups-bind ($1 $2)
              (#?r/^\s*(?:([^\w\s]+)(\s*).*\n)(?:\s*\1\2?.*\n)+$/ string)
            (list $2 (quote-meta-chars $1)))
          (list (scan-to-strings #?r"^(\s+)" string) ""))
    (regex-replace-all
     (create-scanner (format nil #?r"^\s*?~a(?:~a)?" leader white) :multi-line-mode t)
     string
     "")))
;;;-----------------------------

(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)
; => "foo0 foo1 foo2
;     foo3 foo5 foo6
;     foo7 foo8 foo9
;     bar0
;     
;     bar2 bar1
;     
;     bar3 bar4 bar5
;     bar6 bar7 bar8
;     baz0 bar9
;     
;     baz1 baz2 baz3
;     baz4 baz5 baz6
;     baz9 baz8 baz7"

;; backslash
(setf var (regex-replace-all "([CHARLIST])" var "\\\1"))

;; double
(setf var (regex-replace-all "([CHARLIST])" var "\\1\\1"))
;;;-----------------------------
(setf string (regex-replace-all "%" string "%%"))
;;;-----------------------------
(setf string "Mom said, \"Don't do that.\"")
(setf string (regex-replace-all "(['\"])" string #?r"\\\1"))
;;;-----------------------------
(setf string "Mom said, \"Don't do that.\"")
(setf string (regex-replace-all "(['\"])" string #?r"\1\1"))
;;;-----------------------------
(setf string (regex-replace-all #?r"([^A-Z])" string #?r"\\\1"))
;;;-----------------------------
(setf string #?r"this \Qis a test!\E")
(setf string "this is\\ a\\ test\\!")
(setf string (concatenate 'string "this " (quote-meta-chars "is a test!")))
;;;-----------------------------

;;;-----------------------------
(setf string (regex-replace #?r/^\s+/ string "")) 
(setf string (regex-replace #?r/\s+$/ string ""))
;;;-----------------------------

;;; The closest thing to Perl's wantarray is CL's ability to return
;;; multiple values from a function.  Unless the caller uses
;;; MULTIPLE-VALUE-BIND (or, in this case, MULTIPLE-VALUE-LIST), they
;;; will only "see" the first value.  Note also that, normally, you'd
;;; use CL's built-in STRING-TRIM function for this.
(defun trim (&rest strings)
  (values-list 
   (loop for string in strings
      collect (regex-replace #?r/^\s+/ 
                                      (regex-replace #?r/\s+$/ string "")
                                      ""))))

(setf string (trim string))
(setf many (multiple-value-list (apply 'trim many)))
;;;-----------------------------
;; print what's typed, but surrounded by >< symbols
(loop
   (let ((line (read-line)))
     (chomp line)
     (format t #?">$(line)<~%")))
;;;-----------------------------

;;;-----------------------------
(defun parse-csv (text)
  (let (fields)
    (cl-ppcre:do-register-groups (quoted unquoted)
        ("\"([^\"\\\\]*(?:\\\\.[^\"\\\\]*)*)\",?|([^,]+),?|," text)
      (push (or quoted unquoted) fields))
    (nreverse fields)))
;;;-----------------------------
;; CL has no obvious equivalent to Text::ParseWords
;;;-----------------------------
(defparameter *line* "XYZZY,\"\",\"O'Reilly, Inc\",\"Wall, Larry\",\"a \\\"glug\\\" bit,\",5,\"Error, Core Dumped\"")
(let ((fields (parse-csv *line*)))
  (loop
     for i below (length fields)
     do (format t "~D : ~A~%" i (elt fields i))))
;;0 : XYZZY
;;1 : 
;;2 : O'Reilly, Inc
;;3 : Wall, Larry
;;4 : a \"glug\" bit,
;;5 : 5
;;6 : Error, Core Dumped
;;;-----------------------------

(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")))

; TEST> (prompt-lookup-user)
; Lookup user: volkan
; User: "vy". (Matched Token: "Volkan".)

(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)))
; => "If I have analyzed these builtin
;     results correctly in a chastised manner
;     from command-line"

(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)))
; => F   UID   PID  PPID PRI  NI    SZ   RSS WCHAN  STAT TT           TIME COMMAND
;    1  1000  2931     1  19   0   828  2644 -      Ss   ?        00:00:03 /usr/bin/fetchmail --daemon 600 --logfile /home/vy/.fetchmail.log
;    1  1000  3106  3104  19   0  1700  2360 -      Ss   ?        00:00:09 SCREEN -U