common lisp

for loop

(loop for x in '(1 2 3)
      collect x) ;; returns list

(loop for x in '(1 2 3)
      do (print x)) ;; prints the numbers

(loop for x in '(a b c)
    for y in '(1 2 3)
    collect (list x y))
 ;; ((A 1) (B 2) (C 3))

(loop for x in '(a b c d e)
      for y from 1
      if (> y 1)
        do (format t ", ~A" x)
      else
        do (format t "~A" x))
;; A, B, C, D, E
;; NIL

functions

(defun <name> (list of arguments)
  "docstring"
  (body))

plist

defining a plist

(setf my-plist '(alt "yes" bar "no"))

retrieve a value by key

(getf my-plist 'alt)

change the value that corresponds to a key

(setf (getf my-plist 'alt) 45)

get a list of the attributes

(loop for (key value) on my-plist by #'cddr
      collect key)

unbind variable

(makunbound 'foo)

undefine funciton

(fmakunbound 'function)

quicklisp

need to install it manually afaik

curl -O https://beta.quicklisp.org/quicklisp.lisp
sbcl --load quicklisp.lisp

then in sbcl

(quicklisp-quickstart:install :path "~/.quicklisp")
(ql:add-to-init-file)

then to install a package in sbcl:

(ql:quickload "cl-csv")

this will install the package if it doesnt exist, and if it exists it just loads it

classes

example class:

(defclass my-class ()
  ((property1 :accessor property1-accessor)
   (property2 :accessor property2-accessor)))

the accessor is the name you use to access a property1
we construct an object using make-instance:

(defvar p1 (make-instance 'my-class))

we can initialize the class with specific values, first we need to use the :initarg keyword on the class properties

(defclass my-class ()
  ((property1 :initarg property1-initarg :initform default-value :accessor property1-accessor)
   (property2 :accessor property2-accessor)))

then we can pass the values we want to make-instance
:initform is used to pass a default value to the slot incase :initarg argument isnt passed to make-instance

(defvar p1 (make-instance 'my-class :property1-initarg property1-value))

this is the syntax for accessing variables of a class

(property1-accessor p1)

we can do inheritance by passing the parent class in the parenthases after the class name:

(defclass my-class (my-parent-class))

the following syntax is used to define a function for a class, note that the function print-object is the function that gets called when trying to print an object using (print object) so thats what we're defining here

(defmethod print-object ((obj my-class) stream)
  (print-unreadable-object (obj stream :type t)
    (format stream "value of property1: ~a" (property1 obj))))

structs

structs are basically simpler classes with default functions/initializers/etc

(defstruct rgb ()
           (r 0) (g 0) (b 0)) ;; initialize slot values to 0

;; e.g. constructor built by default
(setf color (make-rgb :r 2)) ;; => #S(RGB :NIL NIL :R 2 :G 0 :B 0)

(list (rgb-r color) (rgb-b color)) ;; => (2 0)

arrays/matrices

to create an array:

(make-array 10 :initial-element 10)

multidimensional arrays:

(make-array '(4 3) :initial-element 15)

#2A((15 15 15) (15 15 15) (15 15 15) (15 15 15))

access slot in array

(aref (make-array '(4 3 1) :initial-element 15) 2 0 0)

get the length of the array (last argument is the dimension to check length of):

(print (array-dimension (make-array '(4 3) :initial-element 15) 0))
(print (array-dimension (make-array '(4 3) :initial-element 15) 1))

4
3

iterate through array:

(map nil #'print (make-array 3 :initial-element 15))

15
15
15

iterate with index:

(let ((arr (make-array '(4 3) :initial-element 15)))
  (loop for i from 0 below (array-dimension arr 0)
    do (print (aref arr i 1))))

15
15
15
15

use displacement arrays to get the first element of every row in a 2d array:

(loop for i from 0 below (array-dimension arr 0)
      collect (let ((row (make-array
                          (array-dimension arr 1)
                          :displaced-to arr
                          :displaced-index-offset (* i (array-dimension arr 1)))))
                (aref row 0)))

we can create resizable arrays with the :adjustable keyword, :fill-pointer denotes the next position to be filled in the array and is automatically maintained by the array itself, but has to be initialized

(defparameter *x* (make-array 0 :adjustable t :fill-pointer 0))
(vector-push-extend 'a *x*)
(vector-push-extend 'b *x*)
*x*

fill array manually:

(make-array '(3 3) :initial-contents '((1 0 0) (0 1 0) (0 0 1)))

vectors

create vector

(vector 3 5 1)

we can use length on vectors

(length (vector 3 5 1)) ==> 3

get nth element:

(defparameter *x* (vector 1 2 3))
(length *x*) ==> 3
(elt *x* 1)  ==> 2

we can have nested vectors

(let ((a (vector (vector 1 2) (vector 3) 4)))
  (print a)
  (print (elt a 0)))

#(#(1 2) #(3) 4)
#(1 2)

multithreading

in sbcl sb-thread:make-thread takes a function to call in a newly created thread.

(sb-thread:make-thread
 (lambda ()
   (progn
     (sleep 0) ;; give other threads a chance to run, then return here
     (setf c (+ a b))
     (print "ADDITION:")
     (print c))))

although notice that this is special to sbcl.
the lparallel library works great on multiple CL implementations, more on lparallel at https://lparallel.org/page/2/

macros

simple macro from https://lispcookbook.github.io/cl-cookbook/macros.html:

(defmacro setq2 (v1 v2 e)
  (list 'progn (list 'setq v1 e) (list 'setq v2 e)))
;; (setq2 v1 v2 3) => v1=3,v2=3

this macro is very close to the following function definition:

(defun setq2-function (v1 v2 e)
  (list 'progn (list 'setq v1 e) (list 'setq v2 e)))

consider the following macro when2 which behaves like the builtin when

(defmacro when2 (condition &rest body)
  `(if ,condition (progn ,@body)))
;; (when2 t (print "hey")) => "hey"
;; (when2 nil (print "hey")) => nothing

from http://www.lispworks.com/documentation/HyperSpec/Body/02_df.htm
if a comma is immediately followed by an at-sign, then the form following the at-sign is evaluated to produce a list of objects. these objects are then “spliced” into place in the template. for example, if x has the value (a b c), then
`(x ,x ,@x foo ,(cadr x) bar ,(cdr x) baz ,@(cdr x))
=> (x (a b c) a b c foo b bar (b c) baz b c)

body is just a list and can be used/modified

(defmacro test-macro (&rest body)
  `(quote ,body))

this is called an anaphoric macro where you wrap the body with a lexical function definition that shadows the global one

CL-USER> (defun foo () 1)
FOO
CL-USER> (defmacro with-different-foo (&body body)
           `(flet ((foo () 2))
              ,@body))
WITH-DIFFERENT-FOO
CL-USER> (progn
           (foo))
1
CL-USER> (with-different-foo
           (foo))
2

reader macros

the #+ and #- reader macros are pretty nice for commenting out sexps. they allow ignoring the following sexp, if the given symbol isn't/is found in *FEATURES*. Just pick a symbol not in *FEATURES*, and use it with #+ like this:

,#+nil
(defun foo ()
  ...)

Now, the function definition will be ignored (unless NIL is in *FEATURES*, which is not very likely).

use double-floats by default

(setf *read-default-float-format* 'double-float)

enforce garbage collection

running

(gc :full t)

invokes the garbage collector

checking equalities

some equality tests may return results that are implementation-specific, i dont list those here, i only wrote the ones that are supposed to work on any cl implementation
string equality:

(equal "foo" (copy-seq "foo")) ;; => T

symbol equality (any equality operator works for symbols):

(eq 'foo 'foo) ;; => T

number equality:

;; 'eql' is "type sensitive"
(eql 3 3.0) ;; => NIL
(eql 3 3) ;; => T
;; 'equal' works for floats and integers all the same
(equal 3 3.0) ;; => T
(equal 3 3) ;; => T
;; 'equalp' works for floats and integers all the same
(equalp 3 3.0) ;; => T
(equalp 3 3) ;; => T

object equality (same object in memory):

(eq 'a 'a) ;; => T
(eq "foo" (copy-seq "foo")) ;; => NIL
(eq 3 3.0) ;; => NIL

sequence equality (and general object equality which compares the internal structure):
uppercase and lowercase letters in strings are considered by equal to be distinct. in contrast, equalp ignores case distinctions in strings. equalp works for arrays but equal doesnt ("works" as in does element-wise comparison, which is the intended equality check here)

;; strings
(equal "Foo" (copy-seq "Foo")) ;; => T
(equal "Foo" (copy-seq "foo")) ;; => NIL
(equalp "Foo" (copy-seq "foo")) ;; => NIL

;; vectors/arrays
(equal #(1 2 3) (copy-seq #(1 2 3))) ;; => NIL
(equalp #(1 2 3) (copy-seq #(1 2 3))) ;; => T

;; lists
(equal '(1 2 3) (copy-seq '(1 2 3))) ;; => T
(equalp '(1 2 3) (copy-seq '(1 2 3))) ;; => T

alist

we can append new pairs to an alist using push (there are many other ways):

(let ((my-alist '((a . b))))
  (push (cons 'x 'y) my-alist)
  (push '(10 . 20) my-alist))

multiple value returns

(defun polar (x y)
  (values (sqrt (+ (* x x) (* y y))) (atan y x)))

(multiple-value-bind (r theta) (polar 3.0 4.0)
  (vector r theta))

files

https://lispcookbook.github.io/cl-cookbook/files.html

basename

(pathname-name "test1/test.org") ;; test

file extension

(pathname-type "test1/test.org") ;; org

parent directory

(pathname-directory "test1/test.org") ;; (:RELATIVE "test1")
(car (last (pathname-directory "test1/test.org"))) ;; "test1"
(uiop:pathname-parent-directory-pathname "./test1/test.org") ;; #P"./"

check if file exists

(probe-file "/etc/passwd") ;; #P"/etc/passwd"
(probe-file "foo") ;; NIL
(uiop:probe-file* (uiop:parse-unix-namestring "/home/mahmooz/data/got/[Algorithms and Combinatorics №27] Stasys Jukna (auth.) - Boolean Function Complexity_ Advances and Frontiers (2012, Springer) [10.1007_978-3-642-24508-4] - libgen.li-0.png")) ;; handles [ ] properly while probe-file errors out

expanding tilde

(uiop:native-namestring "~/.emacs.d/") ;; "/home/mahmooz/.emacs.d/"

read file

(uiop:read-file-string "file.txt")
(uiop:read-file-lines "file.txt")
(uiop:read-file-string (uiop:parse-unix-namestring "path")) ;; handles [ ] (and probably other pathological patterns in filenames) properly

write to file

(alexandria:write-string-into-file content "file.txt")
(str:to-file "file.txt" content)
(with-open-file (f "/home/pedro/miscellaneous/misc/tests-output/stack-overflow.lisp"
                   :direction :output
                   :if-exists :overwrite
                   :if-does-not-exist :create)
(write-sequence "hello" f)
(pprint (list example-1 example-2) str))

join paths

(merge-pathnames "otherpath" "/home/mahmooz/") ;; #P"/home/mahmooz/otherpath"
(namestring (merge-pathnames "otherpath" "/home/mahmooz/")) ;; "/home/mahmooz/otherpath"

path to string

(namestring #P"test/test.org") ;; "test/test.org"

get current directory

(uiop/os:getcwd) ;; #P"/home/mahmooz/work/emacs.d/"

change working directory

(uiop:chdir "/bin/")
(let ((dir "/path/to/another/directory/")) ;; only set cwd lexically
  (uiop:with-current-directory (dir)
    (directory-files "./")))

list directory

(uiop:directory-files "./")
(uiop:subdirectories "./")
(directory #P"*.jpg")

walk directory

walking a directory recursively is possible with cl-fad:

(let (files)
  (cl-fad:walk-directory "/tmp/" (lambda (x) (push (namestring x) files)))
  (car files))

MOP

MOP refers to "The Common Lisp Object System MetaObject Protocol".
in the following example, we use an sbcl-specific mop package named sb-mop, other common lisp implementations may have similar functionality in a differently named package.

;; base class with "static" property `rule' that is shared by all instances
(defclass other-text-object (text-object)
  ((rule
    :accessor other-text-object-rule
    :allocation :class
    :documentation "the matching method from `*matching-methods*' used to match against the text object.")))

;; define the `inline-math' subclass with its own default value for `rule'
(defclass inline-math (other-text-object)
  ((rule
    :allocation :class
    :initform (list '(:name inline-math
                      :method pair
                      :data ("\\(" :string "\\)" :string)
                      :nestable nil)))))

;; we need to "finalize" the class to be able to use MOP
(sb-mop:finalize-inheritance (find-class 'inline-math))
;; then we can grab the rule from the class itself:
(slot-value (sb-mop:class-prototype (find-class 'inline-math)) 'rule)

to make it implementation-agnostic (see https://sourceforge.net/p/sbcl/mailman/sbcl-help/thread/sqn024gyx9.fsf@cam.ac.uk/) we can do:

,#+sbcl (:import-from "SB-MOP" "SLOT-VALUE-USING-CLASS")
,#+cmu  (:import-from "MOP" "SLOT-VALUE-USING-CLASS")

common sequence operations

mapping sequence

(mapcar '1+ (loop for i from 0 to 10 collect i))

filtering sequence

(format t "~A" (remove-if-not 'identity (list nil 1 2 3 nil)))
(terpri)
(format t "~A" (remove-if 'identity (list nil 1 2 3 nil)))

finding in a sequence

(find-if 'symbolp (list 1 2 3 'test))

reducing a sequence

(reduce '+ (list 5 6 10))

concatenating sequences

(format t "~A" (concatenate 'string "test1" "test2"))
(terpri)
(format t "~A" (concatenate 'list (list 1 2 3) (list 4 5)))

zipping two sequences

(pairlis '(a b c) '(1 2 3))

regex

using cl-ppcre. docs at https://edicl.github.io/cl-ppcre/.

regex simple matching

this returns the indicies bounding the matching string.

(format t "1. ~A~%" (cl-ppcre:scan "[a-z]{8}" "this worddddd is matched"))
(format t "2. ~A~%" (cl-ppcre:all-matches "[a-z]{8}" "this worddddd is matched"))
(format t "3. ~A~%" (cl-ppcre:all-matches "[a-z]{5}" "more than one match"))
(format t "4. ~A~%" (cl-ppcre:all-matches "[a-z]{5}" "more than one match match match"))

regex group matching

(cl-ppcre:register-groups-bind (kw val)
    ("\\+([a-z]+): (.*)" "#+mykeyword: myvalue")
  (cons kw val))

embedded modifiers

different embedded modifiers are supported, like (?i) to enable case-insensitive matching.

(cl-ppcre:all-matches "(?i)word" "this is an uppercase WORD that is matched")

communicating with subprocesses

https://stackoverflow.com/questions/15988870/how-to-interact-with-a-process-input-output-in-sbcl-common-lisp

(defun program-stream (program &optional args)
  (let ((process (sb-ext:run-program program args
                                     :input :stream
                                     :output :stream
                                     :wait nil
                                     :search t)))
    (when process
      (make-two-way-stream (sb-ext:process-output process)
                           (sb-ext:process-input process)))))

(defvar *stream* (program-stream "cat"))
(format *stream* "foo bar baz~%")
(finish-output *stream*)
(read-line *stream*)
(close *stream*)

;; CL-USER> (defparameter *stream* (program-stream "python" '("-i")))
;; *STREAM*
;; CL-USER> (loop while (read-char-no-hang *stream*)) ; skip startup message
;; NIL
;; CL-USER> (format *stream* "1+2~%")
;; NIL
;; CL-USER> (finish-output *stream*)
;; NIL
;; CL-USER> (read-line *stream*)
;; "3"
;; NIL
;; CL-USER> (close *stream*)
;; T

;; CL-USER> (defparameter *stream* (program-stream "unbuffer"
;;                                                 '("-p" "tr" "a-z" "A-Z")))
;; *STREAM*
;; CL-USER> (format *stream* "foo bar baz~%")
;; NIL
;; CL-USER> (finish-output *stream*)
;; NIL
;; CL-USER> (read-line *stream*)
;; "FOO BAR BAZ
;; "
;; NIL
;; CL-USER> (close *stream*)
T

get definition/source of function

(defun test ()
  (+ (- 1 2) 3))

(function-lambda-expression #'test)

check if symbol refers to a function (if function is bound)

CLTPT> (fboundp 'identity)
#<FUNCTION IDENTITY>
CLTPT> (fboundp 'identity2)
NIL

when-let

(defmacro when-let (bindings &body body)
  "bind multiple VARS to their FORMS like `let`. if all are non-nil,
execute BODY with those bindings in effect, otherwise return NIL."
  (let ((bnds (if (and (consp bindings)
                       (consp (first bindings))
                       (symbolp (caar bindings)))
                  bindings
                  (list bindings))))
    `(let ,bnds
       (when (and ,@(mapcar #'car bnds))
         ,@body))))

(defmacro when-let* (bindings &body body)
  "like LET*, but if every FORM in BINDINGS evaluates non-nil,
execute BODY, otherwise return NIL immediately."
  (if (null bindings)
      `(progn ,@body)
      (destructuring-bind ((var form) . rest) bindings
        `(let ((,var ,form))
           (when ,var
             (when-let* ,rest ,@body))))))

some code for trees i guess

(defun make-node (interval)
  (cons interval nil))

(defun intervals-conflict-p (c-start c-end p-start p-end)
  "checks if two intervals (c-start, c-end) and (p-start, p-end)
overlap AND neither contains the other."
  (let ((overlap (< (max c-start p-start) (min c-end p-end))))
    (when overlap
      (let ((c-contains-p (and (<= c-start p-start) (>= c-end p-end)))
            (p-contains-c (and (<= p-start c-start) (>= p-end c-end))))
        (not (or c-contains-p p-contains-c))))))

(defun build-forest (intervals)
  "build a nested tree from a list of intervals, discarding entries
that overlap with a sibling or a root without being contained by it (or containing it).
each interval is a list of the form (start end id)."
  (let ((forest)
        (stack))
    (setf intervals (sort (copy-list intervals) #'< :key #'first))
    (dolist (current-interval-data intervals)
      (let ((node-to-add (make-node current-interval-data))
            (c-start (first current-interval-data))
            (c-end (second current-interval-data))
            (discard-current))
        (loop while (and stack
                         (let* ((parent-node-on-stack (first stack))
                                (p-interval-on-stack (car parent-node-on-stack))
                                (p-start (first p-interval-on-stack))
                                (p-end (second p-interval-on-stack)))
                           (not (and (<= p-start c-start) (>= p-end c-end)))))
              do (pop stack))
        (let ((potential-parent-node (first stack)))
          (if potential-parent-node
              (dolist (sibling-node (cdr potential-parent-node))
                (when (not discard-current)
                  (let* ((s-interval-data (car sibling-node))
                         (s-start (first s-interval-data))
                         (s-end (second s-interval-data)))
                    (when (intervals-conflict-p c-start c-end s-start s-end)
                      (setf discard-current t)))))
              (dolist (existing-root-node forest)
                (when (not discard-current)
                  (let* ((r-interval-data (car existing-root-node))
                         (r-start (first r-interval-data))
                         (r-end (second r-interval-data)))
                    (when (intervals-conflict-p c-start c-end r-start r-end)
                      (setf discard-current t)))))))
        (unless discard-current
          (if (first stack)
              (progn
                (push node-to-add (cdr (first stack)))
                (push node-to-add stack))
              (progn
                (push node-to-add forest)
                (push node-to-add stack))))))
    (nreverse forest)))

(defun print-node (node &optional (indent 0))
  "recursively prints a node and its children with indentation."
  (format t "~v@T~a~%" indent (car node)) ;; print the node's interval with indentation.
  (dolist (child (cdr node))
    (print-node child (+ indent 2)))) ;; increase indent for children.

(defun print-forest (forest)
  "prints all trees in the forest."
  (dolist (node forest)
    (print-node node 0)))

(defun mapcar-tree (node func)
  (cons (funcall func (car node))
        (mapcar (lambda (child)
                  (mapcar-tree child func))
                (cdr node))))

(defun mapcar-forest (forest func)
  "apply `mapcar-tree' to every node in the forest."
  (mapcar (lambda (node)
            (mapcar-tree node func))
          forest))

(defun map-tree (node func)
  (let ((result (mapcar (lambda (child)
                          (map-tree child func))
                        (cdr node))))
    (cons (funcall func node)
          result)))

(defun map-forest (forest func)
  "apply map-tree to every node in the forest."
  (mapcar (lambda (node)
            (map-tree node func))
          forest))

(defun tree-mapcar (node func &optional cond)
  "we iterate through the tree one NODE at a time and run FUNC on each, COND
decides whether to recurse on a specific node. a tree is returned with nodes
replaced by the results of calling FUNC on them. children are handled first."
  (if cond
      (if (and (consp node) (funcall cond node))
          (cons (funcall func (car node))
                (loop for child in (cdr node)
                      collect (tree-mapcar child func cond)))
          (cons (funcall func (car node))
                (cdr node)))
      (if (consp node)
          (cons (funcall func (car node))
                (loop for child in (cdr node)
                      collect (tree-mapcar child func cond)))
          node)))

(defun tree-find (node item &key (test #'equal) (key #'identity))
  (tree-mapcar
   node
   (lambda (other-node)
     (when (funcall test item (funcall key other-node))
       (return-from tree-find other-node))))
  nil)