notes

Chapter 2
============================================================================
☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆
============================================================================
230521 日
§2.3
13 页 apply vs. funcall
- First arg is "function designator": symbol or function object

Graham shows these as having "the same effect":
(+ 1 2)
(apply #'+ '(1 2))
(apply (symbol-function '+) '(1 2))
(apply #'(lambda (x y) (+ x y)) '(1 2))

However, they are not equivalent. Consider a different context:
[Can't rebind `+`: http://www.lispworks.com/documentation/lw50/CLHS/Body/11_abab.htm]
(defun add (&rest args)
  (apply #'+ args))

(flet ((add (&rest args)
         (apply #'* args)))
  (add 1 2))

(flet ((add (&rest args)
         (apply #'* args)))
  (apply #'add '(1 2)))

(flet ((add (&rest args)
         (apply #'* args)))
  (apply (symbol-function 'add) '(1 2)))

(apply '+ '(1 2))

(flet ((add (&rest args)
         (apply #'* args)))
  (apply 'add '(1 2)))

Also
(apply #'+ '(1 2 3))
(apply #'(lambda (x y) (+ x y)) '(1 2 3))

Variations:
(apply #'+ 1 '(2 3))
(apply #'+ 1 2'(3))
(apply #'+ 1 2 3 '())

(let ((add #'+))
  (apply add '(1 2 3)))
----------------------------------------------------------------------------
另见 funcall
(funcall #'+ 1 2)
(funcall (symbol-function '+) 1 2)
(funcall #'(lambda (x y) (+ x y)) 1 2)

Possible definition:
(defun funcall (f &rest args)
  (apply f args))

CLHS says:
(funcall function arg1 arg2 ...)  ==  (apply function arg1 arg2 ... nil)  ==  (apply function (list arg1 arg2 ...))

(No need for FUNCALL in Scheme/Clojure)
(defun foo (x)
  (+ x 9))

(defun bar (f x)
  (funcall f x))

(bar #'foo 8) => 17

vs.

(defn foo [x]
  (+ x 9))

(defn bar [f x]
  (f x))

(bar foo 8) => 17
----------------------------------------------------------------------------
Side note:
(cons 'a '(b c)) => (A B C)
(list 'a 'b 'c) => (A B C)
(list* 'a 'b 'c '()) => (A B C)

CLHS:
list* is like list except that the last argument to list becomes the car of the last cons constructed, while the last argument to list* becomes the cdr of the last cons constructed. Hence, any given call to list* always produces one fewer conses than a call to list with the same number of arguments.

If the last argument to list* is a list, the effect is to construct a new list which is similar, but which has additional elements added to the front corresponding to the preceding arguments of list*.
----------------------------------------------------------------------------
Head scratchers: (Lisp I APPLY notes 279 页)
(apply #'apply #'+ 7 9 '() '())
(apply #'apply (list #'+ 7 9 '()))
(apply #'apply (list #'+ '(7 9)))
(apply #'apply '(+ (7 9)))
(apply #'apply #'+ '((7 9)))
vs.
(apply #'apply '(#'+ (7 9)))

(sdraw '(apply #'apply '(+ (7 9))))

[*|*]--->[*|*]-------------------->[*|*]--->NIL
 |        |                         |
 v        v                         v
APPLY    [*|*]----->[*|*]--->NIL   [*|*]--->[*|*]--->NIL
          |          |              |        |
          v          v              v        v
         FUNCTION   APPLY          QUOTE    [*|*]--->[*|*]--->NIL
                                             |        |
                                             v        v
                                             +       [*|*]--->[*|*]--->NIL
                                                      |        |
                                                      v        v
                                                      7        9

(sdraw '(apply #'apply '(#'+ (7 9))) :display-width 200)

[*|*]--->[*|*]-------------------->[*|*]--->NIL
 |        |                         |
 v        v                         v
APPLY    [*|*]----->[*|*]--->NIL   [*|*]--->[*|*]--->NIL
          |          |              |        |
          v          v              v        v
         FUNCTION   APPLY          QUOTE    [*|*]-------------------->[*|*]--->NIL
                                             |                         |
                                             v                         v
                                            [*|*]----->[*|*]--->NIL   [*|*]--->[*|*]--->NIL
                                             |          |              |        |
                                             v          v              v        v
                                            FUNCTION    +              7        9

(sdraw '(#'+ (7 9)))

[*|*]-------------------->[*|*]--->NIL
 |                         |
 v                         v
[*|*]----->[*|*]--->NIL   [*|*]--->[*|*]--->NIL
 |          |              |        |
 v          v              v        v
FUNCTION    +              7        9

(sdraw (list #'+ '(7 9)))

[*|*]---------->[*|*]--->NIL
 |               |
 v               v
#<FUNCTION +>   [*|*]--->[*|*]--->NIL
                 |        |
                 v        v
                 7        9
----------------------------------------------------------------------------
240414 日
(defun remove-if (f l)
  (cond ((endp l) '())
        ((funcall f (first l)) (remove-if f (rest l)))
        (t (cons (first l) (remove-if f (rest l)))) ))

(defun remove-if (f l)
  (if (endp l)
      '()
      (destructuring-bind (first . rest) l
        (if (funcall f first)
            (remove-if f rest)
            (cons first (remove-if f rest)))) ))

(clojure.repl/source remove)
(defn remove
  "Returns a lazy sequence of the items in coll for which
  (pred item) returns logical false. pred must be free of side-effects.
  Returns a transducer when no collection is provided."
  {:added "1.0"
   :static true}
  ([pred] (filter (complement pred)))
  ([pred coll]
     (filter (complement pred) coll)))
============================================================================
230613 火
§2.5
Scope
;;;
;;;    Default lexical
;;;
(let ((y 7))
  (defun g (x)
    (list x y)))

(let ((y 5))
  (g 3))

; caught STYLE-WARNING:
;   The variable Y is defined but never used.



;;;
;;;    Special when declared
;;;
(let ((y 7))     ; This binding is irrelevant
  (declare (special y))
  (defun f (x)
    (declare (special y))
    (list x y)))

(let ((y 5))
  (declare (special y))
  (f 3))


;;;
;;;    More typical case
;;;
(defun f* (x)
  (declare (special y))
  (list x y))

(let ((y 9))
  (declare (special y))
  (f* 8)) ; Y indirectly "passed" to F*


;;;
;;;    Persistent DECLAIM
;;;
(defvar *y* 8)

(let ((*y* 7))
  (defun h (x)
    (list x *y*)))

(let ((*y* 5))
  (h 3))

(macroexpand-1 '(defvar *y* 8))
(PROGN (DECLAIM (SPECIAL *Y*)) (OR (BOUNDP '*Y*) (SETQ *Y* 8))
       (RECORD-SOURCE-FILE '*Y* :TYPE :VARIABLE) '*Y*)
T


;;;
;;;    Error
;;;
(defun p (x) (list x y))
; caught WARNING:
;   undefined variable: COMMON-LISP-USER::Y
; 

(let ((y 9)) (declare (special y)) (p 8))

(let ((y 9)) (p 8))


----------------------------------------------------------------------------
Notes pg. 624
(defun f (x)
  (labels ((g ()
             (- x 2))
           (h (x)
             (/ x (g))))
    (+ (g) (h (* 4 x)))) )

(f 8) => 34/3
(f 1) => -5

(+ (g) (h (* 4 x)))
(+ (- x 2) (h (* 4 x)))
(+ (- x 2) (/ (* 4 x) (g)))
(+ (- x 2) (/ (* 4 x) (- x 2)))
          4x
x - 2 + ------
        x - 2

(defun f* (x)
  (declare (special x))
  (labels ((g* ()
             (declare (special x))
             (- x 2))
           (h* (x)
             (declare (special x))
             (/ x (g*))))
    (+ (g*) (h* (* 4 x)))) )

(f* 8) => 106/15
(f* 1) => 1

(+ (g*) (h* (* 4 x)))
(+ (- x 2) (h* (* 4 x)))
(+ (- x 2) (/ x' (g*)))
(+ (- x 2) (/ x' (- x' 2)))
          x'
x - 2 + ------
        x' - 2

x' = 4x

          4x
x - 2 + ------
        4x - 2
----------------------------------------------------------------------------
(defun make-counter (x)
  #'(lambda ()
      (incf x)))

(defun make-counter* (x)
  (declare (special x))
  #'(lambda ()
      (incf x)))

(defvar *c1* (make-counter 8))
(defvar *c2* (make-counter 2))
(defvar *c3* (make-counter* 8))
(defvar *c4* (make-counter* 2))

(funcall *c1*) => 9
(funcall *c1*) => 10
(funcall *c1*) => 11
(funcall *c2*) => 3
(funcall *c2*) => 4
(funcall *c1*) => 12

(funcall *c3*)

*** - SETQ: variable X has no value
The following restarts are available:
USE-VALUE      :R1      Input a value to be used instead of X.
STORE-VALUE    :R2      Input a new value for X.
ABORT          :R3      Abort main loop

(let ((x 8)) (declare (special x)) (print (funcall *c3*)) (print (funcall *c3*)) (print (funcall *c3*)))

9 
10 
11 
11
(let ((x 2)) (declare (special x)) (print (funcall *c3*)) (print (funcall *c3*)) (print (funcall *c3*)))

3 
4 
5 
5
(let ((x 2)) (declare (special x)) (print (funcall *c3*)) (print (funcall *c4*)) (print (funcall *c3*)) (print (funcall *c4*)))

3 
4 
5 
6 
6
----------------------------------------------------------------------------
Only one special variable ever exists at a given moment.
(defun foo (x)
  #'(lambda () (print x)))

(defun bar (x)
  (declare (special x))
  #'(lambda () (print x)))

(defvar *lexical* (list (foo 2) (foo 3) (foo 4)))
(defvar *special* (list (bar 2) (bar 3) (bar 4)))

(dolist (lexical *lexical*) (funcall lexical))
(let ((x 999))
  (declare (special x))
  (dolist (special *special*)
    (funcall special)))


(let ((x 999)
      (y 4)
      (z 88))
  (declare (special x))
  (dolist (special *special*)
    (funcall special)))
----------------------------------------------------------------------------
240418 木
https://www.lispworks.com/documentation/lw50/CLHS/Body/03_abaad.htm
3.1.2.1.1.4 Symbols Naming Both Lexical and Dynamic Variables

The same symbol can name both a lexical variable and a dynamic variable, but never in the same lexical environment.     ??!?!?

CLHS:
(let ((x 1))            ;Binds a special variable X
  (declare (special x))
  (let ((x 2))          ;Binds a lexical variable X
    (+ x                ;Reads a lexical variable X
       (locally (declare (special x))
                x))))  
Me:
(defun baz ()
  (let ((x 2))
    (list x (symbol-value 'x)))) ; Can't call (BAZ) directly...
(defun foo ()
  (let ((x 1))
    (declare (special x))
    (baz)))

(defun baz* ()
  (let ((x 2))
    (list x (boundp 'x))))
(defun foo* ()
  (let ((x 1))
    (declare (special x))
    (baz*)))

(baz*) => (2 NIL)
(foo*) => (2 T)
----------------------------------------------------------------------------
240418 木
Fully encapsulated state
(defclass encapsulated-person ()
  ((state :initarg :state :reader state)))

(defmacro make-state (&rest slots)
;  (let ((getters (mapcar #'(lambda (slot) (make-symbol (format nil "GET-~A" slot))) slots))
;        (setters (mapcar #'(lambda (slot) (make-symbol (format nil "SET-~A" slot))) slots)))
  `(let (,@(mapcar #'list slots) (g (make-hash-table))) (loop for slot in ',slots
                                                              do (setf (gethash slot g)
                                                                 `#'(lambda () ,slot)))
                                                                 g))

(make-instance 'encapsulated-person :state (make-state first-name last-name))
----------------------------------------------------------------------------
240415 月
(defpackage :foo
  (:use :common-lisp)
  (:export :foo :x)) ; <-- Creates FOO:X

(defun bar (x)
  (let ((foo:x 0))
    #'(lambda ()
        (incf x)
        (rotatef x foo:x)
        (list x foo:x))))

No way Jose:
(defun bar (x)
  (let ((x 0))
    #'(lambda ()
        (incf x)
        (rotatef x x)
        (list x x))))

(defvar *b1* (bar 9))
*B1*
* (defvar *b2* (bar 7))
*B2*
* (funcall *b1*)
(0 10)
* (funcall *b1*)
(10 1)
* (funcall *b1*)
(1 11)
* (funcall *b1*)
(11 2)
* (funcall *b2*)
(0 8)
* (funcall *b2*)
(8 1)
* (funcall *b2*)
(1 9)
* (funcall *b2*)
(9 2)
----------------------------------------------------------------------------
240501 水
S-expression vs. Form
* (sdraw (read))
(+ 1 2)

[*|*]--->[*|*]--->[*|*]--->NIL
 |        |        |
 v        v        v
 +        1        2

(+ 1 2)
(+ 1 . (2))
(cl:+ 1 2)
(common-lisp::+ 1 2)
(+ 1. 2.)
(+ 4/4 6/3)
(+ #.(/ 3 3) #.(/ 8 4))
(+ . (1 . (2 . nil)))

1
2
(+ #.** #.*)



`,(+ 1 2)  ; ??? Clozure not SBCL
----------------------------------------------------------------------------
240417 水
Evaluation

The CLHS view
3.1.2.1 Form Evaluation https://www.lispworks.com/documentation/lw50/CLHS/Body/03_aba.htm
Forms fall into three categories: symbols, conses, and self-evaluating objects.

                                    Form
                                  /   |  \
                                 /    |   \
                                /     |    \
                            Symbol    |    Cons
                                      |
                             Self-evaluating object

3.1.2.1.3 Self-Evaluating Objects
A form that is neither a symbol nor a cons is defined to be a self-evaluating object. Evaluating such an object yields the same object as a result.
Not CONS => ATOM
Not Symbol => non-symbolic atoms

                                    Form
                                  /      \
                                 /        \
                                /          \
                            Atom            Cons
                          /      \            |
                     Symbol     Other         |-Lambda Form
                    /      \ (Self-evaluating)|
                   /        \                 |-Function Form
                Symbol   Variable             |
                 Macro      |                 |-Special Form
                            |-Constant        |
                            |                 |-Macro Form
                            |-Lexical          
                            |
                            |-Dynamic (Special)


Conses: First element (CAR) is operator.
        Either:
        - Symbol (names function/macro/special operator)
        - Lambda expression
        
Function forms
(+ 2 3)
[*|*]--->[*|*]--->[*|*]--->NIL
 |        |        |
 v        v        v
 +        2        3

(* (+ 3 4) (- 9 1))

(* (+ 12 2) (/ 7 (- 8 3)))

Macro forms
(when (evenp 9) (cond :huh?))
-> (if (evenp 9) (cond :huh?) nil)

Special forms
(let ((x 8)) ...)

Lambda forms
((lambda (x) (* x 4)) 9)

Certain specific symbols and conses might also happen to be ``self-evaluating''
but only as a special case of a more general set of rules for the evaluation of
symbols and conses; such objects are not considered to be self-evaluating objects.

(eq #1=(quote #1#) #1#) => T          ; SDRAW!!!
(eq :zed :zed) => T
(eq t t) => T
(eq t (eq nil nil)) => T

~/lisp/sbcl/sbcl-1.5.9/src/code/symbol.lisp
(setf (symbol-value t) 99)

debugger invoked on a SIMPLE-ERROR in thread
#<THREAD "main thread" RUNNING {10018301C3}>:
  Veritas aeterna. (can't set SYMBOL-VALUE of T)

(setf (symbol-value nil) 99)

debugger invoked on a SIMPLE-ERROR in thread
#<THREAD "main thread" RUNNING {10018301C3}>:
  Nihil ex nihil. (can't set SYMBOL-VALUE of NIL)
-------------------------------------------------
240708 月
~/lisp/books/Touretzky/2019/unary.lisp

(defconstant tally 'x)

(deftype tally ()            ; <------
  `(member ,tally))

;; (deftype unary ()            ; <------ Infinite expansion!!!
;;   `(or null (cons tally unary)))

(defun unaryp (n)
  (every #'(lambda (elt) (typep elt 'tally)) n))

(deftype unary ()
  '(satisfies unaryp))

(defun unary (n)
  (loop repeat n collect tally))
----------------------------------------------------------------------------
240420 土
What does a symbol mean?

What does (+ 2 x) evaluate to? Obviously, that depends on what X means. What does
it refer to?

Suppose we have:
(let ((x "pung"))
  (+ 2 x))

That looks odd since we assume that + refers to the addition operator (COMMON-LISP:+). But
the meaning of that symbol can change too:
(shadow '+)
(flet ((+ (i s)
         (char s i)))
  (let ((x "pung"))
    (+ 2 x)))

Even more radically, 2 can become a symbol and consequently name something distinct from
its value:
(shadow '+)
(setf (symbol-function '+) #'*)
(setf *read-base* 2)
(let ((2 111)
      (3 101))
  (let ((x 2))
    (+ x 3)))
============================================================================
240425 木
§2.6
Closures

(defun list+ (l n)
  (mapcar #'(lambda (elt) (+ elt n)) l)) ; Creates closure on each invocation
                                         ; N is free variable captured from parameter

(list+ '(1 2 3 4 5) 7) => (8 9 10 11 12)

(let ((counter 0))
  (defun new-id () (incf counter))        ; Creates 2 closures once
  (defun reset-id () (setf counter 0)))   ; <-- Controlled access to modify state

* (new-id)
1
* (new-id)
2
* (reset-id)
0
* (new-id)
1

(defun make-adder (n)
  #'(lambda (x) (+ x n)))

(defvar *add2* (make-adder 2))
(defvar *add10* (make-adder 10))
(funcall *add2* 8) => 10
(funcall *add2* 9) => 11
(funcall *add10* 8) => 18
(funcall *add10* 9) => 19

(setf (symbol-function 'add20) (make-adder 20))
(add20 8) => 28
(add20 9) => 29

;;;
;;;    Redefine LIST+
;;;
(defun list+ (l n)
  (mapcar (make-adder n) l))

(list+ '(1 2 3 4 5) 7) => (8 9 10 11 12)

;;;
;;;    Closure with semi-exposed state
;;;
(defun make-adder* (n)
  #'(lambda (x &optional tweak)
       (if tweak
           (setf n x)
           (+ x n))))

(defvar *f1* (make-adder* 1))
(funcall *f1* 2) => 3
(funcall *f1* 10) => 11
(funcall *f1* 3 t) => 3  ; Optional 2nd arg
(funcall *f1* 2) => 5
(funcall *f1* 10) => 13
============================================================================
230622 木
§2.7
(defun count-instances (obj lists)
  (labels ((instances-in (list)
             (if (consp list)
                 (+ (if (eq (first list) obj) 1 0)
                    (instances-in (rest list)))
                 0)))
    (mapcar #'instances-in lists)))

(count-instances 'a '((a b c) (d a r p a) (a a)))
(1 2 2)
(count-instances 'a '((a b c) (d a r p a) (a (a) a)))
(1 2 2)
(count-instances 'a '((a b c) (d a r p a) (a a) a))
(1 2 2 0)

- Does not count top-level elements
- Does not count nested elements within each top-level list

Poor example to highlight LABELS??
(defun count-instances (obj lists)
  (mapcar #'(lambda (list) (count obj list)) lists))

Not identical...
(count-instances 'a '((a b c) (d a r p a) (a a)))
(1 2 2)
(count-instances 'a '((a b c) (d a r p a) (a (a) a)))
(1 2 2)
(count-instances 'a '((a b c) (d a r p a) (a a) a))
> Error: The value A is not of the expected type SEQUENCE.
> While executing: CCL::SEQUENCE-TYPE, in process listener(1).
> Type :POP to abort, :R for a list of available restarts.
> Type :? for other options.

(defun tree-count-instances (obj tree)
  (cond ((eq tree obj) 1)
        ((atom tree) 0)
        (t (+ (tree-count-instances obj (first tree))
              (tree-count-instances obj (rest tree)))) ))

(tree-count-instances 'a '((a b c) (d a r p a) (a a)))
5
(tree-count-instances 'a '((a b c) (d a r p a) (a (a) a)))
6
(tree-count-instances 'a '((a b c) (d a r p a) (a a) a))
6


见 Slade ch. 4 exercises
(defun count-occurrences (obj tree)
  (cond ((null tree) 0)
        ((atom tree) (if (eq obj tree) 1 0))
        (t (+ (count-occurrences obj (car tree))
              (count-occurrences obj (cdr tree)))) ))

(deftest test-count-occurrences ()
  (check
   (= (count-occurrences 'a '(a ((a b)) d c (a))) 3)
   (= (count-occurrences 'z '(a ((a b)) d c (a))) 0)))

Notes pg. 293
((lambda (obj lists) (labels ((instances-in (list) (if (consp list) (+ (if (eq (first list) obj) 1 0) (instances-in (rest list))) 0)))
  (mapcar #'instances-in lists))) 'a '((a b c) (d a r p a) (d a r) (a a)))

=> (1 2 1 2)


(defun f (x) #'(lambda () ...  x ...))
(defun g () #'(lambda (x) ...  x ...))

eq?
----------------------------------------------------------------------------
240426 金
On Lisp notes 387-388 页
Anonymous recursive function
(defun recurser (f)
  #'(lambda (&rest args)
      (apply f f args)))

(let ((fact #'(lambda (f n)
                (if (zerop n)
                    1
                    (* n (funcall f f (1- n)))) )))
  (funcall (recurser fact) 8))

Direct definition:
((lambda (f) #'(lambda (n) (funcall f f n)))
  #'(lambda (f n)
      (if (zerop n)
          1
          (* n (funcall f f (1- n)))) ))

(funcall * 8) => 40320

Y Combinator!!!
(funcall ((lambda (m)
            ((lambda (future)
               (funcall m #'(lambda (arg)
                              (funcall (funcall future future) arg))))
             #'(lambda (future)
                 (funcall m #'(lambda (arg)
                                (funcall (funcall future future) arg)))) ))
          #'(lambda (recur) #'(lambda (n) (if (zerop n) 1 (* n (funcall recur (1- n)))) )))
          8)

193 页
(defmacro alambda (parms &body body)
  `(labels ((self ,parms ,@body))
     #'self))

(funcall (alambda (n) (if (zerop n) 1 (* n (self (1- n))))) 8) => 40320

Clojure named "anonymous" function:
((fn [x] (+ x 2)) 8) => 10
vs.
((lambda (x) (+ x 2)) 8) => 10

((fn factorial [n] (if (zero? n) 1 (* n (factorial (dec n))))) 8) => 40320

XXXXXX No can do XXXXXX
((alambda (n) (if (zerop n) 1 (* n (self (1- n))))) 8) => 40320



(defun count-instances (obj lists)
  (labels ((instances-in (list)
             (if (consp list)
                 (+ (if (eql (first list) obj) 1 0) ; Closure over OBJ
                    (instances-in (rest list)))     ; Recursive
                 0)))
    (mapcar #'instances-in lists)))

(defun count-instances-reduce (obj lists)
  (mapcar #'(lambda (list)
              (reduce #'+ (mapcar #'(lambda (elt) (if (eql elt obj) 1 0)) list)))
          lists))

(defun count-instances* (obj lists)
  (mapcar #'(lambda (list) (count obj list)) lists))

Using core.lisp:
(defun count-instances** (obj lists)
  (mapcar (partial #'count obj) lists))
============================================================================
230704 火
§2.8 Tail Recursion (TCO)

(defun our-length (lst)
  (if (null lst)
      0
      (1+ (our-length (cdr lst)))))

(disassemble #'our-length)

I. LABELS
(defun our-length (lst)        ;   <-- Not recursive!
  (labels ((rec (lst acc)
             (if (null lst)
                 acc
                 (rec (cdr lst) (1+ acc)))))
    (rec lst 0)))

II. Optional accumulator
(defun our-length (lst &optional (acc 0))
  (if (null lst)
      acc
      (our-length (cdr lst) (1+ acc))))

III. Separate helper function
(defun our-length (lst)
  (our-length-aux lst 0))

(defun our-length-aux (lst acc)
  (if (null lst)
      0
      (1+ (our-length-aux (cdr lst) (1+ acc)))))

- Optimize
http://www.lispworks.com/documentation/lw50/CLHS/Body/d_optimi.htm#optimize

- How to tell TCO?
  - Stack overflow
    (our-length (loop for i upto 10000 collect i)) => 10001
    (our-length (loop for i upto 100000 collect i)) => SB-KERNEL::CONTROL-STACK-EXHAUSTED
  - Disassemble
    CALL -> JMP
----------------------------------------------------------------------------
FIND-IF sequence function.
- Inherently tail recursive

Oops!
(defun our-find-if (fn lst)
  (if (funcall fn (car lst))
      (car lst)
      (our-find-if fn (cdr lst)))) ; Infinite recursion if not present!!!

(defun our-find-if (fn lst)
  (cond ((endp lst) nil)
        ((funcall fn (car lst)) (car lst))
        (t (our-find-if fn (cdr lst)))) )

(defun find-if (f list)
  (if (endp list)
      nil
      (destructuring-bind (elt . more) list
        (if (funcall f elt)
            elt
            (find-if f more)))) )
----------------------------------------------------------------------------
(defun triangle (n)
  (labels ((tri (c n)
             (declare (type fixnum n c))
             (if (zerop n)
                 c
                 (tri (the fixnum (+ n c))
                      (the fixnum (- n 1))))))
    (tri 0 n)))

1. Weird names
2. Weird order of params
3. 0..n
4. Weird algorithm
5. Weird limitation

(triangle 10000000000)
50000000005000000000
most-positive-fixnum
4611686018427387903

(log 10000000000 10)
10.0

(loop for i from 1 upto 20 collect i)
(loop for i from 20 downto 1 collect i)

(1   2  3  4  5  6  7  8  9 10 11 12 13 14 15 16 17 18 19 20) 
(20 19 18 17 16 15 14 13 12 11 10  9  8  7  6  5  4  3  2  1) 
 21 21                                                    21

(defun sum (n)
  (* n (1+ n) 1/2))

(loop for i upto n summing i)

(time (loop for i upto 1000 summing i))
; cpu time (total)  0.000003 sec user, 0.000000 sec system
(time (loop for i upto 10000 summing i))
; cpu time (total)  0.000010 sec user, 0.000000 sec system
(time (loop for i upto 100000 summing i))
; cpu time (total)  0.000085 sec user, 0.000000 sec system
(time (loop for i upto 1000000 summing i))
; cpu time (total)  0.000944 sec user, 0.000000 sec system
(time (loop for i upto 10000000 summing i))
; cpu time (total)  0.009907 sec user, 0.000000 sec system

(time (sum 1000))
; cpu time (total)  0.000010 sec user, 0.000000 sec system
(time (sum 10000))
; cpu time (total)  0.000034 sec user, 0.000000 sec system
(time (sum 100000))
; cpu time (total)  0.000014 sec user, 0.000000 sec system
(time (sum 1000000))
; cpu time (total)  0.000020 sec user, 0.000000 sec system
(time (sum 10000000))
; cpu time (total)  0.000010 sec user, 0.000000 sec system
(time (sum 100000000))
; cpu time (total)  0.000010 sec user, 0.000000 sec system
(time (sum 1000000000))
; cpu time (total)  0.000009 sec user, 0.000000 sec system
----------------------------------------------------------------------------
241002 水
Winston tail recursion examples
(Lisp 3rd Edition https://www.amazon.com/Patrick-Winston-Lisp-3rd-third/dp/B008WDDO5K/)

Reduction - In the context of tail recursion, a single derived problem whose solution
            provides the answer to a given problem directly, without further computation.
            The derived problem is typically simpler than the original problem.

"Whenever a problem is converted into a new problem such that no further computation is 
necessary once the new problem is solved, the new problem is said to be a _reduction_ of
the original problem. Whenever a recursive procedure is defined such that all recursive calls
to itself are reductions, that procedure is said to be _tail recursive_."

(defun fact (n)
  (if (zerop n)
      1
      (* n (fact (1- n)))) )

* (fact 6)
  0: (CORE::FACT 6)
    1: (CORE::FACT 5)
      2: (CORE::FACT 4)
        3: (CORE::FACT 3)
          4: (CORE::FACT 2)
            5: (CORE::FACT 1)
              6: (CORE::FACT 0)
              6: FACT returned 1
            5: FACT returned 1 <-- Not done yet (* 1 1).
          4: FACT returned 2 <-- Each step requires more computation.
        3: FACT returned 6 <-- These are not the same value.
      2: FACT returned 24 <-- Each step is a different problem.
    1: FACT returned 120
  0: FACT returned 720
720

(defun factorial (n &optional (result 1))
  (if (zerop n)
      result
      (factorial (1- n) (* n result)))) ; This states that (factorial n result) [current call] is
                                        ;   whatever is returned by (factorial (1- n) (* n result)) [recursive call]
                                        ;   They are the same value. I.e.,
                                        ;   (factorial (1- n) (* n result)) [new problem]
                                        ;   is a reduction of (factorial n result) [original problem]

* (factorial 6)
  0: (CORE::FACTORIAL 6)
    1: (CORE::FACTORIAL 5 6)
      2: (CORE::FACTORIAL 4 30)
        3: (CORE::FACTORIAL 3 120)
          4: (CORE::FACTORIAL 2 360)
            5: (CORE::FACTORIAL 1 720)
              6: (CORE::FACTORIAL 0 720)
              6: FACTORIAL returned 720 <-- Done
            5: FACTORIAL returned 720 <-- Just keep returning same result
          4: FACTORIAL returned 720
        3: FACTORIAL returned 720
      2: FACTORIAL returned 720
    1: FACTORIAL returned 720
  0: FACTORIAL returned 720
720

Convoluted example - count elements in a list (LENGTH)
(defun count-elements-mutually (l)
  (count-elements-indirectly l 0))

(defun count-elements-indirectly (l result)
  (if (endp l)
      result
      (count-elements-buffer (rest l) (1+ result))))

(defun count-elements-buffer (l result)
  (count-elements-indirectly l result))

Apparent mutual recursion, but for any 2 successive calls to COUNT-ELEMENTS-INDIRECTLY,
the second is merely a reduction of the first:
(count-elements-indirectly l result)
  (count-elements-buffer (rest l) (1+ result))
    (count-elements-indirectly l' result') [Where l' = (rest l), result' = (1+ result)]

* (count-elements-mutually '(a b c d))
  0: (CORE::COUNT-ELEMENTS-INDIRECTLY (CORE::A CORE::B CORE::C CORE::D) 0)
    1: (CORE::COUNT-ELEMENTS-BUFFER (CORE::B CORE::C CORE::D) 1)
      2: (CORE::COUNT-ELEMENTS-INDIRECTLY (CORE::B CORE::C CORE::D) 1)
        3: (CORE::COUNT-ELEMENTS-BUFFER (CORE::C CORE::D) 2)
          4: (CORE::COUNT-ELEMENTS-INDIRECTLY (CORE::C CORE::D) 2)
            5: (CORE::COUNT-ELEMENTS-BUFFER (CORE::D) 3)
              6: (CORE::COUNT-ELEMENTS-INDIRECTLY (CORE::D) 3)
                7: (CORE::COUNT-ELEMENTS-BUFFER NIL 4)
                  8: (CORE::COUNT-ELEMENTS-INDIRECTLY NIL 4)
                  8: COUNT-ELEMENTS-INDIRECTLY returned 4
                7: COUNT-ELEMENTS-BUFFER returned 4
              6: COUNT-ELEMENTS-INDIRECTLY returned 4
            5: COUNT-ELEMENTS-BUFFER returned 4
          4: COUNT-ELEMENTS-INDIRECTLY returned 4
        3: COUNT-ELEMENTS-BUFFER returned 4
      2: COUNT-ELEMENTS-INDIRECTLY returned 4
    1: COUNT-ELEMENTS-BUFFER returned 4
  0: COUNT-ELEMENTS-INDIRECTLY returned 4
4

Exercise
;;;
;;;    5-1 Tail-recursive NTHCDR (AKA, DROP)
;;;    
;; (skip-first-n 3 '(a b c d e f)) => (D E F)
;; (nthcdr 3 '(a b c d e f)) => (D E F)

(defun skip-first-n (n l)
  (cond ((endp l) '())
        ((zerop n) l)
        (t (skip-first-n (1- n) (rest l)))) )

(deftest test-skip-first-n ()
  (let ((l (loop for i from 1 to 10 collect i)))
    (check
     (loop for i upto 11
           do (assert (equal (nthcdr i l) 
                             (skip-first-n i l))
                      () 
                      "Expected: ~S Actual: ~S" (nthcdr i l) (skip-first-n i l))
           finally (return t)))) )

(defun skip-first-n* (n l)
  (assert (not (minusp n)) () "Bad value for N: ~A" n)
  (labels ((skip (n l)
             (cond ((endp l)'())
                   ((zerop n) l)
                   (t (skip (1- n) (rest l)))) ))
    (skip n l)))

(deftest test-skip-first-n* ()
  (let ((l (loop for i from 1 to 10 collect i)))
    (check
     (handler-case (skip-first-n* -1 '(a b c))
       (error (e)
         (format t "Got expected error: ~A~%" e)
         t)
       (:no-error (obj)
         (declare (ignore obj))
         (error "Did not detect bad value for N")))
     (loop for i upto 11
           do (assert (equal (nthcdr i l)
                             (skip-first-n* i l))
                      () 
                      "Expected: ~S Actual: ~S" (nthcdr i l) (skip-first-n* i l))
           finally (return t)))) )

;;;
;;;    5-2 Non tail-recursive BUTLAST (AKA, TAKE)
;;;
;; (keep-first-n 4 '(a b c d e f)) => (A B C D)
;; (butlast '(a b c d e f) 2) => (A B C D)

(defun keep-first-n (n l)
  (cond ((endp l) '())
        ((zerop n) '())
        (t (cons (first l) (keep-first-n (1- n) (rest l)))) ))

(deftest test-keep-first-n ()
  (let ((l (loop for i from 1 to 10 collect i)))
    (check
     (loop for i upto 11
           do (assert (equal (butlast l (max 0 (- 10 i)))
                             (keep-first-n i l))
                      () 
                      "Expected: ~S Actual: ~S" (butlast l (max 0 (- 10 i))) (keep-first-n i l))
           finally (return t)))) )

(defun keep-first-n* (n l)
  (assert (not (minusp n)) () "Bad value for N: ~A" n)
  (labels ((keep (n l)
             (cond ((endp l) '())
                   ((zerop n) '())
                   (t (cons (first l) (keep (1- n) (rest l)))) )))
    (keep n l)))

(deftest test-keep-first-n* ()
  (let ((l (loop for i from 1 to 10 collect i)))
    (check
     (handler-case (keep-first-n* -1 '(a b c))
       (error (e)
         (format t "Got expected error: ~A~%" e)
         t)
       (:no-error (obj)
         (declare (ignore obj))
         (error "Did not detect bad value for N")))
     (loop for i upto 11
           do (assert (equal (butlast l (max 0 (- 10 i)))
                             (keep-first-n* i l)) 
                      () 
                      "Expected: ~S Actual: ~S" (butlast l (max 0 (- 10 i))) (keep-first-n* i l))
           finally (return t)))) )

;;;
;;;    5-3 Tail-recursive
;;;
(defun keep-first-n-cleverly (n l)
  (assert (not (minusp n)) () "Bad value for N: ~A" n)
  (labels ((keep (n l result)
             (cond ((endp l) (nreverse result))
                   ((zerop n) (nreverse result))
                   (t (keep (1- n) (rest l) (cons (first l) result)))) ))
    (keep n l '())))

(deftest test-keep-first-n-cleverly ()
  (let ((l (loop for i from 1 to 10 collect i)))
    (check
     (handler-case (keep-first-n-cleverly -1 '(a b c))
       (error (e)
         (format t "Got expected error: ~A~%" e)
         t)
       (:no-error (obj)
         (declare (ignore obj))
         (error "Did not detect bad value for N")))
     (loop for i upto 11
           do (assert (equal (butlast l (max 0 (- 10 i)))
                             (keep-first-n-cleverly i l))
                      ()
                      "Expected: ~S Actual: ~S" (butlast l (max 0 (- 10 i))) (keep-first-n-cleverly i l))
           finally (return t)))) )
----------------------------------------------------------------------------
241002 水
Detecting cycles (circular list)
(shadow 'length)
(defun length (l)
  (labels ((count-elements (l result)
             (if (endp l)
                 result
                 (count-elements (rest l) (1+ result)))) )
  (count-elements l 0)))

(defvar *circular* (list 'a 'b 'c 'd))
(sdraw *circular*)

[*|*]--->[*|*]--->[*|*]--->[*|*]--->NIL
 |        |        |        |
 v        v        v        v
 A        B        C        D

(setf (rest (last *circular*)) *circular*)
(A B C D A B C D A B C D A B C D A B C D A B C D A B C D A B C D A B C D A B C
 D A B C D A B C D A B C D A B C D A B C D A B C D A B C D A B C D A B C D A B
 C D A B C D A B C D A B C D A B C D A B C D A B C D A B C D A B C D A B C D A
 B C D A B C D A B C D A B C D A B C D A B C D A B C D A B C D A B C D A B C D
 A B C D A B C D A B C D A B C D A B C D A B C D A B C D A B C D A B C D A B C
D'oh!

(sdraw *circular*)

[*|*]--->[*|*]--->[*|*]--->[*|*]--->[*|*]--->[*|*]--->[*|*]--->[*|*]--->etc.
 |        |        |        |        |        |        |        |
 v        v        v        v        v        v        v        v
 A        B        C        D        A        B        C        D

(length *circular*) => ...

(list-length *circular*) => NIL

https://www.lispworks.com/documentation/HyperSpec/Body/f_list_l.htm
Function LIST-LENGTH

(defun list-length (x)  
   (do ((n 0 (+ n 2))           ;Counter.
        (fast x (cddr fast))    ;Fast pointer: leaps by 2.
        (slow x (cdr slow)))    ;Slow pointer: leaps by 1.
       (nil)
     ;; If fast pointer hits the end, return the count.
     (when (endp fast) (return n))
     (when (endp (cdr fast)) (return (+ n 1)))
     ;; If fast pointer eventually equals slow pointer,
     ;;  then we must be stuck in a circular list.
     ;; (A deeper property is the converse: if we are
     ;;  stuck in a circular list, then eventually the
     ;;  fast pointer will equal the slow pointer.
     ;;  That fact justifies this implementation.)
     (when (and (eq fast slow) (> n 0)) (return nil))))
============================================================================
230708 土
§2.9
Compilation

Compile all functions
http://www.lispworks.com/documentation/lw50/CLHS/Body/m_do_sym.htm
(defun compall ()
  (do-symbols (s)
    (when (fboundp s)
      (unless (compiled-function-p (symbol-function s))
        (print s)
        (compile s)))) )

SBCL - nada
* (compall)
NIL

CLISP - error
DECLARE 
*** - Not a lambda expression nor a function: #<SPECIAL-OPERATOR DECLARE>
The following restarts are available:
ABORT          :R1      Abort main loop
Break 1 CH03A[57]> :a
CH03A[58]> (fboundp 'declare)
T
CH03A[59]> (describe 'declare) ; w3m !!!

(loop for s being each symbol collect s)
(loop for s being each present-symbol collect s)
(loop for s being each external-symbol collect s)

----------------------------------------------------------------------------
Compile enclosing function => Enclosed function is compiled
(defun make-adder (n)
  #'(lambda (x) (+ x n)))

(defvar *f* (make-adder 7))

(compiled-function-p *f*)

(compile 'make-adder)

(defvar *g* (make-adder 2))

(compiled-function-p *g*)

----------------------------------------------------------------------------
240429 月
Inlining
(sb-ext:describe-compiler-policy)
- To inline make sure `space` is low optimization, e.g., 1
SBCL manual warns:
The value of space mostly influences the compiler’s decision whether to inline operations, which tend to increase the size of programs. Use the value 0 with caution, since it can cause the compiler to inline operations so indiscriminately that the net effect is to slow the program by causing cache misses or even swapping. 

(defun 50th (l)
  (nth 49 l))

(defun foo (l)
  (+ (50th l) 1))

* (disassemble #'foo)
; disassembly for FOO
; Size: 59 bytes. Origin: #x535A9391                          ; FOO
; 91:       498B4510         MOV RAX, [R13+16]                ; thread.binding-stack-pointer
; 95:       488945F8         MOV [RBP-8], RAX
; 99:       4883EC10         SUB RSP, 16
; 9D:       488B55F0         MOV RDX, [RBP-16]
; A1:       B902000000       MOV ECX, 2
; A6:       48892C24         MOV [RSP], RBP
; AA:       488BEC           MOV RBP, RSP
; AD:       B842BF3F50       MOV EAX, #x503FBF42              ; #<FDEFN 50TH>
; B2:       FFD0             CALL RAX                                   ^^^^
; B4:       480F42E3         CMOVB RSP, RBX
; B8:       BF02000000       MOV EDI, 2
; BD:       FF1425E800A052   CALL QWORD PTR [#x52A000E8]      ; GENERIC-+
; C4:       488BE5           MOV RSP, RBP
; C7:       F8               CLC
; C8:       5D               POP RBP
; C9:       C3               RET
; CA:       CC10             INT3 16                          ; Invalid argument count trap
NIL

(proclaim '(inline 50th))

(defun 50th (l)
  (nth 49 l))

(defun foo (l)
  (+ (50th l) 1))

* (disassemble #'foo)
; disassembly for FOO
; Size: 60 bytes. Origin: #x53593EA4                          ; FOO
; A4:       498B4510         MOV RAX, [R13+16]                ; thread.binding-stack-pointer
; A8:       488945F8         MOV [RBP-8], RAX
; AC:       4883EC10         SUB RSP, 16
; B0:       BA62000000       MOV EDX, 98
; B5:       488B7DF0         MOV RDI, [RBP-16]
; B9:       B904000000       MOV ECX, 4
; BE:       48892C24         MOV [RSP], RBP
; C2:       488BEC           MOV RBP, RSP
; C5:       B8A2E73450       MOV EAX, #x5034E7A2              ; #<FDEFN NTH>
; CA:       FFD0             CALL RAX                                   ^^^
; CC:       BF02000000       MOV EDI, 2
; D1:       FF1425E800A052   CALL QWORD PTR [#x52A000E8]      ; GENERIC-+
; D8:       488BE5           MOV RSP, RBP
; DB:       F8               CLC
; DC:       5D               POP RBP
; DD:       C3               RET
; DE:       CC10             INT3 16                          ; Invalid argument count trap
NIL



(proclaim '(sb-ext:maybe-inline 50th))
----------------------------------------------------------------------------
230814 月
Compilation experiments
1. Reference to 2nd function changes
* (defun foo (x) (+ x 5))
FOO
* (defun bar (x) (* (foo x) 9))
BAR
* (bar 8)
117
* (defun foo (x) (+ x 2))
WARNING: redefining COMMON-LISP-USER::FOO in DEFUN
FOO
* (bar 8)
90
* (disassemble #'bar)
; disassembly for BAR
; Size: 59 bytes. Origin: #x53586BE1                          ; BAR
; BE1:       498B4510         MOV RAX, [R13+16]               ; thread.binding-stack-pointer
; BE5:       488945F8         MOV [RBP-8], RAX
; BE9:       4883EC10         SUB RSP, 16
; BED:       488B55F0         MOV RDX, [RBP-16]
; BF1:       B902000000       MOV ECX, 2
; BF6:       48892C24         MOV [RSP], RBP
; BFA:       488BEC           MOV RBP, RSP
; BFD:       B882693F50       MOV EAX, #x503F6982             ; #<FDEFN FOO>
; C02:       FFD0             CALL RAX
; C04:       480F42E3         CMOVB RSP, RBX
; C08:       BF12000000       MOV EDI, 18
; C0D:       FF1425F800A052   CALL QWORD PTR [#x52A000F8]     ; GENERIC-*
; C14:       488BE5           MOV RSP, RBP
; C17:       F8               CLC
; C18:       5D               POP RBP
; C19:       C3               RET
; C1A:       CC10             INT3 16                         ; Invalid argument count trap
NIL

2. Function defined without 2nd function
* (defun bar (x) (* (baz x) 2))
; in: DEFUN BAR
;     (BAZ X)
; 
; caught STYLE-WARNING:
;   undefined function: COMMON-LISP-USER::BAZ
; 
; compilation unit finished
;   Undefined function:
;     BAZ
;   caught 1 STYLE-WARNING condition
WARNING: redefining COMMON-LISP-USER::BAR in DEFUN
BAR
* (disassemble #'bar)
; disassembly for BAR
; Size: 59 bytes. Origin: #x534E9F91                          ; BAR
; 91:       498B4510         MOV RAX, [R13+16]                ; thread.binding-stack-pointer
; 95:       488945F8         MOV [RBP-8], RAX
; 99:       4883EC10         SUB RSP, 16
; 9D:       488B55F0         MOV RDX, [RBP-16]
; A1:       B902000000       MOV ECX, 2
; A6:       48892C24         MOV [RSP], RBP
; AA:       488BEC           MOV RBP, RSP
; AD:       B8C2693F50       MOV EAX, #x503F69C2              ; #<FDEFN BAZ>
; B2:       FFD0             CALL RAX
; B4:       480F42E3         CMOVB RSP, RBX
; B8:       BF04000000       MOV EDI, 4
; BD:       FF1425F800A052   CALL QWORD PTR [#x52A000F8]      ; GENERIC-*
; C4:       488BE5           MOV RSP, RBP
; C7:       F8               CLC
; C8:       5D               POP RBP
; C9:       C3               RET
; CA:       CC10             INT3 16                          ; Invalid argument count trap
NIL
* (defun baz (x) (- x 4))
BAZ
* (disassemble #'bar)
; disassembly for BAR
; Size: 59 bytes. Origin: #x534E9F91                          ; BAR
; 91:       498B4510         MOV RAX, [R13+16]                ; thread.binding-stack-pointer
; 95:       488945F8         MOV [RBP-8], RAX
; 99:       4883EC10         SUB RSP, 16
; 9D:       488B55F0         MOV RDX, [RBP-16]
; A1:       B902000000       MOV ECX, 2
; A6:       48892C24         MOV [RSP], RBP
; AA:       488BEC           MOV RBP, RSP
; AD:       B8C2693F50       MOV EAX, #x503F69C2              ; #<FDEFN BAZ>
; B2:       FFD0             CALL RAX
; B4:       480F42E3         CMOVB RSP, RBX
; B8:       BF04000000       MOV EDI, 4
; BD:       FF1425F800A052   CALL QWORD PTR [#x52A000F8]      ; GENERIC-*
; C4:       488BE5           MOV RSP, RBP
; C7:       F8               CLC
; C8:       5D               POP RBP
; C9:       C3               RET
; CA:       CC10             INT3 16                          ; Invalid argument count trap
NIL

2.a. Unintern
* (defun bar (x) (* (baz x) 2))
WARNING: redefining COMMON-LISP-USER::BAR in DEFUN
BAR
* (unintern 'baz)
T
* (disassemble #'bar)
; disassembly for BAR
; Size: 59 bytes. Origin: #x534EFFA1                          ; BAR
; A1:       498B4510         MOV RAX, [R13+16]                ; thread.binding-stack-pointer
; A5:       488945F8         MOV [RBP-8], RAX
; A9:       4883EC10         SUB RSP, 16
; AD:       488B55F0         MOV RDX, [RBP-16]
; B1:       B902000000       MOV ECX, 2
; B6:       48892C24         MOV [RSP], RBP
; BA:       488BEC           MOV RBP, RSP
; BD:       B8C2693F50       MOV EAX, #x503F69C2              ; #<FDEFN #:BAZ>
; C2:       FFD0             CALL RAX
; C4:       480F42E3         CMOVB RSP, RBX
; C8:       BF04000000       MOV EDI, 4
; CD:       FF1425F800A052   CALL QWORD PTR [#x52A000F8]      ; GENERIC-*
; D4:       488BE5           MOV RSP, RBP
; D7:       F8               CLC
; D8:       5D               POP RBP
; D9:       C3               RET
; DA:       CC10             INT3 16                          ; Invalid argument count trap
NIL
* (defun baz (x) (- x 4))
BAZ
* (disassemble #'bar)
; disassembly for BAR
; Size: 59 bytes. Origin: #x534EFFA1                          ; BAR
; A1:       498B4510         MOV RAX, [R13+16]                ; thread.binding-stack-pointer
; A5:       488945F8         MOV [RBP-8], RAX
; A9:       4883EC10         SUB RSP, 16
; AD:       488B55F0         MOV RDX, [RBP-16]
; B1:       B902000000       MOV ECX, 2
; B6:       48892C24         MOV [RSP], RBP
; BA:       488BEC           MOV RBP, RSP
; BD:       B8C2693F50       MOV EAX, #x503F69C2              ; #<FDEFN #:BAZ>
; C2:       FFD0             CALL RAX
; C4:       480F42E3         CMOVB RSP, RBX
; C8:       BF04000000       MOV EDI, 4
; CD:       FF1425F800A052   CALL QWORD PTR [#x52A000F8]      ; GENERIC-*
; D4:       488BE5           MOV RSP, RBP
; D7:       F8               CLC
; D8:       5D               POP RBP
; D9:       C3               RET
; DA:       CC10             INT3 16                          ; Invalid argument count trap
NIL

3. Reference to uninterned
   (DEFUN uninterned?)
   - Before
   - After
4. FLET/LABELS
* (defun bar (x)
(labels ((baz (x) (- x 4)))
(* (baz x) 2)))
WARNING: redefining COMMON-LISP-USER::BAR in DEFUN
BAR
* (disassemble #'bar)
; disassembly for BAR
; Size: 44 bytes. Origin: #x535890B1                          ; BAR
; B1:       498B4510         MOV RAX, [R13+16]                ; thread.binding-stack-pointer
; B5:       488945F8         MOV [RBP-8], RAX
; B9:       488B55F0         MOV RDX, [RBP-16]
; BD:       BF08000000       MOV EDI, 8
; C2:       FF1425F000A052   CALL QWORD PTR [#x52A000F0]      ; GENERIC--
; C9:       BF04000000       MOV EDI, 4
; CE:       FF1425F800A052   CALL QWORD PTR [#x52A000F8]      ; GENERIC-*
; D5:       488BE5           MOV RSP, RBP
; D8:       F8               CLC
; D9:       5D               POP RBP
; DA:       C3               RET
; DB:       CC10             INT3 16                          ; Invalid argument count trap
NIL
* (defun bar (x)
(labels ((baz (x) (foo (- x 4))))
(* (baz x) 2)))
WARNING: redefining COMMON-LISP-USER::BAR in DEFUN
BAR
* (disassemble #'bar)
; disassembly for BAR
; Size: 71 bytes. Origin: #x534EFC91                          ; BAR
; 91:       498B4510         MOV RAX, [R13+16]                ; thread.binding-stack-pointer
; 95:       488945F8         MOV [RBP-8], RAX
; 99:       488B55F0         MOV RDX, [RBP-16]
; 9D:       BF08000000       MOV EDI, 8
; A2:       FF1425F000A052   CALL QWORD PTR [#x52A000F0]      ; GENERIC--
; A9:       4883EC10         SUB RSP, 16
; AD:       B902000000       MOV ECX, 2
; B2:       48892C24         MOV [RSP], RBP
; B6:       488BEC           MOV RBP, RSP
; B9:       B882693F50       MOV EAX, #x503F6982              ; #<FDEFN FOO>
; BE:       FFD0             CALL RAX
; C0:       480F42E3         CMOVB RSP, RBX
; C4:       BF04000000       MOV EDI, 4
; C9:       FF1425F800A052   CALL QWORD PTR [#x52A000F8]      ; GENERIC-*
; D0:       488BE5           MOV RSP, RBP
; D3:       F8               CLC
; D4:       5D               POP RBP
; D5:       C3               RET
; D6:       CC10             INT3 16                          ; Invalid argument count trap
NIL
----------------------------------------------------------------------------
240428 日
(compile nil '(lambda (x) (+ x 2)))

Lambda expression does not capture lexical environment!
(let ((n 8)) (compile nil '(lambda (x) (+ x n))))

vs.

(let ((n 8)) (compile nil #'(lambda (x) (+ x n)))) ; Consequences undefined?

vs.

(let ((n 8)) (compile nil `(lambda (x) (+ x ,n)))) ; !!!

Not identical:
(defun foo (x) (* x 9))

(compile 'foo #'(lambda (x) (* x 9)))

(macroexpand-1 '(defun foo (x) (* x 9)))
(PROGN
 (EVAL-WHEN (:COMPILE-TOPLEVEL) (SB-C:%COMPILER-DEFUN 'FOO T NIL NIL))
 (SB-IMPL::%DEFUN 'FOO
                  (SB-INT:NAMED-LAMBDA FOO
                      (X)
                    (BLOCK FOO (* X 9))))) ; <-------
                     ^^^^^^^^^
----------------------
DEFUN -> Named BLOCK
- Inside LAMBDA
(defun foo (x) (* x 9))

#'(lambda (x)
    (block foo
      (* x 9)))

- Not outside LAMBDA!
(block foo ; Lexical scope/dynamic extent
  #'(lambda (x)
      (* x 9)))
; BLOCK disestablished here!

CMUCL
(macroexpand-1 '(defun foo (x) (* x 9)))

(C::%DEFUN 'FOO #'(LAMBDA (X) (BLOCK FOO (* X 9))) NIL '(DEFUN FOO (X) (* X 9)))

(macroexpand-1 '(defun foo (x) (* x 9)))
(PROGN (CCL::%DEFUN (NFUNCTION FOO (LAMBDA (X) (DECLARE (CCL::GLOBAL-FUNCTION-NAME FOO)) (BLOCK FOO (* X 9)))) 'NIL) 'FOO)
----------------------------------------------------------------------------
240429 月
☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆
Graham discusses compilers for embedded languages: (26 页)
If a new language is implemented by transformation,
and the transformation code is compiled, then it yields compiled output—and
so becomes in effect a compiler for the new language.

He brings up this idea again in §6.3 and §24.8
☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆

☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆
§2.10
It cannot be overemphasized how important it is that Lisp programs can
write Lisp programs, especially since this fact is so often overlooked. Even
experienced Lisp users rarely realize the advantages they derive from this feature
of the language. This is why Lisp macros are so powerful, for example. Most
of the techniques described in this book depend on the ability to write programs
which manipulate Lisp expressions.
☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆

Chapter 3
============================================================================
☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆
============================================================================
230710 月
https://maryrosecook.com/blog/post/a-practical-introduction-to-functional-programming
  Functional code is characterised by one thing: the absence of side effects.
  It doesn’t rely on data outside the current function,
  and it doesn’t change data that exists outside the current function.
  Every other “functional” thing can be derived from this property.
  Use it as a guide rope as you learn.

§3.1
(defun bad-reverse (l)
  (do* ((length (length l))
        (i 0 (1+ i))
        (j (1- length) (1- j)))
       ((>= i j))
    (rotatef (nth i l) (nth j l))))

;(defvar *l* '(a b c))
(defvar *l* (list 'a 'b 'c 'd 'e 'f 'g))

(bad-reverse *l*)

- Destructive. Reverses list in place. Original destroyed (no consing...)
- Inefficient. Sequential access
- No meaningful return value

(defun functional-reverse (l)
  (labels ((reverse-aux (l result)
             (if (endp l)
                 result
                 (reverse-aux (rest l) (cons (first l) result)))) )
   (reverse-aux l '())))

- Non-destructive
- One pass across list
- Twice the memory (original + copy)
- Returns reversed list as value

NREVERSE
(defun nreverse (l)
  (labels ((nreverse-aux (l)
             (let ((tail (rest l)))
               (prog1 (if (null (rest tail))
                          tail
                          (nreverse-aux tail))
                      (setf (rest tail) l)))) )
    (cond ((null (rest l)) l) ; empty, single-elt list
          (t (prog1 (nreverse-aux l)
                    (setf (rest l) '()))) )))


? (setf *l* (list 'p 'q 'r 's)) ; Must capture return value
(P Q R S)
? (nreverse *l*)
(S R Q P)
? *l*
(P)


       L₁      L₂       L₃
       |       | T₁     | T₂      T₃
       v       v |      v |       |
                 v        v       v
L -> [*|*]--->[*|*]--->[*|*]--->[*|*]--->NIL
      |        |        |        |
      v        v        v        v
      P        Q        R        S
                                                L'
                                                |
                                                v
   +->[*|*]--->NIL +->[*|*]--+ +->[*|*]--+    [*|*]--+
   |    |          |    |    | |    |    |      |    |
   |    v          |    v    | |    v    |      v    |
   |    P          |    Q    | |    R    |      S    |
   +-------------------------+ |         |           |
                   |           |         |           |
                   +---------------------+           |
                               |                     |
                               +---------------------+
----------------------------------------------------------------------------
230711 火
? (defvar *l1* (list 1 2 3))
*L1*
? (defvar *l2* (list 4 5))
*L2*
? (defvar *l3* (list))
*L3*
? (nconc *l1* *l2*)
(1 2 3 4 5)
? *l1*
(1 2 3 4 5)
? *l2*
(4 5)
? (nconc *l3* *l2*)
(4 5)
? *l3*
NIL
? (setf *l3* (nconc *l3* *l2*))
(4 5)
? (eq *l3* *l2*)
T
----------------------------------------------------------------------------
Taxed operators

Assignment
----------
[set] setq setf psetf psetq
rotatef shiftf
multiple-value-setq

CLHS says:
 (multiple-value-setq (symbol1 ... symboln) value-producing-form)
is defined to always behave in the same way as
 (values (setf (values symbol1 ... symboln) value-producing-form))


(defvar *x* 9)
(set '*x* 10)
(setq *x* 10)
(setf *x* 10)

(macroexpand-1 '(setf *x* 10)) => (SETQ *X* 10)

(let ((x 1)
      (y 2))
  (setf x y y x)
  (list x y))
=> (2 2)

(let ((x 1)
      (y 2))
  (psetf x y y x)
  (list x y))
=> (2 1)

(let ((x 1)
      (y 2))
  (shiftf x y -1)
  (list x y))
=> (2 -1)

(let ((x 1)
      (y 2))
  (rotatef x y)
  (list x y))
=> (2 1)

(macroexpand-1 '(rotatef x y))
(MULTIPLE-VALUE-BIND (#:G5215) X
  (MULTIPLE-VALUE-BIND (#:G5216) Y
    (PROGN (SETQ X #:G5216)
           (SETQ Y #:G5215)
           NIL)))

(let* ((x 1)
       (y 2)
       (temp x))
  (setf x y y temp)
  (list x y))
=> (2 1)

Numeric
-------
incf decf

Cons
----
push pop pushnew
rplaca rplacd

(let ((l (cons 'a 'b)))
  (rplaca l :a)
  (rplacd l :b)
  l)
=> (:A . :B)

(let ((l (cons 'a 'b)))
  (setf (car l) :a (cdr l) :b)
  l)

(let ((l (list 'a 'b)))
  (setf (first l) :a (rest l) (list :b))
  l)
=> (:A :B)

Property lists
--------------
remf remprop
(setf (get ...) ...)
(setf (getf ...) ...)

http://www.lispworks.com/documentation/lw50/CLHS/Body/f_get.htm
(defun make-person (first-name last-name)
  (let ((person (gensym "PERSON")))
    (setf (get person 'first-name) first-name)
    (setf (get person 'last-name) last-name)
    person))

(defvar *john* (make-person "John" "Dow"))
(defvar *sally* (make-person "Sally" "Jones"))

(get *john* 'first-name)
(get *sally* 'last-name)

(symbol-plist *john*)
=> (LAST-NAME "Dow" FIRST-NAME "John")
(describe *john*)
#:PERSON5232
Type: SYMBOL
Class: #<BUILT-IN-CLASS SYMBOL>
No home package.
Print name: "PERSON5232"
Value: #<Unbound>
Function: #<Unbound>
Plist: (LAST-NAME "Dow" FIRST-NAME "John")

(defun marry (man woman married-name)
  (setf (get man 'wife) woman)
  (setf (get woman 'husband) man)
  (setf (get man 'last-name) married-name)
  (setf (get woman 'last-name) married-name)
  married-name)

(marry *john* *sally* "Dow-Jones")
(get *john* 'last-name)
(get (get *john* 'wife) 'first-name)
(symbol-plist *john*)

(defmacro age (person &optional (default ''thirty-something)) 
  `(get ,person 'age ,default))

(age *john*)
(age *john* 20)
(setf (age *john*) 25)

(macroexpand-1 '(setf (age *john*) 25))
(SETF (GET *JOHN* 'AGE 'THIRTY-SOMETHING) 25)

(age *john*)
(age *john* 20)

Hash tables
-----------
remhash

* (defvar *h* (make-hash-table))
*H*
* (setf (gethash :foo *h*) t)
T
* (setf (gethash :bar *h*) nil)
NIL
* (gethash :foo *h*)
T
T
* (gethash :bar *h*)
NIL
T
* (gethash :baz *h*)
NIL
NIL
* (remhash :foo *h*)
T
* (gethash :foo *h*)
NIL
NIL
----------------------------------------------------------------------------
Multiple values

Graham:
Other operators, like VALUES and MULTIPLE-VALUE-BIND, have been
provided specifically to make functional programming easier.

Alternative is to modify data in place:
int count = scanf("%d", &n);

? (truncate 3 2)
1
1
? (truncate 10 3)
3
1
? (truncate 10/3)
3
1/3
? (truncate (/ 10d0 3d0))
3
0.3333333333333335D0
? (multiple-value-bind (quotient remainder) (truncate 10 3)
  (list quotient remainder))
(3 1)
? (multiple-value-list (truncate 10 3))
(3 1)

(defun powers (x)
  (values x (sqrt x) (expt x 2)))

? (powers 4)
4
2
16

(defun foo (x)
  (truncate x))

(defun bar (x)
  (values (truncate x)))  ; Suppress multiple values!!

? (foo 2.3)
2
0.29999995
? (bar 2.3)
2
============================================================================
231115 水
SETF expanders
setf expander n. a function used by setf to compute the setf expansion of a place.

place n. 1. a form which is suitable for use as a generalized reference. 2. the conceptual location referred to by such a place[1].

generalized reference n. a reference to a location storing an object as if to a variable. (Such a reference can be either to read or write the location.) See Section 5.1 (Generalized Reference). See also place.

(defvar *l* '())

(setf *l* (list 1 2 3 4))
(1 2 3 4)

(setf (first *l*) 9)
9

*l*
(9 2 3 4)

(setf (rest *l*) 8)
8

*l*
(9 . 8)

fdefinition vs. symbol-function

见 date.lisp
============================================================================
Mofifying macros (Graham §12.2)

(defmacro incf (n &optional (delta 1))
  `(setf ,n (+ ,n ,delta)))

(define-modify-macro incf (&optional (delta 1)) +)

(defmacro timesf (x y)
  `(setf ,x (* ,x ,y)))

(define-modify-macro timesf (y) *)

(defmacro negatef (x)
  `(setf ,x (- ,x)))

(define-modify-macro negatef () -)

(defmacro reversef (l)
  `(setf ,l (reverse ,l)))

(define-modify-macro reversef () reverse)

(defvar *x* (list 1 2 3))
(defvar *y* *x*)
(defvar *z* *x*)

*x*
(1 2 3)


(reversef *x*)
(3 2 1)
*x*
(3 2 1)
*y*
(1 2 3)


(nreverse *y*)
(3 2 1)
*y*
(1)
*z*
(1)





let* in which imperative programs often lie concealed
============================================================================
230713 木
§3.2 Imperative Outside-In

(let (x y) ; "Uninitialized" bindings. Red flag.
  (setf x 1 y 2)
  (list x y))

Necessary in C89: (Uh, sort of...declaration must be at start of block, but these could be initialized...)
List foo(List x) {
  int y;
  int sqr;

  y = x.car;
  sqr = y * y;

  return new List('a, sqr);
}

Better in C99:
List foo(List x) {
  int y = x.car;
  int sqr = y * y;

  return new List('a, sqr);
}

FP ideal: pure functions

Make code "purer" vs. strictly "pure"?
============================================================================
230714 金
§3.3 Functional Interfaces (vs. purely functional code)

For example, though this function calls NCONC it preserves referential transparency.
For a given arg, it will always return the same (EQUAL) value. To outside world
(caller) this is indistinguishable from purely functional code. (vs. BAD-REVERSE)

      §14.3 (198 页)                                                                                    
      "A language is referentially transparent if (a) every subexpression                               
       can be replaced by any other that’s equal to it in value and (b) all                             
       occurrences of an expression within a given context yield the same                               
       value."                                                                                          
                                                                                                        
      Graham: Note that this standard applies to languages, not to programs. No language with           
      assignment is referentially transparent.                                                          
                                                                                                        
      https://stackoverflow.com/questions/210835/what-is-referential-transparency/9859966#9859966       
      https://www.nobugs.org/blog/archives/2008/11/12/why-do-they-call-it-referentially-transparent/    
      https://www.nobugs.org/blog/archives/2008/11/12/why-do-they-call-it-referentially-transparent-ii/ 
      https://wiki.haskell.org/Referential_transparency                                                 
        https://www.cs.tufts.edu/~nr/cs257/archive/peter-sestoft/ref-trans.pdf                          
      http://www.cas.mcmaster.ca/~kahl/reftrans.html                                                    

(defun qualify (expr)
  (nconc (copy-list expr) (list 'maybe)))

(defun qualify* (expr)
  (append expr (list 'maybe)))    ; <-- Why not just use this?!

(defvar *l* (list 1 2 3 4))
*L*
(qualify *l*)
(1 2 3 4 MAYBE)
(qualify* *l*)
(1 2 3 4 MAYBE)
*l*
(1 2 3 4)

APPEND vs. NCONC
[*|*]--->[*|*]--->[*|*]--->[*|*]--->NIL   [*|*]--->[*|*]--->NIL
  |        |        |        |              |        |         
  v        v        v        v              v        v         
  A        B        C        D              E        F         

NCONC
[*|*]--->[*|*]--->[*|*]--->[*|*]------->[*|*]--->[*|*]--->NIL
  |        |        |        |            |        |
  v        v        v        v            v        v
  A        B        C        D            E        F


APPEND
[*|*]--->[*|*]--->[*|*]--->[*|*]--->NIL     +->[*|*]--->[*|*]--->NIL 
  |        |        |        |              |    |        |          
  v        v        v        v              |    v        v          
  A        B        C        D              |    E        F          
  ^        ^        ^        ^              |
  |        |        |        |              |
[*|*]--->[*|*]--->[*|*]--->[*|*]------------+
----------------------------------------------------------------------------
240505 日
Not all side effects equally bad.

Rule of thumb:------------------------------------------------------------
It is harmless for a function to modify something that no one else owns. |
--------------------------------------------------------------------------

In QUALIFY, a new copy of the argument is passed to NCONC. This list is freshly CONSed.
No other code could have a reference to it.

But this is not strict enough. Consider
(let ((x 0))
  (defun total (y)
    (incf x y)))

TOTAL is a lexical closure over the binding of X. No other function can access that binding.
However, the effects of one call will be visible to subsequent calls.
(total 1) => 1
(total 1) => 2 ; Visible side effect
(total 1) => 3

Take II:-----------------------------------------------------
A given invocation can safely modify what it uniquely owns. |
        ^^^^^^^^^^                                          |
-------------------------------------------------------------
(Ownership per invocation not merely per function.)

The discussion of ownership involves both arguments and returned values.
Lisp convention:
  An invocation owns objects it receives as return values (from functions that it has called)
  but not objects passed to it as arguments (by caller of the function).
[This assertion does not imply that the caller owns a particular argument either. It may
 have received an argument from its own caller and simply passed it along to the callee:
(defun f (l)
  (g 2 l))
(defun g (n l) ; <-- G does not own L, but neither does F
  (if (zerop n)
      l
      (append l (g (1- n) l))))
]      

Functions that modify their arguments -> "Destructive"
Functions that modify objects returned to them -> ???????
- Only problematic when returned value is derived from an argument.
  If called function modifies arg or current function modifies the returned value,
  this may indirectly destructively modify arg (which it doesn't own).

Informally:
"QUALIFY creates a copy of its arg EXPR"
In fact, it receives a copy from COPY-LIST.

This function follows the convention:
(defun ok (x)                     ; <-- OK does not own X
  (nconc (list 'a x) (list 'c)))
         ^^^^^^^^^^^
             | OK "owns" this object returned by LIST.
             
Even though NCONC does not follow the convention,
the arg which NCONC modifies was freshly made by (for) OK.
The argument X passed to OK will not itself be changed.

- This local violation does not disqualify the calling function (OK) from observing the convention.
  Such functions retain most of the advantages of purely functional code

;(ok '(1 2 3))
(ok (list 1 2 3))

NCONC receives:
[*|*]--->[*|*]--->NIL                    [*|*]--->NIL
 |        |                                |         
 v        v                                v         
 A       [*|*]--->[*|*]--->[*|*]--->NIL    C         
          |        |        |
          v        v        v
          1        2        3
and alters the first list:
[*|*]--->[*|*]-------------------------->[*|*]--->NIL
 |        |                                |
 v        v                                v
 A       [*|*]--->[*|*]--->[*|*]--->NIL    C
          |        |        |
          v        v        v
          1        2        3

This small change, however, now violates the convention:
(defun not-ok (x)
  (nconc (list 'a) x (list 'c)))

NCONC will splice the list X to the final arg and then splice the first arg to this.

;(not-ok '(1 2 3))
(not-ok (list 1 2 3))

NCONC receives:
[*|*]--->NIL   [*|*]--->[*|*]--->[*|*]--->NIL   [*|*]--->NIL
 |              |        |        |               |         
 v              v        v        v               v         
 A              1        2        3               C         

and alters both the first and second lists:
[*|*]-------->[*|*]--->[*|*]--->[*|*]---------->[*|*]--->NIL
 |              |        |        |               |         
 v              v        v        v               v         
 A              1        2        3               C         

(defun f (x)
  (let ((x* (ok x)))
    (nconc x* (list 'd))))
F does not modify its arg X, and neither does OK.

How about?
(defun g (x)
  (let ((x* (not-ok x)))
    (nconc x* (list 'd))))

Or
(defun ok2 (x)
  (nconc (list 'a) x))
(defun h (x)
  (let ((x* (ok2 x)))
    (nconc x* (list 'd))))

* (defvar *l* (list 1 2 3))
*L*
* (ok *l*)
(A (1 2 3) C)
* *l*
(1 2 3)
* (ok2 *l*)
(A 1 2 3)
* *l*
(1 2 3)
* (not-ok *l*)
(A 1 2 3 C)
* *l*
(1 2 3 C)

* (setf *l* (list 1 2 3))
(1 2 3)

* (f *l*)
(A (1 2 3) C D)
* *l*
(1 2 3)

* (g *l*)
(A 1 2 3 C D)
* *l*
(1 2 3 C D)

* (setf *l* (list 1 2 3))
(1 2 3)

* (h *l*)
(A 1 2 3 D)
* *l*
(1 2 3 D)

----------------------
Condition System 19 页
(block collect
  (let ((result '())
        (i 0))
    (tagbody
      :head
        (unless (< i 5)
          (return-from collect (nreverse result))) ; Destructive reverse
        (incf i)
        (push i result)
        (go :head))))
----------------------
Programs that are truly indistinguishable from purely functional code require one more condition:
---------------------------------------------------------------------------
- Functions cannot share objects with other code that violates the rules. |
---------------------------------------------------------------------------
(defvar *anything* 99)
(defun anything (x)
  (+ x *anything*))

This function does not produce any side effects. However, the value that it returns does not
simply rely on the args passed to it.
- If any other code can alter the value of *ANYTHING*, then ANYTHING will subsequently behave differently.

(anything 100) => 199

(defun ☠ ()
  (incf *anything*))

(☠)

(anything 100) => 200
----------------------------------------------------------------------------
Same issue with free variables in general (particularly special variables)?

      §2.5
      The difference between lexical and dynamic scope comes down to how an
      implementation deals with free variables.                            

Lexical
(let ((y 7))
  (defun g (x)
    (list x y)))

(g 2) => (2 7)
(g 2) => (2 7)

Dynamic
(defun f (x)
  (declare (special y))
  (list x y))

(let ((y 9))
  (declare (special y))
  (f 8)) ; Y indirectly "passed" to F
=> (8 9)

(let ((y 12))
  (declare (special y))
  (f 8))
=> (8 12)

But lexical closures are not automatically immune:
(let ((x 0))
  (defun total (y)
    (incf x y)))

(total 1) => 1
(total 1) => 2
(total 1) => 3
----------------------------------------------------------------------------
240510 金
Purely functional code:
- When writing (or thinking about) a function, only need to consider
  - Functions that call the function
  - Functions called by the function

Apparently functional code (no visible side effects):
- Destructive operations, like global variables, can destroy locality
- Code with functional interface better than wanton side effects

(defun f (x)
  (let ((val (g x)))
    ; Safe to modify VAL?
    ))
    
What if G is IDENTITY?
(g x) => x
Modifying VAL modifies object owned by caller of F.

Have to look beyond F. But if F presents functional interface only subtree
below F needs to be considered.
----------------------------------------------------------------------------
Functions should not return anything unsafe to modify
- Value "belongs" to caller after
- Don't return anything involving certain constant objects: list, array, string
  - Literals are obvious red flag
  - Other constant values vulnerable too

(defun exclaim (expression)
  (append expression '(oh my))) ; <-- l Literal list

(defun exclaim* (expression)
  (append expression (list 'oh 'my)))

(exclaim '(lions and tigers and bears)) => (LIONS AND TIGERS AND BEARS OH MY)
(exclaim* '(lions and tigers and bears)) => (LIONS AND TIGERS AND BEARS OH MY)

(nconc (exclaim '(lions and tigers and bears)) '(goodness)) =>
(LIONS AND TIGERS AND BEARS OH MY GOODNESS)
(nconc (exclaim* '(lions and tigers and bears)) '(goodness)) => 
(LIONS AND TIGERS AND BEARS OH MY GOODNESS)

[*|*]--->[*|*]--->NIL  <-- l
 |        |
 v        v
 OH       MY

[*|*]--->[*|*]--->[*|*]--->NIL  <-- l'
 |        |        |
 v        v        v
 OH       MY      GOODNESS

(exclaim '(fixnums and bignums and floats)) =>
(FIXNUMS AND BIGNUMS AND FLOATS OH MY GOODNESS)
(exclaim* '(fixnums and bignums and floats)) =>
(FIXNUMS AND BIGNUMS AND FLOATS OH MY)

CLHS:
3.7.1 Modification of Literal Objects
The consequences are undefined if literal objects are destructively modified.

        literal adj. (of an object) referenced directly in a program rather than being computed by the program; 
        that is, appearing as data in a quote form, or, if the object is a self-evaluating object,              
        appearing as unquoted data.                                                                             
        ``In the form (cons "one" '("two")), the expressions "one", ("two"), and "two" are literal objects.''   
----------------------
(defun f () #(1 2 3)) ; <-- Literal vector
(defvar *v1* (f))

(setf (aref *v1* 1) 'foo)
*v1* => #(1 FOO 3)
(f) => #(1 FOO 3)

(defun f* () (vector 1 2 3))
(defun f** () (copy-seq #(1 2 3)))
----------------------
(let ((l (list 1 2 3))) ; <-- Not literal, but 
  (defun g () l))       ; <-- effectively a constant here

(g) => (1 2 3)
(nconc (g) '(4 5 6)) => (1 2 3 4 5 6)
(g) => (1 2 3 4 5 6)
----------------------
Hidden modification!
- First time fine
- Second time never returns!
test-core TEST-PARTIAL
(equal '(B C 2 Y Z)
        (funcall (compose (partial #'apply #'nconc) #'mapcar)
                 #'rest
                 '((a b c) (1 2) (x y z)))) ; MAPCAN


(defvar *l* '((a b c) (1 2) (x y z)))
*l* => ((A B C) (1 2) (X Y Z))

(apply #'nconc (mapcar #'rest *l*)) => (B C 2 Y Z)
*l* => ((A B C 2 Y Z) (1 2 Y Z) (X Y Z))
(apply #'nconc (mapcar #'rest *l*))
  C-c C-c
debugger invoked on a SB-SYS:INTERACTIVE-INTERRUPT @52A19B80 in thread

Before:
[*|*]--------------------------->[*|*]------------------>[*|*]--->NIL
 |                                |                       |
 v                                v                       v
[*|*]--->[*|*]--->[*|*]--->NIL   [*|*]--->[*|*]--->NIL   [*|*]--->[*|*]--->[*|*]--->NIL
 |        |        |              |        |              |        |        |
 v        v        v              v        v              v        v        v
 A        B        C              1        2              X        Y        Z

MAPCAR #'REST
[*|*]------------------>[*|*]--------->[*|*]--->NIL
 |                       |              |
 v                       v              v
[*|*]--->[*|*]--->NIL   [*|*]--->NIL   [*|*]--->[*|*]--->NIL
 |        |              |              |        |
 v        v              v              v        v
 B        C              2              Y        Z

Wrong:
[*|*]------------------------------------------------------>[*|*]------------------------------------>[*|*]--->NIL
 |                                                           |                                         |
 v                                                           v                                         v
[*|*]--->[*|*]--->[*|*]--->[*|*]--->[*|*]--->[*|*]--->NIL   [*|*]--->[*|*]--->[*|*]--->[*|*]--->NIL   [*|*]--->[*|*]--->[*|*]--->NIL
 |        |        |        |        |        |              |        |        |        |              |        |        |
 v        v        v        v        v        v              v        v        v        v              v        v        v
 A        B        C        2        Y        Z              1        2        Y        Z              X        Y        Z

Actual:
[*|*]------------------------------------------------------>[*|*]------------------------------------>[*|*]--->NIL
 |                                                           |                                         |
 v                                                           v                                         v
[*|*]--->[*|*]                                              [*|*]                                     [*|*]
 |        | |                                                | |                                       | |  
 v        v |                                                v |                                       v | 
 A        B |                                                1 |                                       X | 
            |                                                  |                                         |
            |                                                  |                                         |
            v                                                  v                                         v
           [*|*]--------------------------------------------->[*|*]------------------------------------>[*|*]--->[*|*]--->NIL
            |                                                  |                                         |        |          
            v                                                  v                                         v        v          
            C                                                  2                                         Y        Z          
 
(eq (cdddr (first *l*)) (cdr (second *l*))) => T
(eq (cddr (second *l*)) (cdr (third *l*))) => T





MAPCAN has same result
(setf *l* '((a b c) (1 2) (x y z)))
(mapcan #'rest *l*) => (B C 2 Y Z)
*l* => ((A B C 2 Y Z) (1 2 Y Z) (X Y Z))
(mapcan #'rest *l*)
  C-c C-c

COPY-LIST of original list doesn't help
(setf *l* (copy-list '((a b c) (1 2) (x y z))))
(mapcan #'rest *l*) => (B C 2 Y Z)
*l* => ((A B C 2 Y Z) (1 2 Y Z) (X Y Z))
* (mapcan #'rest *l*)
  C-c C-c

COPY-LIST of arg to MAPCAN doesn't help
(setf *l* '((a b c) (1 2) (x y z)))
(mapcan #'rest (copy-list *l*)) => (B C 2 Y Z)
*l* => ((A B C 2 Y Z) (1 2 Y Z) (X Y Z))
(mapcan #'rest (copy-list *l*))
  C-c C-c

Original:
     [*|*]---------------------------->[*|*]------------------->[*|*]--->NIL                  
      |                                 |                        |                            
      v                                 v                        v                            
 +-->[*|*]--->[*|*]--->[*|*]--->NIL +->[*|*]--->[*|*]--->NIL +->[*|*]--->[*|*]--->[*|*]--->NIL
 |    |        |        |           |    |        |          |    |        |        |          
 |    v        v        v           |    v        v          |    v        v        v          
 |    A        B        C           |    1        2          |    X        Y        Z          
 |                                  |                        |
 |                                  |                        |
 |                                  |                        |
[*|*]----------------------------->[*|*]------------------->[*|*]--->NIL

(eq (first *l*) (first (copy-list *l*))) => T
(eq (second *l*) (second (copy-list *l*))) => T

Must use COPY-TREE. Deep copy.
(setf *l* '((a b c) (1 2) (x y z)))
(mapcan #'rest (copy-tree *l*)) => (B C 2 Y Z)
*l* => ((A B C) (1 2) (X Y Z))
(mapcan #'rest (copy-tree *l*)) => (B C 2 Y Z)

[*|*]--------------------------->[*|*]------------------>[*|*]--->NIL
 |                                |                       |
 v                                v                       v
[*|*]--->[*|*]--->[*|*]--->NIL   [*|*]--->[*|*]--->NIL   [*|*]--->[*|*]--->[*|*]--->NIL
 |        |        |              |        |              |        |        |
 v        v        v              v        v              v        v        v
 A        B        C              1        2              X        Y        Z
 ^        ^        ^              ^        ^              ^        ^        ^
 |        |        |              |        |              |        |        |
[*|*]--->[*|*]--->[*|*]--->NIL   [*|*]--->[*|*]--->NIL   [*|*]--->[*|*]--->[*|*]--->NIL
 ^                                ^                       ^
 |                                |                       |
[*|*]--------------------------->[*|*]------------------>[*|*]--->NIL
----------------------------------------------------------------------------
Pure Functional Programming (FP)
- Don't cause side effects
- Not vulnerable to side effects
  - All input comes from parameters
  - (Closures OK in context of immutable variables)

Functional Interface ≈ FP
- No visible side effects
  - Only modify what you own
    - per invocation
    - values returned by other functions to you
- Don't share vulnerable objects (other code has access)
- Don't return vulnerable objects (you give access to other code)
- Call with same args => same value
----------------------------------------------------------------------------
Chapter 4 Utility Functions
============================================================================
☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆
============================================================================
240512 日
Extend Lisp with new functions
(Special operators are fixed. Rest of book covers macros.)

Learning to write utilities: learning the habit rather than techniques

How to decide which "Lisp features" a program is lacking?

                                 Utility
                                 /    \
                                /      \
                               /        \
                              /       More general-purpose
                      Smaller than     than a particular program
                      an application

Example:
Reinventing the wheel
- Special purpose solution created when existing general solution could handle

(defvar *nicknames* '((thomas (tom tommy))
                      (robert (rob bob bobbie))
                      (theodore (theo ted))
                      (catherine (kate cathy))
                      (david (dave davey))
                      (edward (ed))
                      (michael (mike))
                      (elizabeth (liz lisa lizzie))))

(defun nicknames (name)
  "Get all of the nicknames for a given NAME."
  (let ((entry (assoc name *nicknames*)))
    (if (null entry)
        nil
        (second entry))))

Naive:
(defun all-nicknames (names)
  "Collect all of the nicknames for the specified NAMES."
  (if (null names)
      '()
      (nconc (nicknames (first names)) (all-nicknames (rest names)))) ) ; !!

(all-nicknames '(michael edward david)) => (MIKE ED DAVE DAVEY)

- Buries pattern in specific function that could be generally useful.
  This is not about collecting lists of "nicknames" into a single list but
  rather a special case of mapping a function over the elements of a list
  that itself yields lists and joining those lists together: MAPCAN

Idiomatic:
(mapcan #'nicknames '(michael edward david))
  C-c C-c

Oops!
(sdraw *nicknames* :display-width 200)
[*|*]--------------------------->[*|*]------------------------------------>[*|*]----------------------------->[*|*]------------------------------>[*|*]------------------>[*|*]----->[*|*]--->etc.
 |                                |                                         |                                  |                                   |                       |          |
 v                                v                                         v                                  v                                   v                       v          v
[*|*]--->[*|*]--->NIL            [*|*]--->[*|*]--->NIL                     [*|*]----->[*|*]--->NIL            [*|*]------>[*|*]--->NIL            [*|*]--->[*|*]--->NIL   etc.       etc.
 |        |                       |        |                                |          |                       |           |                       |        |
 v        v                       v        v                                v          v                       v           v                       v        v
THOMAS   [*|*]--->[*|*]--->NIL   ROBERT   [*|*]--->[*|*]--->[*|*]--->NIL   THEODORE   [*|*]--->[*|*]--->NIL   CATHERINE   [*|*]--->[*|*]--->NIL   DAVID    [*|*]--->[*|*]--->[*|*]--->[*|*]--->etc.
          |        |                       |        |        |                         |        |                          |        |                       |        |        |        |
          v        v                       v        v        v                         v        v                          v        v                       v        v        v        v
         TOM      TOMMY                   ROB      BOB      BOBBIE                    THEO     TED                        KATE     CATHY                   DAVE     DAVEY     ED      DAVE

(sdraw (cddr *nicknames*) :display-width 200)
[*|*]----------------------------->[*|*]------------------------------>[*|*]------------------>[*|*]----->[*|*]----->[*|*]--->NIL
 |                                  |                                   |                       |          |          |
 v                                  v                                   v                       v          v          v
[*|*]----->[*|*]--->NIL            [*|*]------>[*|*]--->NIL            [*|*]--->[*|*]--->NIL   etc.       etc.       etc.
 |          |                       |           |                       |        |
 v          v                       v           v                       v        v
THEODORE   [*|*]--->[*|*]--->NIL   CATHERINE   [*|*]--->[*|*]--->NIL   DAVID    [*|*]--->[*|*]--->[*|*]--->[*|*]--->[*|*]--->[*|*]--->[*|*]--->[*|*]--->[*|*]--->[*|*]--->[*|*]--->[*|*]--->etc.
            |        |                          |        |                       |        |        |        |        |        |        |        |        |        |        |        |
            v        v                          v        v                       v        v        v        v        v        v        v        v        v        v        v        v
           THEO     TED                        KATE     CATHY                   DAVE     DAVEY     ED      DAVE     DAVEY     ED      DAVE     DAVEY     ED      DAVE     DAVEY     ED


Could rewrite ALL-NICKNAMES with APPEND rather than NCONC, but what about MAPCAN??

见 54 页 (With warning about NICKNAMES!)
;;;
;;;    Non-destructive alternative to MAPCAN.
;;;    
(defun mappend (f &rest lists)
  (apply #'append (apply #'mapcar f lists)))

vs.

(defun mapcan (f &rest lists)
  (apply #'nconc (apply #'mapcar f lists)))


(mapcar #'list '(a b c) '(1 2 3))
((A 1) (B 2) (C 3))
(mapcar #'list (loop for i upto 10 collect i) (loop for i upto 10 collect (format nil "~R" i)))
((0 "zero") (1 "one") (2 "two") (3 "three") (4 "four") (5 "five") (6 "six")
 (7 "seven") (8 "eight") (9 "nine") (10 "ten"))
(mapcan #'list (loop for i upto 10 collect i) (loop for i upto 10 collect (format nil "~R" i)))
(0 "zero" 1 "one" 2 "two" 3 "three" 4 "four" 5 "five" 6 "six" 7 "seven" 8
 "eight" 9 "nine" 10 "ten")
(mappend #'list (loop for i upto 10 collect i) (loop for i upto 10 collect (format nil "~R" i)))
(0 "zero" 1 "one" 2 "two" 3 "three" 4 "four" 5 "five" 6 "six" 7 "seven" 8
 "eight" 9 "nine" 10 "ten")


(defun nicknames (name)
  (let ((entry (assoc name *nicknames*)))
    (if (null entry)
        nil
        (copy-list (second entry)))) ) ; Defensive copy (consistent with Graham's oblique description.)
---------------------------------------------------------
Above, MAPCAN is an existing and superior alternative to writing ALL-NICKNAMES from scratch.
But what about the case where the alternative (i.e., MAPCAN) doesn't exist yet?

Example:
(defvar *towns* (List of nearby towns sorted by increasing distance (from where?)))

(defun bookshops (town)
  ;; Returns list of all bookshops in the given TOWN
  )

(let ((town (find-if #'bookshops *towns*))) ; Find nearest (first) town in list with a bookshop, i.e., success means non-nil list of shops
  (values town (bookshops town)))           ; Get bookshops for that town

- Inelegant/possibly inefficient. BOOKSHOPS called twice to do same work

Instead:
(defun find-books (towns)
  (if (endp towns)
      nil
      (let ((shops (bookshops (first towns))))
        (if shops
            (values (first towns) shops)
            (find-books (rest towns)))) ))

But is there more general pattern here?

Eureka!
What we want is a combination of FIND-IF/SOME:
(find-if #'bookshops *towns*) ; Find TOWN where (bookshops town) => non-NIL
(some #'bookshops *towns*) ; Find non-NIL value of (bookshops town) for some town

(defun safe-sqrt (x)
  (if (and (numberp x) (>= x 0))
      (sqrt x)
      nil))

(find-if #'safe-sqrt '(a "foo" -3 8 t)) => 8 ; Element of list
(some #'safe-sqrt '(a "foo" -3 8 t)) => 2.828427 ; Value of function applied to that element

Generalize:
[Only works on lists! SOME/FIND-IF are more general sequence functions.]
(defun find2 (f l)
  (if (endp l)
      nil
      (let ((val (funcall f (first l))))
        (if val
            (values (first l) val)
            (find2 f (rest l)))) ))

(find2 #'(lambda (elt) (if (numberp elt) (sqrt elt) nil)) '(a "pung" 5 t)) => 5; 2.236068

;;    Sequence function
(defun find-some-if (f seq)
  (values-list (some #'(lambda (elt)
                         (let ((val (funcall f elt)))
                           (if val
                               (list elt val) ; SOME only returns primary value.
                               nil)))
                     seq)))

(find-some-if #'(lambda (elt) (if (numberp elt) (sqrt elt) nil)) '(a "pung" 5 t)) =>
5
2.236068
(find-some-if #'(lambda (elt) (if (numberp elt) (sqrt elt) nil)) #('a "pung" 5 t)) =>
5
2.236068

;;    Another implementation. Handles sequences.
(defun find-some-if (f seq)
  (typecase seq
    (list (loop for elt in seq                       ; <-- D'oh!
                for val = (funcall f elt)
                when val
                return (values elt val)))
    (vector (loop for elt across seq                 ; <--
                  for val = (funcall f elt)
                  when val
                  return (values elt val)))) )

Look for general function <- skeleton of more specific function
- Higher-order function
  - Pass in function arg to customize behavior ("Put the flesh back on the skeleton.")
----------------------------------------------------------------------------
240614 金
Sidebar: compare SOME vs. FIND-IF
(defun some1 (fn l)
  (cond ((endp l) nil)
	((funcall fn (first l)))
	(t (some1 fn (rest l)))) )

(defun find-if1 (fn l)
  (cond ((endp l) nil)
	((funcall fn (first l)) (first l))
	(t (find-if1 fn (rest l)))) )

;;;
;;;    Abstraction
;;;    
(defun traverse (l test xform)
  (cond ((endp l) nil)
	((funcall test (first l)) (funcall xform (first l)))
	(t (traverse (rest l) test xform))))

(defun some2 (fn l)
  (traverse l fn fn))

(defun find-if2 (fn l)
  (traverse l fn #'identity))


SOME -> FIND-IF:
(some f seq) -> (some #'(lambda (elt) (and (funcall f elt) elt)) seq)
----------------------------------------------------------------------------
240925 水
Case study

Customize behavior with higher-order functions

Quicksort
2 implementations
- QSORT
  1. Works on vectors
  2. Destructive. Sorts in place.
- QUICKSORT
  1. Works on lists.
  2. Nondestructive. Builds sorted copy of input.

Basic algorithm
1. Choose pivot element. Place it in sorted position.
2. Gather all elements less than or equal to pivot on left (unsorted).
   (Less than or equal--accounts for duplicates of pivot.)
3. Gather all elements greater than pivot on right (unsorted).
4. Recursively sort left/right subsequences.

Choose first elt as pivot
----------------------
|12| 3| 6|18| 7|15|10|
----------------------
         ||
         \/
----------------------
|10| 3| 6| 7|12|15|18|  Pivot in correct position
----------------------
              ^  
              |

Sort left subsequence. Sort right subsequence.


I. QSORT sort vector in place.
(defun qsort (a)
  (labels ((qsort-aux (a low high)
             (if (>= low high)
                 a
                 (let ((middle (partition a low high)))
                   (qsort-aux a low (1- middle))
                   (qsort-aux a (1+ middle) high))))
           (partition (a low high)
             (let* ((pivot (aref a low))
                    (new-pivot-index (lower a pivot low high)))
               (setf (aref a new-pivot-index) pivot)
               new-pivot-index))
           (lower (a pivot low high)
             (cond ((= low high) high)
                   ((< (aref a high) pivot) 
                    (setf (aref a low) (aref a high))
                    (raise a pivot (1+ low) high))
                   (t (lower a pivot low (1- high)))) )
           (raise (a pivot low high)
             (cond ((= low high) high)
                   ((< pivot (aref a low))
                    (setf (aref a high) (aref a low))
                    (lower a pivot low (1- high)))
                   (t (raise a pivot (1+ low) high)))) )
    (qsort-aux a 0 (1- (length a)))) )

1. Choose pivot (first elt)
----------------------
|12| 3| 6|18| 7|15|10|
----------------------
2. Pivot: 12
An empty location exists where pivot was "removed".
If `high` pointer points to elt < pivot, move that elt to left
----------------------
|  | 3| 6|18| 7|15|10|
----------------------
  ^                 ^
  |low              |high
3. Increment `low` pointer. Look for low elts that belong to right of pivot
----------------------
|10| 3| 6|18| 7|15|  |  Nope
----------------------
     ^              ^
     |low           |high
----------------------
|10| 3| 6|18| 7|15|  |  Nope
----------------------
        ^           ^
        |low        |high
----------------------
|10| 3| 6|18| 7|15|  |  Yes
----------------------
           ^        ^
           |low     |high
Copy to hole on right.
4. Decrement `high` pointer. Resume looking for low elts.
----------------------
|10| 3| 6|  | 7|15|18|  Nope
----------------------
           ^     ^
           |low  |high
----------------------
|10| 3| 6|  | 7|15|18|  Yes
----------------------
           ^  ^
           |  |high
           |low
5. Copy elt to hole. Increment `low` pointer.
----------------------
|10| 3| 6| 7|  |15|18|
----------------------
              ^
              |high
              |low
6. low = high. Done with this pass. Copy pivot into correct location.
----------------------
|10| 3| 6| 7|12|15|18|
----------------------
7. Recursively sort subsequence to left of pivot and that to right.

II. QUICKSORT build sorted copy of list
Very clear declarative program
(defun quicksort (l)
  (if (null l)
      '()
      (destructuring-bind (pivot . xs) l
        (let ((lower (loop for elt in xs when (<= elt pivot) collect elt))
              (higher (loop for elt in xs when (> elt pivot) collect elt)))
          (append (quicksort lower)
                  (list pivot)
                  (quicksort higher)))) ))

Beautiful. But nearly useless.
Only sorts numbers in ascending order!!!

Should be able to customize by telling how to compare any two items.

Total ordering
For any elements a, b either:
1. a < b
2. a > b
3. a = b

Three separate comparisons: <, >, =

Instead given < function:
1. a < b
2. b < a
3. Otherwise a and b are equal. Consequence of first two tests failing.

(defun quicksort (l &key (test #'<))
  (if (null l)
      '()
      (destructuring-bind (pivot . xs) l
        (let ((lower (loop for elt in xs unless (funcall test pivot elt) collect elt))
              (higher (loop for elt in xs when (funcall test pivot elt) collect elt)))
          (append (quicksort lower :test test)
                  (list pivot)
                  (quicksort higher :test test)))) ))

(funcall test pivot elt) ; General
vs.
(< pivot elt) ; Original (limited)


(quicksort (list 61 82 67 4 98 20 37 85)) => (4 20 37 61 67 82 85 98)
(quicksort (list 61 82 67 4 98 20 37 85) :test #'>) => (98 85 82 67 61 37 20 4)
(quicksort (list "pung" "foo" "bar" "baz") :test #'string>) => ("pung" "foo" "baz" "bar")
(quicksort (list "Pung" "FOO" "BAR" "baz") :test #'string-greaterp) => ("Pung" "FOO" "baz" "BAR")
(quicksort '((a . 5) (b . 9) (k . 3) (p . 4) (z . 2)) :test #'(lambda (a b) (< (cdr a) (cdr b)))) => ((Z . 2) (K . 3) (P . 4) (A . 5) (B . 9))

Cleaner implementation with sequence functions

https://www.lispworks.com/documentation/HyperSpec/Body/c_sequen.htm
Many sequence functions come in 3 flavors:
foo
foo-if
foo-if-not

(remove 5 '(1 2 3 4 5 2 3 4 5 6)) => (1 2 3 4 2 3 4 6)
(remove-if #'evenp #(1 2 3 4 5)) => #(1 3 5)
(remove-if-not #'oddp #(1 2 3 4 5)) => #(1 3 5)

https://www.lispworks.com/documentation/HyperSpec/Body/f_rm_rm.htm
The functions delete-if-not and remove-if-not are deprecated.

Oh really? Who says that isn't the case?
   Welcome to the Common Lisp HyperSpec.
   I hope it serves your need.          
                                        
   --Kent Pitman, X3J13 Project Editor  

Kent has confirmed in comp.lang.lisp that the deprecation of the IF-NOT functions should be ignored.

REMOVE-IF-NOT is often called "filter". (Perl's grep!)
Clojure:
(filter odd? '(1 2 3 4 5)) => (1 3 5)
Oz:
{Filter [1 2 3 4 5] IsOdd} => [1 3 5]

(defun quicksort (l &key (test #'<))
  (if (null l)
      '()
      (destructuring-bind (pivot . xs) l
        (append (quicksort (remove-if (partial test pivot) xs) :test test)
                (list pivot)
                (quicksort (remove-if-not (partial test pivot) xs) :test test)))) )

Suppose TEST is #'<
#'(lambda (elt) (< pivot elt))
#'(lambda (elt) (funcall test pivot elt))

Equivalent:
((lambda (elt) (funcall test pivot elt)) 10)
(funcall (partial test pivot) 10)

For comparison (Haskell):
quicksort :: (Ord a) => [a] -> [a]
quicksort [] = []
quicksort (x:xs) =
    let smallerOrEqual = [a | a <- xs, a <= x]
        larger = [a | a <- xs, a > x]
    in quicksort smallerOrEqual ++ [x] ++ quicksort larger
------------------------------------------------------------------
Generalization overkill?

Convert temperature:
Fahrenheit -> Celsius
Celsius -> Fahrenheit

Simple formulas:
F = 9/5 C + 32
C = 5/9(F - 32)

But wait, there's more!
Two coplanar lines that are not parallel will intersect. Thus:
F = 9/5 C + 32 intersects F = C. Where? (Answer below)

C = 5/9(F + 40) - 40
F = 9/5(C + 40) - 40

(defun convert (m)
  #'(lambda (temperature)
      (- (* (+ temperature 40) m) 40)))
(defun f->c (f)
  (funcall (convert 5/9) f))
(defun c->f (c)
  (funcall (convert 9/5) c))

This has nice symmetry but probably isn't worth the refactor.










Spoiler!
9
- C + 32 = C
5

9
- C - C = -32
5

4
- C = -32
5

C = -40
----------------------------------------------------------------------------
§4.2 Invest in abstraction
Utility as capital expense
- Write once
- Benefit multiple times after

Write utilities to _efficiently_ implement features that may be _simple to express_ yet
inefficient in base lang.

(defun longerp (l1 l2)
  (> (length l1) (length l2)))

(longerp (make-list 1000000) '(a b c)) !!

Make the efficient approach as convenient/natural as the inefficient.
----------------------------------------------------------------------------
§4.3 Operations on Lists 240621 金

"Smallest utilities worth defining"
- Should be declared inline

(proclaim '(inline last1 singlep append1 conc1 mklist))

(defun last1 (l)
  (first (last l)))

;; LAST cons
(last '(a b c)) => (C)
(last '(a b . c)) => (B . C)

(last1 '(a b c)) => C
(last1 '(a b . c)) => B


Does a list contain only one elt?
(= (length l) 1)
(= (length (loop for i from 1 to 1000000 collect i)) 1) ; ???

(defun singlep (l)
  (and (consp l) (null (rest l)))) ; Watch out for NIL

(first '()) => NIL
(rest '()) => NIL
(null (rest '())) => T
(and (consp '()) (null (rest '()))) => NIL

(singlep '(a b)) => NIL
(singlep '(a)) => T
(singlep '()) => NIL



(defun append1 (l obj)
  (append l (list obj)))

(append1 '(a b c) 'd) => (A B C D)



(defun conc1 (l obj)
  (nconc l (list obj))) ; Destructive



(defun mklist (obj)
  (if (listp obj)
      obj
      (list obj)))

(mklist 'a) => (A)
(mklist '(a b)) => (A B)

Facilitates MAPCAN/MAPPEND
- Map a function that returns a list for each elt of input list

(defvar *nicknames* '((thomas (tom tommy))
                      (robert (rob bob bobbie))
                      (theodore (theo ted))
                      (catherine (kate cathy))
                      (david dave)    ; ---+
                      (edward ed)     ;    |---> Single names
                      (michael mike)  ; ---+
                      (elizabeth (liz lisa lizzie))))

I. MKLIST in mapping function
(defun nicknames (name)
  "Get all of the nicknames for a given NAME."
  (let ((entry (assoc name *nicknames*)))
    (if (null entry)
        nil
        (second entry))))

(defun mappend (f &rest lists)
  (apply #'append (apply #'mapcar f lists)))

(mappend #'nicknames '(robert michael elizabeth))

debugger invoked on a TYPE-ERROR @52A1FA31 in thread
#<THREAD "main thread" RUNNING {1001834103}>:
  The value
    MIKE
  is not of type
    LIST

(mappend (compose #'mklist #'nicknames) '(robert michael elizabeth))
=> (ROB BOB BOBBIE MIKE LIZ LISA LIZZIE)


II. MKLIST in source function
(defun nicknames (name)
  "Get all of the nicknames for a given NAME."
  (let ((entry (assoc name *nicknames*)))
    (if (null entry)
        nil
        (copy-list (mklist (second entry)))) )) ; Defensive copy (consistent with Graham's oblique description.)

(mappend #'nicknames '(robert michael elizabeth))
=> (ROB BOB BOBBIE MIKE LIZ LISA LIZZIE)
-----------------------------------------------------------
Bigger utilities

Is one sequence longer than another?
(defun longerp (seq1 seq2)
  "Is SEQ1 strictly longer than SEQ2?"
  (labels ((compare (seq1 seq2)
             (cond ((endp seq1) nil) ; Fail fast
                   ((endp seq2) t)
                   (t (compare (rest seq1) (rest seq2)))) ))
    (if (and (listp seq1) (listp seq2))
        (compare seq1 seq2)
        (> (length seq1) (length seq2)))) ) ; Cheap for 2 vectors. Expensive for lists

(> (length '(a)) (length (loop for i from 1 to (expt 10 6) collect i)))
vs.
(longerp '(a) (loop for i from 1 to (expt 10 6) collect i))

(defun longerp (seq1 seq2)
  "Is SEQ1 strictly longer than SEQ2?"
  (labels ((compare-ll (seq1 seq2)
             (cond ((endp seq1) nil)
                   ((endp seq2) t)
                   (t (compare-ll (rest seq1) (rest seq2)))) )
           (compare-ln (seq n)
             (cond ((endp seq) nil)
                   ((zerop n) t)
                   (t (compare-ln (rest seq) (1- n)))) )
           (compare-nl (n seq)
             (cond ((zerop n) nil)
                   ((endp seq) t)
                   (t (compare-nl (1- n) (rest seq)))) ))
    (cond ((and (listp seq1) (listp seq2)) (compare-ll seq1 seq2))
          ((listp seq1) (compare-ln seq1 (length seq2)))
          ((listp seq2) (compare-nl (length seq1) seq2))
          (t (> (length seq1) (length seq2)))) ))

(longerp (loop for i upto 100000 collect i) "yep")
(longerp "nope" (loop for i upto 100000 collect i))

Generic function vs. explicit type checking:
(defgeneric longerp (seq1 seq2)
  (:documentation "Is SEQ1 strictly longer than SEQ2?"))
(defmethod longerp ((seq1 list) (seq2 list))
  (cond ((endp seq1) nil)
        ((endp seq2) t)
        (t (longerp (rest seq1) (rest seq2)))) )
(defmethod longerp ((seq1 list) (seq2 sequence))
  (labels ((compare (seq n)
             (cond ((endp seq) nil)
                   ((zerop n) t)
                   (t (compare (rest seq) (1- n)))) ))
    (compare seq1 (length seq2))))
(defmethod longerp ((seq1 sequence) (seq2 list))
  (labels ((compare (n seq)
             (cond ((zerop n) nil)
                   ((endp seq) t)
                   (t (compare (1- n) (rest seq)))) ))
    (compare (length seq1) seq2)))
(defmethod longerp ((seq1 sequence) (seq2 sequence))
  (> (length seq1) (length seq2)))

-------------------------------------------
Graham's FILTER is weird...
More efficient version of: (mapcar #'f (remove-if-not #'f seq))

He draws the analogy FILTER:SOME::REMOVE-IF-NOT:FIND-IF
    The built-in REMOVE-IF-NOT returns all the values that might have been returned  
    if you called FIND-IF with the same function on successive cdrs of a list. Analo-
    gously, FILTER returns what SOME would have returned for successive cdrs of the  
    list.

Uh, sort of...
(remove-if-not #'evenp (loop for i from 1 to 20 collect i))
(2 4 6 8 10 12 14 16 18 20)

(find-if #'evenp '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20))
2
(find-if #'evenp '(2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20))
2
(find-if #'evenp '(3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20))
4
(find-if #'evenp '(4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20))
4
(maplist #'(lambda (l) (find-if #'evenp l)) (loop for i from 1 to 20 collect i))
(2 2 4 4 6 6 8 8 10 10 12 12 14 14 16 16 18 18 20 20)

Likewise:
(filter #'(lambda (x) (if (numberp x) (1+ x) nil)) '(a 1 2 b 3 c d 4))
(2 3 4 5)

(some #'(lambda (x) (if (numberp x) (1+ x) nil)) '(a 1 2 b 3 c d 4))
2
(some #'(lambda (x) (if (numberp x) (1+ x) nil)) '(1 2 b 3 c d 4))
2
(some #'(lambda (x) (if (numberp x) (1+ x) nil)) '(2 b 3 c d 4))
3
(some #'(lambda (x) (if (numberp x) (1+ x) nil)) '(b 3 c d 4))
4
(some #'(lambda (x) (if (numberp x) (1+ x) nil)) '(3 c d 4))
4
(maplist #'(lambda (l) (some #'(lambda (x) (if (numberp x) (1+ x) nil)) l)) '(a 1 2 b 3 c d 4))
(2 2 3 4 4 5 5 5)


(flet ((f (x) (if (numberp x) (1+ x) nil))) (remove-if-not #'f '(a 1 2 b 3 c d 4)))
=> (1 2 3 4)
(flet ((f (x) (if (numberp x) (1+ x) nil))) (mapcar #'f (remove-if-not #'f '(a 1 2 b 3 c d 4))))
=> (2 3 4 5)

(defun filter (fn list)
  (let ((acc '()))
    (dolist (elt list (nreverse acc))
      (let ((val (funcall fn elt)))
 	(when val
          (push val acc)))) ))  ; <-- Accumulate vals

Similarly
(defun remove-if-not (fn list)
  (let ((acc '()))
    (dolist (elt list (nreverse acc))
      (when (funcall fn elt)
        (push elt acc)))) )  ; <-- Accumulate elts

His version only works on lists...

REMOVE-IF-NOT is a sequence function:
(remove-if-not #'lower-case-p "aBCdefGhIJk")
"adefhk"
(remove-if-not #'lower-case-p (coerce "aBCdefGhIJk" 'list))
(#\a #\d #\e #\f #\h #\k)

Alternative:
(defun filter (f seq)
  (typecase seq
    (list (loop for elt in seq
                for val = (funcall f elt)
                when val collect val))
    (vector (loop for elt across seq
                  for val = (funcall f elt)
                  when val collect val into result
                  finally (return (coerce result (if (stringp seq) 'string 'vector)))) )))

(filter #'(lambda (ch) (and (alpha-char-p ch) (lower-case-p ch) (char-upcase ch))) "Is this not pung?"))
"STHISNOTPUNG"
(filter #'(lambda (ch) (and (alpha-char-p ch) (lower-case-p ch) (char-upcase ch))) (coerce "Is this not pung?" 'list)))
(#\S #\T #\H #\I #\S #\N #\O #\T #\P #\U #\N #\G)

CLOS:
(defgeneric filter (f seq)
  (:documentation "Retain non-nil values obtained by applying F to elts of SEQ."))
(defmethod filter (f (seq list))
  (loop for elt in seq                    ; D'oh!
        for val = (funcall f elt)
        when val collect val))
(defmethod filter (f (seq sequence))
  (loop for elt across seq                ; D'oh!
        for val = (funcall f elt)
        when val collect val))
(defmethod filter (f (seq vector))
  (coerce (call-next-method) 'vector))
(defmethod filter (f (seq string))
  (coerce (call-next-method) 'string))
-------------------------------------------
Partition a sequence (list) into groups of size N (last group may be incomplete):
(group (loop for i from 1 to 12 collect i) 3)
((1 2 3) (4 5 6) (7 8 9) (10 11 12))
(group (loop for i from 1 to 12 collect i) 4)
((1 2 3 4) (5 6 7 8) (9 10 11 12))
(group (loop for i from 1 to 12 collect i) 5)
((1 2 3 4 5) (6 7 8 9 10) (11 12))

[Clojure has a similar function `partition-all`:
(partition-all 5 (range 20)) => ((0 1 2 3 4) (5 6 7 8 9) (10 11 12 13 14) (15 16 17 18 19))
(partition-all 6 (range 20)) => ((0 1 2 3 4 5) (6 7 8 9 10 11) (12 13 14 15 16 17) (18 19))]

2 edge cases:
1. SOURCE is empty
2. N = 0
(defun group (source n)
  (when (zerop n) (error "Invalid length.")) ; edge case 2
  (labels ((group-aux (source acc)
             (let ((rest (nthcdr n source)))
               (if (consp rest)
                   (group-aux rest (cons (subseq source 0 n) acc))
                   (nreverse (cons source acc)))) ))
    (if source
        (group-aux source '())
        '()))) ; edge case 1

Old skool idiom:
1. CONS result (backwards)
2. NREVERSE result when done

More general solution handling sequences:
(defun drop (n seq)
  "Drop the first N elements of sequence SEQ."
  (typecase seq
    (list (nthcdr n seq))
    (vector (subseq seq (min n (length seq)))) ))

(defun take (n seq)
  "Take the first N elements of sequence SEQ."
  (typecase seq
    (list (loop repeat n
                for elt in seq
                collect elt))
    (vector (subseq seq 0 (min n (length seq)))) ))

(defun take-drop (n seq)
  "Split a sequence at the Nth element. Return the subsequences before and after."
  (assert (typep n `(integer 0))
          (n)
          "N must be a non-negative integer.")
  (typecase seq
    (list (do ((q (make-linked-queue))
               (tail seq (rest tail))
               (i 0 (1+ i)))
              ((or (= i n) (endp tail)) (values (elements q) tail))
            (enqueue q (first tail))))
    (vector (values (take n seq) (drop n seq)))) ) ; Works for strings too

(defun emptyp (seq)
  (typecase seq
    (list (null seq))
    (vector (zerop (length seq)))) )

(defun group (seq n)
  (loop for (take drop) =      (multiple-value-list (take-drop n seq))
                          then (multiple-value-list (take-drop n drop))
        until (emptyp take)
        collect take))

Graham's version is quite a bit faster than mine!
(let ((l (loop for i from 1 to 10000 collect i)))
  (time (loop repeat 10000 do (group l 10))))
Evaluation took:
  0.296 seconds of real time
  0.296443 seconds of total run time (0.292585 user, 0.003858 system)
  [ Run times consist of 0.028 seconds GC time, and 0.269 seconds non-GC time. ]
  100.00% CPU
  948,581,367 processor cycles
  1,758,406,496 bytes consed

(let ((l (loop for i from 1 to 10000 collect i)))
  (time (loop repeat 10000 do (group l 10))))
Evaluation took:
  2.072 seconds of real time
  2.072825 seconds of total run time (2.068832 user, 0.003993 system)
  [ Run times consist of 0.047 seconds GC time, and 2.026 seconds non-GC time. ]
  100.05% CPU
  6,606,210,198 processor cycles
  2,400,649,232 bytes consed
  
Furthermore, his version does not handle vectors/strings at all, but mine is _much_ slower for vectors:  
(let ((l (coerce (loop for i from 1 to 10000 collect i) 'vector)))
  (time (loop repeat 10000 do (group l 10))))
Evaluation took:
  57.417 seconds of real time
  57.120416 seconds of total run time (55.012079 user, 2.108337 system)
  [ Run times consist of 6.791 seconds GC time, and 50.330 seconds non-GC time. ]
  99.48% CPU
  183,006,234,734 processor cycles
  400,644,938,192 bytes consed


More competitive with Graham:
(defun take-drop (n seq)
  "Split a sequence at the Nth element. Return the subsequences before and after."
  (assert (typep n `(integer 0))
          (n)
          "N must be a non-negative integer.")
  (typecase seq
    (list (do ((tail seq (rest tail))
               (i 0 (1+ i)))
              ((or (= i n) (endp tail)) (values (subseq seq 0 i) tail))))
    (vector (values (take n seq) (drop n seq)))) ) ; Works for strings too

(let ((l (loop for i from 1 to 10000 collect i)))
  (time (loop repeat 10000 do (group l 10))))
Evaluation took:
  0.456 seconds of real time
  0.459321 seconds of total run time (0.455205 user, 0.004116 system)
  [ Run times consist of 0.037 seconds GC time, and 0.423 seconds non-GC time. ]
  100.66% CPU
  1,464,684,868 processor cycles
  1,759,999,248 bytes consed
  
NIL
----------------------------------------------------------------------------
PRUNE elements (atoms) from a tree vs. REMOVE-IF for sequences
(prune #'evenp '(1 2 (3 (4 5) 6) 7 8 (9))) => (1 (3 (5)) 7 (9))
(remove-if #'evenp '(1 2 3 4 5 6 7 8 9)) => (1 3 5 7 9)

Graham gets the names wrong:
- PRUNE        -> REMOVE
- PRUNE-IF     -> REMOVE-IF
- PRUNE-IF-NOT -> REMOVE-IF-NOT

His PRUNE (Should be PRUNE-IF):
(defun prune (test tree)
  (labels ((rec (tree acc)
             (cond ((null tree) (nreverse acc))
                   ((consp (car tree))
                    (rec (cdr tree) 
                         (cons (rec (car tree) nil) acc))) ; Not tail-recursive!
                   (t (rec (cdr tree)
                           (if (funcall test (car tree)) ; CAR is not a CONS here.
                               acc
                               (cons (car tree) acc)))))))
    (rec tree nil)))

My redo:
- ITEM to be pruned is passed in (not TEST. See PRUNE-IF below.)
- Why does Graham use accumulator? Not tail-recursive!
- PRUNE:REMOVE::COPY-TREE:COPY-LIST
(defun prune (item tree)
  (cond ;((null tree) '())
        ((atom tree) tree)
        ((atom (first tree)) (if (eql (first tree) item)
                                 (prune item (rest tree))
                                 (cons (first tree) (prune item (rest tree)))) )
        (t (cons (prune item (first tree))
                 (prune item (rest tree)))) ))

(defun copy-tree (tree)
  (cond ((atom tree) tree)
        (t (cons (copy-tree (first tree))
                 (copy-tree (rest tree)))) ))

(defun prune (item tree)
  (cond ((atom tree) tree)
        ((eql (first tree) item) (prune item (rest tree))) ; Fails with different test
        (t (cons (prune item (first tree))
                 (prune item (rest tree)))) ))

(defun copy-list (list)
  (cond ((atom list) list) ; Handles dotted list
        (t (cons (first list) (copy-list (rest list)))) ))

(defun remove (item list)
  (cond ((atom list) list)
        ((eql item (first list)) (remove item (rest list))) ; Fails with different test
        (t (cons (first list) (remove item (rest list)))) ))

More complex 2nd clause for arbitrary test:
(defun prune (item tree &key (test #'eql) (key #'identity))
  (cond ((atom tree) tree)
        ((and (atom (first tree)) (funcall test item (funcall key (first tree))))
         (prune item (rest tree) :test test :key key))
        (t (cons (prune item (first tree) :test test :key key)
                 (prune item (rest tree) :test test :key key))) ))

Graham style:
(defun prune (item tree &key (test #'eql) (key #'identity))
  "Remove all instances of the atom ITEM from TREE."
  (labels ((prune-aux (tree result)
	     (cond ((null tree) (nreverse result))
                   (t (destructuring-bind (car . cdr) tree
                        (cond ((and (atom car) (funcall test item (funcall key car))) (prune-aux cdr result))
                              ((atom car) (prune-aux cdr (cons car result)))
                              (t (prune-aux cdr (cons (prune-aux car '()) result)))) )))) )
    (prune-aux tree '())))

PRUNE-IF involves a predicate arg as does REMOVE-IF:
(defun prune-if (pred tree)
  "Remove all leaves of TREE for which PRED is true."
  (labels ((prune-aux (tree result)
	     (cond ((null tree) (nreverse result))
                   (t (destructuring-bind (car . cdr) tree
                        (cond ((and (atom car) (funcall pred car)) (prune-aux cdr result))
                              ((atom car) (prune-aux cdr (cons car result)))
                              (t (prune-aux cdr (cons (prune-aux car '()) result)))) )))) )
    (prune-aux tree '())))

Simply invert the predicate:
(defun prune-if-not (pred tree)
  "Remove all leaves of TREE for which PRED is not true."
  (prune-if (complement pred) tree))


(prune :a '(:b :a (:c (:a :d) :e) :g :a (:h :a)))
(:B (:C (:D) :E) :G (:H))
(prune-if #'(lambda (elt) (< elt 4)) '(1 2 (3 (4 5) 6) 7 8 (9)))
(((4 5) 6) 7 8 (9))
(prune-if (partial* #'< 4) '(1 2 (3 (4 5) 6) 7 8 (9)))
(((4 5) 6) 7 8 (9))

(< 4 ?)
     ^--- PARTIAL
(< ? 4)
   ^----- PARTIAL*

(prune-if-not #'evenp '(1 2 (3 (4 5) 6) 7 8 (9)))
(2 ((4) 6) 8 NIL)
(prune-if #'oddp '(1 2 (3 (4 5) 6) 7 8 (9)))
(2 ((4) 6) 8 NIL)
----------------------------------------------------------------------------
240902 月
:TEST vs. :KEY
Wrong way
(defgeneric before (x y seq &key test)
  (:documentation  "Does X occur before Y in SEQ?"))
(defmethod before (x y (seq list) &key (test #'eql))
  (loop for cons on seq
        for elt = (first cons)
        when (funcall test y elt) return nil
        when (funcall test x elt) return cons))

(equal '((:A 9) (:E 5) (:B -6))
       (before :a :b '((:d 7) (:c 12) (:a 9) (:e 5) (:b -6))
               :test #'(lambda (x elt) (eq x (first elt)))) )

x = y???

Right way
(defgeneric before (x y seq &key test key)
  (:documentation  "Does X occur before Y in SEQ?"))
(defmethod before (x y (seq list) &key (test #'eql) (key #'identity))
  (if (funcall test x y)
      nil
      (loop for cons on seq
            for elt = (first cons)
            when (funcall test y (funcall key elt)) return nil
            when (funcall test x (funcall key elt)) return cons)))

(equal '((:B -6))
       (after :b :a '((:d 7) (:c 12) (:a 9) (:e 5) (:b -6)) :key #'first))
----------------------------------------------------------------------------
Case study: Birth of a utility

Tanimoto exercise: Define a function (EQUALELTS LST) that returns T if and only if all the top-level elements of LST are EQUAL to each other.

- EQUAL is a binary function. We want to generalize it to an arbitrary number of elements.
Essentially we want to augment EQUAL so that it behaves like =:
(equal '(a b) '(a b)) => T
(= 1 (- 3 2) (/ 8 8) (+ 1/2 1/2)) => T

One common pattern is to take a binary function and then employ REDUCE to extend it.

Example: Haskell has `max` and `maximum` functions
max 8 9
9
maximum [9, 2, 11, 5, 17]
17

Common Lisp only has the function MAX, but it is simple to employ it with a sequence:
(reduce #'max '(9 2 11 5 17)) => 17

In fact, MAX already supports an arbitrary number of args, so we can just APPLY it to a list:
(apply #'max '(9 2 11 5 17)) => 17

But suppose that + only took 2 args:
(+ 2 3) => 5

We could use REDUCE to operate pairwise on an arbitrary list:
(reduce #'+ '(8 9 4 7 2 1 6)) => 37

The problem is that + is a different kind of function than EQUAL:
+: ℝ ⨯ ℝ -> ℝ
In other words, the result of the function is the same type as the inputs.

However,
EQUAL: T ⨯ T -> 𝔹
where 𝔹 = {t, nil}

So REDUCE can feed the result of + back in as part of the next pair. Not so with EQUAL:
(+ (+ (+ (+ (+ (+ 8 9) 4) 7) 2) 1) 6)

(reduce #'equal '(a a a)) => NIL
(equal (equal 'a 'a) 'a), i.e., (equal t 'a) doesn't make any sense...

But it's easy enough to use normal list-processing techniques to handle EQUALELTS.

Experiments:
(defun equalelts (l)
  (if (null l)
      t
      (destructuring-bind (x . xs) l
        (if (null xs)
            t
            (destructuring-bind (y . ys) xs
              (and (equal x y)
                   (or (null ys)
                       (equalelts xs)))) ))))

(defun equalelts (l)
  (cond ((null l) t)
        ((singlep l) t)
        (t (and (equal (first l) (second l))
                (equalelts (rest l)))) ))

(defun equalelts (l)
  (or (null l)
      (singlep l)
      (and (equal (first l) (second l))
           (equalelts (rest l)))) )

(defun equalelts (l &key (test #'equal))
  (or (null l)
      (destructuring-bind (x . more) l
        (every #'(lambda (elt) (funcall test elt x)) more))))

The final example above hints at two obvious improvements to Tanimoto's spec:
1. Handle sequences (vectors, strings) rather than simply lists.
2. Allow for different notions of equality: =, char=, string-equal

The second issue is already handled by the keyword argument :TEST specified in the final EQUALELTS definition. This allows us to do things like this:
(equalelts '(1.0 1 1d0)) => NIL ; Different numeric types are not EQUAL
(equalelts '(1.0 1 1d0) :test #'=) => T ; But they are all numerically =

(equalelts '("pung" "PUNG" "pUnG" "PunG")) => NIL
(equalelts '("pung" "PUNG" "pUnG" "PunG") :test #'string=) => NIL
(equalelts '("pung" "PUNG" "pUnG" "PunG") :test #'string-equal) => T ; Case-insensitive compare

This last function uses EVERY instead of REDUCE. We pull the first element of the list out and then check that every other element is equal to it. We have to check for an empty list first, but EVERY works in all other cases. This includes the case of a singleton list where MORE is empty.

The good news is that EVERY is actually a sequence function. We can apply it to vectors and strings as well:
(every #'evenp #(2 4 6 8)) => T
(every #'digit-char-p "132412") => T

The only problem is that we can't use DESTRUCTURING-BIND to pull out the first element of these other types of sequences. However, I do have a library function that can do the job.

Many other functional programming languages have TAKE and DROP functions:
(take 5 '(a b c d e f g h i j k l m)) => (A B C D E)
(drop 8 '(a b c d e f g h i j k l m)) => (I J K L M)
(take 5 #(a b c d e f g h i j k l m)) => #(A B C D E)
(drop 8 "Is this not pung?") => "not pung?"

These aren't part of Common Lisp, but they are easy enough to define:
(defgeneric drop (n seq)
  (:documentation "Drop the first N elements of sequence SEQ."))
(defmethod drop (n (seq list))
  (nthcdr n seq))
(defmethod drop (n (seq vector))
 (subseq seq (min n (length seq))))

(defgeneric take (n seq)
  (:documentation "Take the first N elements of sequence SEQ."))
(defmethod take (n (seq list))
  (loop repeat n for elt in seq collect elt))
(defmethod take (n (seq vector))
  (subseq seq 0 (min n (length seq))))

And then it's only one step further to bolt them together: TAKE-DROP
(defgeneric take-drop (n seq)
  (:documentation "Split a sequence at the Nth element. Return the subsequences before and after."))
(defmethod take-drop :around (n seq)
  (assert (typep n `(integer 0))
          (n)
          "N must be a non-negative integer.")
  (call-next-method))
(defmethod take-drop (n (seq list))
  (do ((tail seq (rest tail))
       (i 0 (1+ i)))
      ((or (= i n) (endp tail)) (values (subseq seq 0 i) tail))))
(defmethod take-drop (n (seq vector))
  (values (take n seq) (drop n seq))) ; Works for strings too

(take-drop 5 '(a b c d e f g h i j k l m))
(A B C D E)
(F G H I J K L M)
(take-drop 8 #(a b c d e f g h i j k l m))
#(A B C D E F G H)
#(I J K L M)
(take-drop 8 "Is this not pung?")
"Is this "
"not pung?"

Now we see how to split any sequence into its first element and then all of the rest:
(take-drop 1 '(1 2 3 4))
(1)
(2 3 4)
(take-drop 1 #(1 2 3 4))
#(1)
#(2 3 4)
(take-drop 1 "1234")
"1"
"234"

(defun emptyp (seq) ; A helper function
  (typecase seq
    (list (null seq))
    (vector (zerop (length seq)))) )

(defun equalelts (seq &key (test #'equal))
  (or (emptyp seq)
      (multiple-value-bind (x more) (take-drop 1 seq)
        (every (partial test (elt x 0)) more))))

(equalelts #(a a a)) => T
(equalelts "aaaaaaaaa") => T
(equalelts "aaaAaAAaa") => NIL
(equalelts "aaaAaAAaa" :test #'char-equal) => T

Finally, we might consider a more subtle type of equality for objects that may not be strictly equal, but maybe parts of them are. Many Common Lisp sequence functions take a :KEY argument that is applied to an element before the :TEST:
(equalelts '((a . 1) (a . 2) (a . 1) (a . 4))) => NIL
(equalelts '((a . 1) (a . 2) (a . 1) (a . 4)) :key #'first) => T

Final version!
[This makes the comparison function a little more complicated.]
(defun equalelts (seq &key (test #'equal) (key #'identity))
  (or (emptyp seq)
      (multiple-value-bind (take drop) (take-drop 1 seq)
        (let ((exemplar (elt take 0)))
          (every #'(lambda (elt)
                     (funcall test (funcall key exemplar)
                                   (funcall key elt)))
                 drop)))) )

Are Ramones equal?
(defclass person ()
  ((first-name :reader first-name :initarg :first)
   (last-name :reader last-name :initarg :last)))

(defmethod print-object ((p person) stream)
  (print-unreadable-object (p stream :type t)
    (format t "~A, ~A" (last-name p) (first-name p))))

(defclass ramone (person) ())

(defmethod initialize-instance :after ((r ramone) &rest initargs)
  (declare (ignore initargs))
  (with-slots (last-name) r
    (setf last-name "Ramone")))

(defvar *andy* (make-instance 'person :first "Andy" :last "Warhol"))
*andy* => #<PERSON Warhol, Andy>

(defvar *joey* (make-instance 'ramone :first "Joey"))
*joey* => #<RAMONE Ramone, Joey>
(defvar *dee-dee* (make-instance 'ramone :first "Dee Dee"))
(defvar *tommy* (make-instance 'ramone :first "Tommy"))
(defvar *johnny* (make-instance 'ramone :first "Johnny"))

(equalelts (list *joey* *dee-dee* *tommy* *johnny*)) => NIL
(equalelts (list *joey* *dee-dee* *tommy* *johnny*) :key #'last-name) => T

Equivalence classes:
(equalelts '(1 4 7 10 13)) =>NIL
(equalelts '(1 4 7 10 13) :key (partial* #'mod 3)) => T

Final final version!
(defun equalelts (seq &key (test #'equal) (key #'identity))
  "Are all elements of SEQ equal with respect to TEST after applying KEY?"
  (or (emptyp seq)
      (multiple-value-bind (head tail) (take-drop 1 seq)
        (let ((exemplar (funcall key (elt head 0))))
          (every (compose (partial* test exemplar) key) tail)))) )

An alternative take using generic functions (MISMATCH almost does what we want...)
(defgeneric equalelts (seq &key test key)
  (:documentation "Are all elements of SEQ equal with respect to TEST after applying KEY?"))
(defmethod equalelts ((seq null) &key test key)
  (declare (ignore seq test key))
  t)
(defmethod equalelts ((seq list) &key (test #'equal) (key #'identity))
  (every #'(lambda (x y) (funcall test (funcall key x) (funcall key y))) seq (rest seq)))
(defmethod equalelts ((seq vector) &key (test #'equal) (key #'identity))
  (not (mismatch seq seq :start1 1 :end2 (1- (length seq)) :key key :test test)))

Application: Poker hand
(defun flushp (hand)
  (if (= (length hand) 5)
      (equalelts hand :key #'suit)
      nil))

One last attempt:
(defgeneric equalelts (seq &key test key)
  (:documentation "Are all elements of SEQ equal with respect to TEST after applying KEY?"))
(defmethod equalelts :around (seq &key test key)
  (declare (ignore test key))
  (or (emptyp seq)
      (call-next-method)))
(defmethod equalelts ((seq list) &key (test #'equal) (key #'identity))
  (loop for elt in seq
        with exemplar = (funcall key (elt seq 0))
        always (funcall test exemplar (funcall key elt))))
(defmethod equalelts ((seq vector) &key (test #'equal) (key #'identity))
  (loop for elt across seq
        with exemplar = (funcall key (elt seq 0))
        always (funcall test exemplar (funcall key elt))))

The significant difference is that this version doesn't copy any of the sequence in question as the earlier version did (with the TAKE-DROP). So this should be more efficient.

The less significant differences:
• It uses generic functions to handle lists and vectors.
    This allows us to put an :AROUND method in front of
    the specific implementations to handle the empty sequence case.
• These use some fancy LOOP magic with the ALWAYS clause.
    It does bug me that the 2 implementations are identical
    save for the keyword needed to traverse specific sequence types
    (IN vs. ACROSS)...

(One subtle difference here is that these versions perform a redundant comparison of the first element with itself. That was the whole point of the TAKE-DROP, to pull one element out as the exemplar.)
----------------------------------------------------------------------------
241009 水
Case study: MOST/BEST/MOSTN

In §4.4 Graham defines several functions for searching lists. He introduces 3 functions that
look for extreme values in a list: MOST/BEST/MOSTN

In his words, MOST:
    It takes a list and a scoring function, and returns the element with the highest score.
    In case of ties, the element occurring first wins. For convenience, most also returns the
    score of the winner.

(most #'length '((a b) (a b c) (a) (e f g))) => (A B C); 3
(most #'abs '(-9 8 -7 3 25 0 -28)) => -28; 28

He describes BEST this way:
    This utility also takes a function and a list, but here the function must be
    a predicate of two arguments. It returns the element which, according to the
    predicate, beats all the others. We can think of best as being equivalent to
    car of sort, but much more efficient. As before, in case of ties, the first
    element wins.

(best #'> '(1 2 3 4 5)) => 5
(best #'< '(1 2 3 4 5)) => 1
(best #'char> "Is this not pung?") => #\u

Finally MOSTN is an extension of MOST:
    mostn takes a function and a list and returns a list of all the elements     
    for which the function yields the highest score (along with the score itself).

(mostn #'length '((a b) (a b c) (a) (e f g))) => ((A B C) (E F G)); 3
(mostn #'abs #(-9 8 -7 3 25 28 0 -28))) => (28 -28); 28

His implementations (slightly updated):
(defun most (fn lst)
  (if (null lst)
      (values nil nil)
      (let* ((wins (first lst))
             (max (funcall fn wins)))
        (dolist (obj (rest lst) (values wins max))
          (let ((score (funcall fn obj)))
            (when (> score max)
              (setf wins obj
                    max score)))) )))

(defun best (fn lst)
  (if (null lst)
      nil
      (let ((wins (first lst)))
        (dolist (obj (rest lst) wins)
          (when (funcall fn obj wins)
            (setq wins obj)))) ))

(defun mostn (fn lst)
  (if (null lst)
      (values nil nil)
      (let ((result (list (first lst)))
            (max (funcall fn (first lst))))
        (dolist (obj (rest lst) (values (nreverse result) max))
          (let ((score (funcall fn obj)))
            (cond ((> score max) (setf max score
                                       result (list obj)))
                  ((= score max) (push obj result)))) ))))

His versions work, but there are some obvious improvements:
• What about vectors? These just work on lists.
• What about LEAST and WORST?
• Why not capture MOST and LEAST or BEST and WORST at the same time? MOST-LEAST/BEST-WORST
• What about multiple MOST-LEAST or BEST-WORST values? MOST-LEAST-N/BEST-WORST-N
• What is the underlying similarity of MOST and BEST? Can it be refactored?

I. Handle vectors too
- Unfortunate code duplication due to LOOP semantics
(defun most (f seq)
  (if (emptyp seq)
      (values nil nil)
      (typecase seq
        (list (loop with winner = (first seq)
                    with max = (funcall f winner)
                    for elt in (rest seq)
                    for score = (funcall f elt)
                    when (> score max) do (setf winner elt max score)
                    finally (return (values winner max))))
        (vector (loop with winner = (elt seq 0)
                      with max = (funcall f winner)
                      for i from 1 below (length seq)
                      for elt = (elt seq i)
                      for score = (funcall f elt)
                      when (> score max) do (setf winner elt max score)
                      finally (return (values winner max)))) )))

II. Grab the LEAST value too along the way
(defun most-least (f seq)
  (if (emptyp seq)
      nil
      (typecase seq
        (list (loop with winner = (first seq)
                    with loser = winner
                    with max = (funcall f winner)
                    with min = max
                    for elt in (rest seq)
                    for score = (funcall f elt)
                    when (> score max) do (setf winner elt max score)
                    else when (< score min) do (setf loser elt min score)
                    finally (return (values winner max loser min))))
        (vector (loop with winner = (elt seq 0)
                      with loser = winner
                      with max = (funcall f winner)
                      with min = max
                      for i from 1 below (length seq)
                      for elt = (elt seq i)
                      for score = (funcall f elt)
                      when (> score max) do (setf winner elt max score)
                      else when (< score min) do (setf loser elt min score)
                      finally (return (values winner max loser min)))) )))

III. MOSTN -> MOST-LEAST-N
- MOSTN reimplemented
(defun mostn (f seq)
  (if (emptyp seq)
      nil
      (typecase seq
        (list (loop with winners = (make-linked-queue)
                    with max = (funcall f (first seq))
                    for elt in seq
                    for score = (funcall f elt)
                    if (= score max)
                      do (enqueue winners elt)
                    else if (> score max)
                      do (make-empty winners)
                         (enqueue winners elt)
                         (setf max score)
                    end
                    finally (return (values (elements winners) max))))
        (vector (loop with winners = (make-linked-queue)
                      with max = (funcall f (elt seq 0))
                      for elt across seq
                      for score = (funcall f elt)
                      if (= score max)
                        do (enqueue winners elt)
                      else if (> score max)
                        do (make-empty winners)
                           (enqueue winners elt)
                           (setf max score)
                      end
                      finally (return (values (elements winners) max)))) )))

(defun most-least-n (f seq)
  (if (emptyp seq)
      nil
      (typecase seq
        (list (loop with winners = (make-linked-queue)
                    with losers = (make-linked-queue)
                    with max = (funcall f (first seq))
                    with min = max
                    for elt in seq
                    for score = (funcall f elt)
                    if (= score max)
                      do (enqueue winners elt)
                    else if (> score max)
                      do (make-empty winners)
                         (enqueue winners elt)
                         (setf max score)
                    end
                    if (= score min)
                      do (enqueue losers elt)
                    else if (< score min)
                      do (make-empty losers)
                         (enqueue losers elt)
                         (setf min score)
                    end
                    finally (return (values (elements winners) max (elements losers) min))))
        (vector (loop with winners = (make-linked-queue)
                      with losers = (make-linked-queue)
                      with max = (funcall f (elt seq 0))
                      with min = max
                      for elt across seq
                      for score = (funcall f elt)
                      if (= score max)
                        do (enqueue winners elt)
                      else if (> score max)
                        do (make-empty winners)
                           (enqueue winners elt)
                           (setf max score)
                      end
                      if (= score min)
                        do (enqueue losers elt)
                      else if (< score min)
                        do (make-empty losers)
                           (enqueue losers elt)
                           (setf min score)
                      end
                      finally (return (values (elements winners) max (elements losers) min)))) )))

IV. Refactor!
- MOST and LEAST are pretty much the same just opposite order
(defgeneric extremum (f order seq)
  (:documentation "Locate the first element in SEQ that yields the extreme (in terms of ORDER) value when F is applied. The secondary value is the value returned by F for that element."))
(defmethod extremum :around (f order seq)
  (if (emptyp seq)
      (values nil nil)
      (call-next-method)))
(defmethod extremum (f order (seq list))
 (loop with winner = (first seq)
       with max = (funcall f winner)
       for elt in (rest seq)
       for score = (funcall f elt)
       when (funcall order score max) do (setf winner elt max score)
       finally (return (values winner max))))
(defmethod extremum (f order (seq vector))
  (loop with winner = (elt seq 0)
        with max = (funcall f winner)
        for i from 1 below (length seq)
        for elt = (elt seq i)
        for score = (funcall f elt)
        when (funcall order score max) do (setf winner elt max score)
        finally (return (values winner max))))

(defun most (f seq)
  (extremum f #'> seq))
(defun least (f seq)
  (extremum f #'< seq))

V. All of the MOST/LEAST functions:
- The documentation is incorrect.
  ORDER no longer matters since we always grab both the highs and lows.
(defgeneric extrema (f order seq)
  (:documentation "Locate the elements in SEQ that yield the extreme (in terms of ORDER) values both high and low when F is applied. The secondary values are the extreme values returned by F for those elements."))
(defmethod extrema :around (f order seq)  ; <-------    Mistake! ORDER not actually used anymore
  (if (emptyp seq)
      (values nil nil nil nil)
      (call-next-method)))
(defmethod extrema (f order (seq list))
 (loop with winners = (make-linked-queue)
       with losers = (make-linked-queue)
       with max = (funcall f (first seq))
       with min = max
       for elt in seq
       for score = (funcall f elt)
       if (= score max)
         do (enqueue winners elt)
       else if (> score max)
         do (make-empty winners)
            (enqueue winners elt)
            (setf max score)
       end
       if (= score min)
         do (enqueue losers elt)
       else if (< score min)
         do (make-empty losers)
            (enqueue losers elt)
            (setf min score)
       end
       finally (return (values (elements winners) max (elements losers) min))))
(defmethod extrema (f order (seq vector))
  (loop with winners = (make-linked-queue)
        with losers = (make-linked-queue)
        with max = (funcall f (elt seq 0))
        with min = max
        for elt across seq
        for score = (funcall f elt)
        if (= score max)
          do (enqueue winners elt)
        else if (> score max)
          do (make-empty winners)
             (enqueue winners elt)
             (setf max score)
        end
        if (= score min)
          do (enqueue losers elt)
        else if (< score min)
          do (make-empty losers)
             (enqueue losers elt)
             (setf min score)
        end
        finally (return (values (elements winners) max (elements losers) min))))

These should all be defined in terms of MOST-LEAST-N rather than calling EXTREMA directly.
See final refactor in section VI.
(defun most (f seq)
  (multiple-value-bind (winners max) (extrema f #'> seq)
    (values (first winners) max)))
(defun least (f seq)
  (multiple-value-bind (winners max losers min) (extrema f #'< seq)
    (declare (ignore winners max))
    (values (first losers) min)))
(defun most-least (f seq)
  (multiple-value-bind (winners max losers min) (extrema f #'> seq)
    (values (first winners) max (first losers) min)))

(defun mostn (f seq)
  (multiple-value-bind (winners max) (extrema f #'> seq)
    (values winners max)))
(defun leastn (f seq)
  (multiple-value-bind (winners max losers min) (extrema f #'< seq)
    (declare (ignore winners max))
    (values losers min)))
(defun most-least-n (f seq)
  (extrema f #'> seq))

VI. What about BEST?
Nice simple definition for BEST. Unfortunately it is not easily integrated with the
refactoring below.
(defun best (f seq)
  "Return the first element as if the elements of SEQ were sorted by means of F."
  (labels ((a-vs-b (b a)
             (if (funcall f a b) a b)))
    (if (emptyp seq)
        nil
        (reduce #'a-vs-b seq))))


MOST vs. BEST
These 2 functions seem to serve a similar role:
(most #'length '((a b) (a b c) (a) (e f g)))
(A B C)
3
(best #'> (mapcar #'length '((a b) (a b c) (a) (e f g))))
3

(best #'> '(1 2 3 4 5))
5
(best #'> (mapcar #'identity '(1 2 3 4 5)))
5

MOST applies a "key" to each element before ordering them.
BEST applies a "test" to determine the ordering of elts.

Complete refactor. Everything is defined in terms of EXTREMA methods. They
capture all of the high/low values plus the corresponding "scores".
All of the specific functions simply extract the parts they need from these results.

(defgeneric extrema (seq &key test key)
  (:documentation "Locate the elements in SEQ that yield the extreme (in terms of TEST) values both high and low when KEY is applied. The secondary values are the extreme values returned by KEY for those elements."))
(defmethod extrema :around (seq &key test key)
  (if (emptyp seq)
      (values nil nil nil nil)
      (call-next-method)))
(defmethod extrema ((seq list) &key (test #'>) (key #'identity))
  (loop with winners = (make-linked-queue)
        with losers = (make-linked-queue)
        with max = (funcall key (first seq))
        with min = max
        for elt in seq
        for score = (funcall key elt)
        if (funcall test score max)
          do (make-empty winners)
             (enqueue winners elt)
             (setf max score)
        else if (not (funcall test max score))
          do (enqueue winners elt)
        end
        if (funcall test min score)
          do (make-empty losers)
             (enqueue losers elt)
             (setf min score)
        else if (not (funcall test score min))
          do (enqueue losers elt)
        end
        finally (return (values (elements winners) max (elements losers) min))))
(defmethod extrema ((seq vector) &key (test #'>) (key #'identity))
  (loop with winners = (make-linked-queue)
        with losers = (make-linked-queue)
        with max = (funcall key (elt seq 0))
        with min = max
        for elt across seq
        for score = (funcall key elt)
        if (funcall test score max)
          do (make-empty winners)
             (enqueue winners elt)
             (setf max score)
        else if (not (funcall test max score))
          do (enqueue winners elt)
        end
        if (funcall test min score)
          do (make-empty losers)
             (enqueue losers elt)
             (setf min score)
        else if (not (funcall test score min))
          do (enqueue losers elt)
        end
        finally (return (values (elements winners) max (elements losers) min))))

All of the MOST/LEAST functions derived from MOST-LEAST-N:
- This cares about the KEY but not the TEST
(defun most-least-n (f seq)
  (extrema seq :key f))

(defun most (f seq)
  (multiple-value-bind (winners max) (most-least-n f seq)
    (values (first winners) max)))
(defun least (f seq)
  (multiple-value-bind (winners max losers min) (most-least-n f seq)
    (declare (ignore winners max))
    (values (first losers) min)))
(defun most-least (f seq)
  (multiple-value-bind (winners max losers min) (most-least-n f seq)
    (values (first winners) max (first losers) min)))

(defun mostn (f seq)
  (multiple-value-bind (winners max) (most-least-n f seq)
    (values winners max)))
(defun leastn (f seq)
  (multiple-value-bind (winners max losers min) (most-least-n f seq)
    (declare (ignore winners max))
    (values losers min)))

All of the BEST/WORST functions derived from BEST-WORST-N:
- This cares about the TEST but not the KEY
(defun best-worst-n (f seq)
  (multiple-value-bind (winners max losers min) (extrema seq :test f)
    (declare (ignore max min))
    (values winners losers)))

(defun best (f seq)
  (multiple-value-bind (winners) (best-worst-n f seq)
    (first winners)))
(defun worst (f seq)
  (multiple-value-bind (winners losers) (best-worst-n f seq)
    (declare (ignore winners))
    (first losers)))
(defun best-worst (f seq)
  (multiple-value-bind (winners losers) (best-worst-n f seq)
    (values (first winners) (first losers))))

(defun bestn (f seq)
  (multiple-value-bind (winners) (best-worst-n f seq)
    winners))
(defun worstn (f seq)
  (multiple-value-bind (winners losers) (best-worst-n f seq)
    (declare (ignore winners))
    losers))
-------------------------------------------
Experiments with REDUCE.
I. Lost of CONSing. RESULT is built and destructured for each elt
(defun extrema (seq &key (test #'>) (key #'identity))
  (if (emptyp seq)
      (values nil nil nil nil)
      (let* ((winners (make-linked-queue))
             (losers (make-linked-queue))
             (max (funcall key (elt seq 0)))
             (min max))
        (destructuring-bind (winners max losers min)
            (reduce #'(lambda (result elt)
                        (destructuring-bind (winners max losers min) result
                          (let ((score (funcall key elt)))
                            (cond ((funcall test score max)
                                   (make-empty winners)
                                   (enqueue winners elt)
                                   (setf max score))
                                  ((not (funcall test max score))
                                   (enqueue winners elt)))
                            (cond ((funcall test min score)
                                   (make-empty losers)
                                   (enqueue losers elt)
                                   (setf min score))
                                  ((not (funcall test score min))
                                   (enqueue losers elt))))
                          (list winners max losers min)))
                    seq
                    :initial-value (list winners max losers min))
          (values (elements winners) max (elements losers) min)))) )

II. Use reduction function for side effect rather than value
- This is the style used in Graham's original implementations but with
  DOLIST rather than REDUCE.
(defun extrema (seq &key (test #'>) (key #'identity))
  (if (emptyp seq)
      (values nil nil nil nil)
      (let* ((winners (make-linked-queue))
             (losers (make-linked-queue))
             (max (funcall key (elt seq 0)))
             (min max))
        (reduce #'(lambda (_ elt) ; Don't care about first arg
                    (let ((score (funcall key elt)))
                      (cond ((funcall test score max)
                             (make-empty winners)
                             (enqueue winners elt)
                             (setf max score))
                            ((not (funcall test max score))
                             (enqueue winners elt)))
                      (cond ((funcall test min score)
                             (make-empty losers)
                             (enqueue losers elt)
                             (setf min score))
                            ((not (funcall test score min))
                             (enqueue losers elt)))) ) ; Value returned is irrelevant
                seq
                :initial-value :foo) ; Irrelevant (but necessary) initial value
        (values (elements winners) max (elements losers) min))))

III. Outsource the logic to a separate class
(defclass scorer ()
  ((winners :initform (make-linked-queue))
   (max)
   (losers :initform (make-linked-queue))
   (min)))

(defun make-scorer (initial)
  (let ((scorer (make-instance 'scorer)))
    (with-slots (min max) scorer
      (setf max initial
            min initial))
    scorer))

(defun update (scorer elt &key test key)
  (let ((score (funcall key elt)))
    (with-slots (winners max losers min) scorer
      (cond ((funcall test score max)
             (make-empty winners)
             (enqueue winners elt)
             (setf max score))
            ((not (funcall test max score))
             (enqueue winners elt)))
      (cond ((funcall test min score)
             (make-empty losers)
             (enqueue losers elt)
             (setf min score))
            ((not (funcall test score min))
             (enqueue losers elt)))) ))

(defun results (scorer)
  (with-slots (winners max losers min) scorer
    (values (elements winners) max (elements losers) min)))

(defun extrema (seq &key (test #'>) (key #'identity))
  (if (emptyp seq)
      (values nil nil nil nil)
      (results (reduce #'(lambda (scorer elt)
                           (update scorer elt :test test :key key)
                           scorer)
                       seq
                       :initial-value (make-scorer (funcall key (elt seq 0)))) )))
-------------------------------------------
Using a generator for lists/vectors. Consolidates LOOP for single EXTREMA function.

(defclass generator () ())
(defclass list-generator (generator)
  ((contents :initarg :contents)))
(defclass vector-generator (generator)
  ((contents :initarg :contents)
   (index :initform 0)))

(defgeneric exhaustedp (generator)
  (:documentation "Has every element of a generator's sequence been consumed?"))
(defmethod exhaustedp ((g list-generator))
  (with-slots (contents) g
    (null contents)))
(defmethod exhaustedp ((g vector-generator))
  (with-slots (contents index) g
    (= index (length contents))))

(defgeneric current (generator)
  (:documentation "Retrieve current element of the generator's sequence."))
(defmethod current :around ((g generator))
  (if (exhaustedp g)
      (error "The generator has been exhausted.")
      (call-next-method)))
(defmethod current ((g list-generator))
  (with-slots (contents) g
    (first contents)))
(defmethod current ((g vector-generator))
  (with-slots (contents index) g
    (elt contents index)))

(defgeneric next (generator)
  (:documentation "Retrieve current element of the generator's sequence and advance to next."))
(defmethod next :around ((g generator))
  (if (exhaustedp g)
      (error "The generator has been exhausted.")
      (call-next-method)))
(defmethod next ((g list-generator))
  (with-slots (contents) g
    (prog1 (current g)
      (setf contents (rest contents)))) )
(defmethod next ((g vector-generator))
  (with-slots (contents index) g
    (prog1 (current g)
      (incf index))))

(defun make-generator (seq)
  (etypecase seq
    (list (make-instance 'list-generator :contents seq))
    (vector (make-instance 'vector-generator :contents seq))))

(defun extrema (seq &key (test #'>) (key #'identity))
  (if (emptyp seq)
      (values nil nil nil nil)
      (let ((generator (make-generator seq)))
        (loop with winners = (make-linked-queue)
              with losers = (make-linked-queue)
              with max = (funcall key (current generator))
              with min = max
              for elt = (next generator)
              for score = (funcall key elt)
              if (funcall test score max)
                do (make-empty winners)
                   (enqueue winners elt)
                   (setf max score)
              else if (not (funcall test max score))
                do (enqueue winners elt)
              end
              if (funcall test min score)
                do (make-empty losers)
                   (enqueue losers elt)
                   (setf min score)
              else if (not (funcall test score min))
                do (enqueue losers elt)
              end
              until (exhaustedp generator)
              finally (return (values (elements winners) max (elements losers) min)))) ))
----------------------------------------------------------------------------
241023 水
§4.5 Mapping

Review
• List mapping functions
Granddaddy MAPCAR
Apply a function F to each element of a list, yielding a new function:
(mapcar #'1+ '(1 2 3 4 5)) => (2 3 4 5 6)
(mapcar #'char-upcase '(#\a #\b #\c)) => (#\A #\B #\C)

Works across multiple input lists:
(mapcar #'vector '(1 2 3 4 5) '(:p :q :r :s :t)) => (#(1 :P) #(2 :Q) #(3 :R) #(4 :S) #(5 :T))

Variations
MAPCAR sends the CAR of each CONS to F.
MAPLIST sends each CONS itself to F:
(maplist #'identity '(1 2 3 4 5)) => ((1 2 3 4 5) (2 3 4 5) (3 4 5) (4 5) (5))
MAPLIST is more fundamental. Don't really need MAPCAR:
(maplist #'(lambda (l) (1+ (first l))) '(1 2 3 4 5)) => (2 3 4 5 6)
(maplist (compose #'1+ #'first) '(1 2 3 4 5)) => (2 3 4 5 6)

(maplist #'(lambda (l) (char-upcase (first l))) '(#\a #\b #\c)) => (#\A #\B #\C)
(maplist (compose #'char-upcase #'first) '(#\a #\b #\c)) => (#\A #\B #\C)

LOOP analogs:
CARs
(loop for n in '(1 2 3 4 5) collect (1+ n)) => (2 3 4 5 6)
            ^^
CONSes
(loop for l on '(1 2 3 4 5) collect l) => ((1 2 3 4 5) (2 3 4 5) (3 4 5) (4 5) (5))
            ^^

MAPCAN/MAPCON correspond to MAPCAR/MAPLIST but expect results to be lists themselves.
Each result is concatenated into single final result list (destructively using NCONC):
(mapcar #'list '(1 2 3 4 5) '(:p :q :r :s :t)) => ((1 :P) (2 :Q) (3 :R) (4 :S) (5 :T))
(mapcan #'list '(1 2 3 4 5) '(:p :q :r :s :t)) => (1 :P 2 :Q 3 :R 4 :S 5 :T)

(maplist #'identity '(1 2 3 4 5)) => ((1 2 3 4 5) (2 3 4 5) (3 4 5) (4 5) (5))
(mapcon #'identity '(1 2 3 4 5)) ; Whoops! List surgery causes infinite loop...
(mapcon #'copy-list '(1 2 3 4 5)) => (1 2 3 4 5 2 3 4 5 3 4 5 4 5 5)

CLHS says:
(mapcan f x1 ... xn) ≡ (apply #'nconc (mapcar f x1 ... xn))
(mapcon f x1 ... xn) ≡ (apply #'nconc (maplist f x1 ... xn))

MAPC/MAPL also correspond to MAPCAR/MAPLIST but are used for side effects:
(mapc (compose #'write-char #'char-upcase) (coerce "Is this not pung?" 'list))
IS THIS NOT PUNG?  <-- Side effect
(#\I #\s #\  #\t #\h #\i #\s #\  #\n #\o #\t #\  #\p #\u #\n #\g #\?)  <-- Input is list is simply returned

Clearer?
(loop for ch across "Is this not pung?" do (write-char (char-upcase ch)))
(loop for ch in (coerce "Is this not pung?" 'list) do (write-char (char-upcase ch)))
IS THIS NOT PUNG?
NIL

CLHS example:
(defvar *dummy* '())
(mapl #'(lambda (x) (push x *dummy*)) '(1 2 3 4)) ; Push successive CONSes
*dummy* => ((4) (3 4) (2 3 4) (1 2 3 4))

• Sequence mapping functions
MAP like MAPCAR applies F to elts of 1+ sequences. Type of result sequence is given.
Works with mixed types of inpute sequences:
(map 'vector #'sqrt #(2 4 6 8)) => #(1.4142135 2.0 2.4494898 2.828427)
(map 'list #'sqrt #(2 4 6 8)) => (1.4142135 2.0 2.4494898 2.828427)
(map 'vector #'+ '(1 2 3 4) #(0 1 0 1)) => #(1 3 3 5)
(map 'list #'(lambda (ch n) (make-string n :initial-element ch)) "Cat" '(3 2 1)) => ("CCC" "aa" "t")

Omitting result type - MAP used for side effect only:
(map nil (compose #'print #'sqrt) '(2 4 6 8))

1.4142135                  <-- Output (side effect)
2.0 
2.4494898 
2.828427 
NIL                        <-- Result
-------------------------------------------
Graham's functions

What's wrong with this?
Apply FN to integers 1,...,10
Reader macro:
#[1 10] => (1 2 3 4 5 6 7 8 9 10)
(mapcar #'sqrt #[1 10]) => (1.0 1.4142135 1.7320508 2.0 2.236068 2.4494898 2.6457512 2.828427 3.0 3.1622777)

Graham (pg. 6):
(mapcar fn
        (do* ((x 1 (1+ x))
              (result (list x) (push x result)))
             ((= x 10) (nreverse result))))

The verbosity of Graham's example highlights the wasted work of building the input list (1 ... 10).
The function must build the result list. Why bother generating an input list?

Instead:
(map1-n #'sqrt 10) => (1.0 1.4142135 1.7320508 2.0 2.236068 2.4494898 2.6457512 2.828427 3.0 3.1622777)
(map0-n #'list 9) => ((0) (1) (2) (3) (4) (5) (6) (7) (8) (9))

Both defined in terms of general MAPA-B:
(mapa-b #'abs -3 8) => (3 2 1 0 1 2 3 4 5 6 7 8)
Optional STEP
(mapa-b #'abs -3 8 5) => (3 2 7)

Graham's version:
(defun map0-n (fn n)
  (mapa-b fn 0 n))
(defun map1-n (fn n)
  (mapa-b fn 1 n))
(defun mapa-b (fn a b &optional (step 1))
  (do ((i a (+ i step))
       (result nil))
      ((> i b) (nreverse result))
      (push (funcall fn i) result)))

Why not descending sequence?
(mapa-b #'abs 8 -3) => (8 7 6 5 4 3 2 1 0 1 2 3)

Take two:
(defun mapa-b (f a b &optional (step 1))
  (assert (plusp step) () "Step increment must be positive.")
  (if (<= a b)
      (loop for i from a to b by step collect (funcall f i))
      (loop for i from a downto b by step collect (funcall f i))))
-------------------------------------------
Let's make ranges!

Old - bad
(defun make-range (start &optional end (step 1))
  (etypecase start
    (character (typecase end
                 (character
                   (if (char> start end)
                       (loop for i from (char-code start) downto (char-code end) by step collect (code-char i))
                       (loop for i from (char-code start) to (char-code end) by step collect (code-char i))))
                 (null (loop for i from 0 below (char-code start) by step collect (code-char i)))
                 (otherwise (error "Mismatched input types."))))
    (number (typecase end
              (number (if (> start end)
                          (loop for i from start downto end by step collect i)
                          (loop for i from start to end by step collect i)))
              (null (loop for i from 0 below start by step collect i))
              (otherwise (error "Mismatched input types.")))) ))

Why not let MAPA-B do the work?

New - better
(defun range (start &optional end (step 1))                       ; END is optional for RANGE. Required for MAKE-RANGE.
  (make-range start end step))                                    ;    Can't dispatch on type of OPTIONAL param.
(defgeneric make-range (start end step)
  (:documentation "Create a list from START to END inclusive by STEP."))
(defmethod make-range ((start character) (end character) (step integer))
  (mapa-b #'code-char (char-code start) (char-code end) step))
(defmethod make-range ((start character) (end null) (step integer))
  (declare (ignore end))
  (if (char> start #\0)
      (make-range #\0 (code-char (1- (char-code start))) step)
      '()))
(defmethod make-range ((start character) end step)                 ; Default is an error
  (error "Mismatched input types."))
(defmethod make-range ((start number) (end number) (step number))
  (mapa-b #'identity start end step))
(defmethod make-range ((start number) (end null) (step number))
  (declare (ignore end))
  (if (plusp start)
      (make-range 0 (1- start) step)
      '()))
(defmethod make-range ((start number) end step)
  (error "Mismatched input types."))

Haskell vs. Clojure
[1..10] => [1,2,3,4,5,6,7,8,9,10]

(range 1 10) => (1 2 3 4 5 6 7 8 9)
(range 1 (inc 10)) => (1 2 3 4 5 6 7 8 9 10) ; Ugh...
(range 5) => (0 1 2 3 4)

My Common Lisp version:
(range 1 10) => (1 2 3 4 5 6 7 8 9 10)
(range 5) => (0 1 2 3 4)
(range 1 3 1/10) => (1 11/10 6/5 13/10 7/5 3/2 8/5 17/10 9/5 19/10
                     2 21/10 11/5 23/10 12/5 5/2 13/5 27/10 14/5 29/10 3)
(range #\a #\e) => (#\a #\b #\c #\d #\e)
(range #\s #\j) => (#\s #\r #\q #\p #\o #\n #\m #\l #\k #\j)
(range 4 #\j)
  Mismatched input types.
(range #\a #\e 2) => (#\a #\c #\e)
(range #\a #\e 2.1)
  Mismatched input types.

Add range syntax
(set-dispatch-macro-character #\# #\[
  #'(lambda (stream ch arg)
      (declare (ignore ch arg))
      (destructuring-bind (m &optional n step) (read-delimited-list #\] stream t)
        (if step
            (if (and (numberp step)
                     (or (and (numberp m) (numberp n))
                         (and (characterp m) (characterp n))))
                `',(range m n step)
                `(range ,m ,n ,step))
            (if n
                (if (or (and (numberp m) (numberp n))
                        (and (characterp m) (characterp n)))
                    `',(range m n)
                    `(range ,m ,n))
                (if (or (numberp m) (characterp m))
                    `',(range m)
                    `(range ,m)))) )))

#[1 10] => (1 2 3 4 5 6 7 8 9 10)
#[5] => (0 1 2 3 4)
#[1 3 1/10] => (1 11/10 6/5 13/10 7/5 3/2 8/5 17/10 9/5 19/10
                2 21/10 11/5 23/10 12/5 5/2 13/5 27/10 14/5 29/10 3)
#[#\a #\e] => (#\a #\b #\c #\d #\e)
-------------------------------------------
More Graham mapping functions
(defun map-> (fn start test-fn succ-fn)
  (do ((i start (funcall succ-fn i))
       (result '()))
      ((funcall test-fn i) (nreverse result))
    (push (funcall fn i) result)))

(defun map-> (f start test step)
  "Collect repeated application of the function F to START as it is transformed by the STEP function until TEST returns true."
  (loop for obj = start then (funcall step obj)
        until (funcall test obj)
        collect (funcall f obj)))

;;;
;;;    Non-destructive alternative to MAPCAN.
;;;    
(defun mappend (f &rest lists)
  (apply #'append (apply #'mapcar f lists)))

;;;
;;;    Map over multiple lists in sequence, accumulating all results.
;;;    
(defun mapcars (fn &rest lsts)
  (let ((result '()))
    (dolist (l lsts)
      (dolist (obj l)
	(push (funcall fn obj) result)))
    (nreverse result)))

(defun mapcars (f &rest lists)
  "Map the function F over each element of each list argument provided."
  (loop with result = (make-linked-queue)
        for list in lists
        do (loop for elt in list
                 do (enqueue result (funcall f elt)))
        finally (return (elements result))))


----------------------------------------------------------------------------

240514 火
4 types of closures.

https://en.wikipedia.org/wiki/Funarg_problem
("Sideward Funarg" Lecture Notes in Computer Science 441, 290 页)

2 "Upward Funargs"
- Indefinite extent
- Bindings must be preserved on heap
- Binding still accessible once enclosing form has exited.

I. Closure over variable binding
(let ((index 0))
  (defun counter ()
    (incf index)))

Evaluation has exited LET form. COUNTER retains access to binding
(counter) => 1
(counter) => 2
(counter) => 3

II. Closure over function binding
(flet ((foo (x) (* x 17)))
  (defun bar (x)
    (if (evenp x)
        x
        (foo x))))

FLET exited. BAR retains local function binding.
(bar 4) => 4
(bar 5) => 85

Oz example (58 页)
(labels ((q (x) (cons 'stat x))
         (p (x) (q x)))
  (flet ((q (x) (cons 'dyn x)))
    (p 'hello)))
=> (STAT . HELLO)

2 "Downward Funargs"
- Dynamic extent
- All state still on stack
- Unavailable once enclosing BLOCK/TAGBODY exits
- Nothing returned back up callstack.

III. Closure over BLOCK name.
(defun eject (f)
  (format t "Punching out!~%")
  (funcall f)) ; Not within lexical scope of BLOCK but still within its
               ;   dynamic extent.

(block baz
  (format t "We are in BAZ.~%")
  (eject #'(lambda () (return-from baz :done)))
  (format t "About to leave BAZ.~%")) ; Unreachable
=> We are in BAZ.
Punching out!
:DONE

(eject #'(lambda () (return-from baz :done))) ; Extent of BLOCK has ended (disestablished)
Compile-time error:
  return for unknown block: BAZ

IV. Closure over TAGBODY tag
(defun exit-stage-left (f)
  (format t "Enough of that...~%")
  (funcall f)) ; Not with lexical scope of TAGBODY. Within dynamic extent.

(let ((i 0))
  (tagbody
    :head
    (print i)
    (incf i)
    (when (> i 3)
      (exit-stage-left #'(lambda () (go :exit))))
    (go :head)
    :exit))

0 
1 
2 
3 Enough of that...
NIL
----------------------------------------------------------------------------
240929 日
Oz closure examples:
(let ((y 5))
  (flet ((lower-bound (x)
           (if (>= x y)
               x
               y)))
    (let ((c (lower-bound 3)))) ))

(let ((y 5))
  (defun lower-bound (x)
    (if (>= x y)
        x
        y)))
(let ((c (lower-bound 3))))

(let ((y 5))
  (flet ((lower-bound (x)
           (if (>= x y)
               x
               y)))
    (let* ((y 10)
           (c (lower-bound 3)))) ))

(let ((y 5))
  (flet ((lower-bound (x)
           (if (>= x y)
               x
               y)))
    (let* ((x 10)
           (c (lower-bound 3)))) ))
----------------------------------------------------------------------------
        
240508 水
(defun foo (obj l) (cons obj (rest l)))
(foo 'x '(a b c)) => (X B C)

(trace foo)

(foo 'x '(a b c))   <-- QUOTE
  0: (FOO X (A B C)) <-- ???
  0: FOO returned (X B C)
(X B C)




230927

(defmacro condp (pred val &rest clauses)
  (let ((predicate (make-symbol "PREDICATE"))
        (value (make-symbol "VALUE")))
    `(let ((,predicate ,pred)
           (,value ,val))
       (assert (functionp ,predicate) () "Predicate must be a function: ~A" ,predicate)
       (cond ,@(loop for clause in clauses
                     collect `((funcall ,predicate ,(first clause) ,value) ,(second clause)))) )))










(defun transform-clause (clause predicate value)
  (ecase (length clause)
    (1)
    (2 `((funcall ,predicate ,(first clause) ,value) ,(second clause)))
    (3 (destructuring-bind (target delimiter fn) clause
         (assert (eq delimiter :>>) () "Malformed delimiter: ~S" delimiter)
         `((funcall ,predicate ,target ,value) (funcall ,fn (funcall ,predicate ,target ,value)))) )))

(defmacro condp (pred val &rest clauses)
  (let ((predicate (make-symbol "PREDICATE"))
        (value (make-symbol "VALUE")))
    `(let ((,predicate ,pred)
           (,value ,val))
       (assert (functionp ,predicate) () "Predicate must be a function: ~A" ,predicate)
       (cond ,@(loop for clause in clauses
                     collect (transform-clause clause predicate value)))) ))


(defun transform-clause (clause predicate value)
  (ecase (length clause)
    (1 `(t ,@clause))
    (2 `((funcall ,predicate ,(first clause) ,value) ,(second clause)))
    (3 (destructuring-bind (target delimiter fn) clause
         (assert (eq delimiter :>>) () "Malformed delimiter: ~S" delimiter)
         `((funcall ,predicate ,target ,value) (funcall ,fn (funcall ,predicate ,target ,value)))) )))


(defun fizz-buzz (n)
  (condp #'(lambda (p q) (zerop (mod q p))) n
    (15 "fizzbuzz")
    (3  "fizz")
    (5  "buzz")
    (n)))

(loop for i from 1 to 20 do (format t "~A~%" (fizz-buzz i)))

(defun fizz-buzz* (n)
  (case (mod n 15)
    (15 "fizzbuzz")
    (3  "fizz")
    (5  "buzz")
    (otherwise n)))

(defun ordering (x y)
  (condp #'apply (list x y)
    (#'= "eq")
    (#'< "lt")
    (#'> "gt")))

(condp some [1 2 3 4]
  #{0 6 7} :>> inc
  #{4 5 9} :>> dec
  #{1 2 3} :>> #(+ % 3))