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 ...))

See MULTIPLE-VALUE-CALL below 


(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.

76-78 页:
"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) (partial #'mapcar #'rest))
                 (copy-tree '((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

[Categorization of utility involves both size and generality.]

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

(sdraw *nicknames* :display-width 280)

[*|*]--------------------------->[*|*]------------------------------------>[*|*]----------------------------->[*|*]------------------------------>[*|*]--------------------------->[*|*]------------------>[*|*]------------------->[*|*]--->NIL
 |                                |                                         |                                  |                                   |                                |                       |                        |
 v                                v                                         v                                  v                                   v                                v                       v                        v
[*|*]--->[*|*]--->NIL            [*|*]--->[*|*]--->NIL                     [*|*]----->[*|*]--->NIL            [*|*]------>[*|*]--->NIL            [*|*]--->[*|*]--->NIL            [*|*]--->[*|*]--->NIL   [*|*]---->[*|*]--->NIL   [*|*]------>[*|*]--->NIL
 |        |                       |        |                                |          |                       |           |                       |        |                       |        |              |         |              |           |
 v        v                       v        v                                v          v                       v           v                       v        v                       v        v              v         v              v           v
THOMAS   [*|*]--->[*|*]--->NIL   ROBERT   [*|*]--->[*|*]--->[*|*]--->NIL   THEODORE   [*|*]--->[*|*]--->NIL   CATHERINE   [*|*]--->[*|*]--->NIL   DAVID    [*|*]--->[*|*]--->NIL   EDWARD   [*|*]--->NIL   MICHAEL   [*|*]--->NIL   ELIZABETH   [*|*]--->[*|*]--->[*|*]--->NIL
          |        |                       |        |        |                         |        |                          |        |                       |        |                       |                        |                          |        |        |
          v        v                       v        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                      MIKE                       LIZ      LISA     LIZZIE

Idiomatic:
(mapcan #'nicknames '(michael edward david))
(MIKE ED DAVE DAVEY)

Oops!
(sdraw *nicknames* :display-width 280)

[*|*]--------------------------->[*|*]------------------------------------>[*|*]----------------------------->[*|*]------------------------------>[*|*]--------------------------->[*|*]------------------------------------>[*|*]------------------->[*|*]--->NIL
 |                                |                                         |                                  |                                   |                                |                                         |                        |
 v                                v                                         v                                  v                                   v                                v                                         v                        v
[*|*]--->[*|*]--->NIL            [*|*]--->[*|*]--->NIL                     [*|*]----->[*|*]--->NIL            [*|*]------>[*|*]--->NIL            [*|*]--->[*|*]--->NIL            [*|*]--->[*|*]--->NIL                     [*|*]---->[*|*]--->NIL   etc.
 |        |                       |        |                                |          |                       |           |                       |        |                       |        |                                |         |
 v        v                       v        v                                v          v                       v           v                       v        v                       v        v                                v         v
THOMAS   [*|*]--->[*|*]--->NIL   ROBERT   [*|*]--->[*|*]--->[*|*]--->NIL   THEODORE   [*|*]--->[*|*]--->NIL   CATHERINE   [*|*]--->[*|*]--->NIL   DAVID    [*|*]--->[*|*]--->NIL   EDWARD   [*|*]--->[*|*]--->[*|*]--->NIL   MICHAEL   [*|*]--->[*|*]--->[*|*]--->[*|*]--->NIL
          |        |                       |        |        |                         |        |                          |        |                       |        |                       |        |        |                        |        |        |        |
          v        v                       v        v        v                         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     DAVEY                    MIKE      ED      DAVE     DAVEY

(sdraw (cddr *nicknames*) :display-width 280)

[*|*]----------------------------->[*|*]------------------------------>[*|*]--------------------------->[*|*]------------------------------------>[*|*]---------------------------------------------->[*|*]--->NIL
 |                                  |                                   |                                |                                         |                                                   |
 v                                  v                                   v                                v                                         v                                                   v
[*|*]----->[*|*]--->NIL            [*|*]------>[*|*]--->NIL            [*|*]--->[*|*]--->NIL            [*|*]--->[*|*]--->NIL                     [*|*]---->[*|*]--->NIL                              [*|*]------>[*|*]--->NIL
 |          |                       |           |                       |        |                       |        |                                |         |                                         |           |
 v          v                       v           v                       v        v                       v        v                                v         v                                         v           v
THEODORE   [*|*]--->[*|*]--->NIL   CATHERINE   [*|*]--->[*|*]--->NIL   DAVID    [*|*]--->[*|*]--->NIL   EDWARD   [*|*]--->[*|*]--->[*|*]--->NIL   MICHAEL   [*|*]--->[*|*]--->[*|*]--->[*|*]--->NIL   ELIZABETH   [*|*]--->[*|*]--->[*|*]--->NIL
            |        |                          |        |                       |        |                       |        |        |                        |        |        |        |                          |        |        |
            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                    MIKE      ED      DAVE     DAVEY                      LIZ      LISA     LIZZIE

Calling (mapcan #'nicknames '(michael edward david)) again goes into infinite loop with circular list!!

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.)

Thus, 2 problems with ALL-NICKNAMES:
• Wasted effort. MAPCAN already exists.
• Obscurity. ALL-NICKNAMES is clearly a kind of mapping. Use normal idioms.
---------------------------------------------------------
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 (if any).
  )

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


(defun some3 (fn l)
  (funcall fn (find-if fn l)))

SOME -> FIND-IF:
(some f seq) -> (some #'(lambda (elt) (and (funcall f elt) elt)) seq) ; Not identical for NIL element.
----------------------------------------------------------------------------
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, simply 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!) (Distinct from Graham's FILTER below!)
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. See LONGERP below.

Good utilities => Programming is easier
               => Programs are better

Writing a utility can highlight good places to use it!
----------------------------------------------------------------------------
§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?
Naive:
(= (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))
[Just as SOME can be viewed as: (funcall f (find-if 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

(Compare similarity between SOME/FIND-IF above.)

Graham remarks that this sort of iterative code that records work done up to a given point in an accumulator
is similar to the output of a compiler performing tail call optimization. He argues that in this simple case
it's easier to just write the iterative version directly.

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)
(filter (every-pred #'alpha-char-p #'lower-case-p #'char-upcase) "Is this not pung?")
"STHISNOTPUNG"

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))]

Graham points out that GROUP can be very useful in defining macros and uses it throughout the book.

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

His version only works on lists...

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)
  (assert (typep n `(integer (0)))
          (n)
          "N must be a positive integer.")
  (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:
(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))
       (if (endp tail)
           (values seq '())
           (values (subseq seq 0 i) tail)))) )
(defmethod take-drop (n (seq 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 list:
(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 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 function: MAP
MAP like MAPCAR applies F to elts of 1+ sequences. Type of result sequence is given.
Works with mixed types of input 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

Goal: Apply FN to integers 1,...,10

What's wrong with this?
(mapcar #'sqrt '(1 2 3 4 5 6 7 8 9 10)) => (1.0 1.4142135 1.7320508 2.0 2.236068 2.4494898 2.6457512 2.828427 3.0 3.1622777)
                 ^^^^^^^^^^^^^^^^^^^^
                 Dummy input list is simply thrown away...

Shortcut with reader macro: (Same wasted work)
(See ranges below)
#[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 to be immediately thrown away?

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 upto 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 number) (step function))
  (if (<= start end)
      (loop with f = (iterate step start)
            for elt = (funcall f)
            until (> elt end)
            collect elt)
      (loop with f = (iterate step start)
            for elt = (funcall f)
            until (< elt end)
            collect elt)))
(defmethod make-range ((start number) (end null) (step number))
  (declare (ignore end))
  (cond ((zerop start) '())
        ((plusp start) (make-range 0 (1- start) step))
        (t (make-range 0 (1+ start) step))))
(defmethod make-range ((start number) end step)
  (error "Mismatched input types."))

Haskell
[1..10] => [1,2,3,4,5,6,7,8,9,10] -- Both endpoints inclusive

Clojure
(range 1 10) => (1 2 3 4 5 6 7 8 9) ; Upper endpoint exclusive!
(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) ; Both endpoints included
(range 5) => (0 1 2 3 4) ; Value is exclusive upper bound (or count)
(range -5) => (0 -1 -2 -3 -4)
(range 0) => NIL ; Perhaps counterintuitive
(range 0 0) => (0)
(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 1 1024 (partial #'* 2)) => (1 2 4 8 16 32 64 128 256 512 1024) ; Can't do that in Haskell!
(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)
#[1 1024 (partial #'* 2)] => (1 2 4 8 16 32 64 128 256 512 1024)
-------------------------------------------
More Graham mapping functions

MAP-> maps a function FN over a sequence beginning with the value START, whose successive elements are generated
via SUCC-FN, and which terminates based on TEST-FN.

For example, increment the values in (-2 -1.5 -1 -0.5 0):
(map-> #'1+ -2 #'(lambda (x) (> x 0)) #'(lambda (x) (+ x 0.5)))
• Start with -2
• Add 0.5 to get next element
• Stop when element is greater than 0
• Add one to each

Graham:
(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)))

My rewrite:
(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)))

MAP-> could serve as the universal CONS mapping function, replacing MAPLIST, MAPCAR, MAPA-B, etc.:
(mapcar #'length '("Is" "this" "not" "pung?"))
vs.
(map-> (compose #'length #'first) '("Is" "this" "not" "pung?") #'null #'rest))

(maplist #'reverse '(1 2 3 4))
vs.
(map-> #'reverse '(1 2 3 4) #'null #'rest))

(mapa-b #'1+ -2 0 0.5)
vs.
(map-> #'1+ -2 #'(lambda (x) (> x 0)) #'(lambda (x) (+ x 0.5))))

In general, Graham poses: (This is not the full MAPA-B above. Only handles A < B.)
(defun mapa-b (f a b &optional (step 1))
  (map-> f
         a
         #'(lambda (x) (> x b))
         #'(lambda (x) (+ x step))))

Alternatively:
(defun mapa-b (f a b &optional (step 1))
  (map-> f a (partial* #'> b) (partial #'+ step)))

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

-------------------------------------------
250528 水
5 approaches to MAPCAR, i.e., 5 ways to accumulate a list result:
1. Go with the flow. Follow the natural process of building a list from the head:
(defun mapcar (f l)
  (if (endp l)
      '()
      (cons (funcall f (first l)) (simple-mapcar f (rest l)))) )

Not tail-recursive. Prone to stack overflow.

2. Accumulate list head to tail, then reverse (in place) when done:
(defun mapcar (f l)
  (labels ((process (l result)
             (if (endp l)
                 (nreverse result)
                 (process (rest l) (cons (funcall f (first l)) result)))) )
    (process l '())))

Many flavors of this (Not necessarily recursive, e.g., DO). Standard old school idiom.
Tail-recursive. NREVERSE only modifies privately owned list, so this maintains a functional interface.

3. Get yer hands dirty. List surgery:
(defun mapcar (f l)
  (if (null l)
      '()                    ; <-- Special case: empty list
      (destructuring-bind (first . more) l
        (let ((result (list (funcall f first))))
          (if (null more)
              result         ; <-- Special case: single-elt list
              (let ((tail result)) ; <-- General case: Accumulate TCONC
                (dolist (elt more result)
                  (setf (rest tail) (list (funcall f elt))
                        tail (rest tail)))) )))) )

Example
Add: 7 to end of list
RESULT             TAIL
  |                 |
  v                 v
[*|*]---> ... --->[*|*]--->NIL
 |                 |
 v                 v
 9                -2

I. Create new CONS: (cons x '()) ≡ (list x)
RESULT             TAIL
  |                 |
  v                 v
[*|*]---> ... --->[*|*]--->NIL   [*|*]--->NIL
 |                 |              |          
 v                 v              v          
 9                -2              7          

II. Modify current last CDR
RESULT             TAIL
  |                 |
  v                 v
[*|*]---> ... --->[*|*]--->[*|*]--->NIL
 |                 |        |  
 v                 v        v  
 9                -2        7          

III. Point to new TAIL
RESULT                      TAIL
  |                          |
  v                          v
[*|*]---> ... --->[*|*]--->[*|*]--->NIL
 |                 |        |  
 v                 v        v  
 9                -2        7  



Standard Lisp idiom of TCONC (https://www.merl.com/publications/TR91-04 ch. 3)
"Tail Concatenation". Messy. Feels like C code.

4. Use an explicit queue:
(defun mapcar (f l)
  (let ((result (make-linked-queue)))
    (dolist (elt l (elements result)) ; <-- This queue implementation allows easily extracting the underlying list
      (enqueue result (funcall f elt)))) )

Most likely just encapsulates the details of option 3.

5. Use the LOOP macro with COLLECT:
(defun mapcar (f l)
  (loop for elt in l
        collect (funcall f l)))

Probably something like 3. under the covers!
-------------------------------------------
MAPCARS: Apply MAPCAR across multiple lists in sequence (not parallel):
(mapcars #'abs '(2 5 6) '(99 -23 -8)) => (2 5 6 99 23 8)

"Obvious" definition:
(defun mapcars (f &rest lists)
  (mapcar f (apply #'append lists)))

But this is inefficient, APPEND produces ephemeral list that is thrown away.

Instead:
- Graham's version
(defun mapcars (fn &rest lsts)
  (let ((result '()))
    (dolist (l lsts)
      (dolist (obj l)
	(push (funcall fn obj) result)))
    (nreverse result)))

- An alternative
(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))))

- Hard to beat
(defun mapcars (f &rest lists)
  (loop for list in lists
        nconc (loop for elt in list
                    collect (funcall f elt))))

-------------------------------------------
250430 水
Mapping over trees

Cases to consider for tree mapping function:
- Only proper trees allowed? Allow dotted trees?
  - Single tree
  - Multiple trees same shape
  - Multiple trees inconsistent shapes

Two views of tree: (另见 Tanimoto ch. 2 notes)
- List of lists
- General tree (arbitrary number of children/node)
  - Recast as binary tree

((1 2) (3 4 5))

List of lists:
[*|*]------------------>[*|*]--->NIL
 |                       |
 v                       v
[*|*]--->[*|*]--->NIL   [*|*]--->[*|*]--->[*|*]--->NIL
 |        |              |        |        |
 v        v              v        v        v
 1        2              3        4        5

Subtrees are FIRST, SECOND, THIRD, ... elements.
Generate result by using MAPCAR to iterate across top-level list. Sublists are
passed as arguments to the mapping function.
(Map one list of lists to another list of lists.)

General tree:
       ◯       
      / \                                                   
     /   \                                                  
    /     \                                                 
   ◯       ◯                                                
  / \     /|\                                               
 /   \   / | \                                              
1     2 3  4  5

However, any tree can be represented as a binary tree.
[Just as any number can be represented in binary radix.]
       ◯       
      / \                                                   
     /   \                                                  
    ◯     \                                                 
   / \     \                                             
  /   \     \                                         
 1     ◯     \                                        
      / \     \
     /   \     \
    2    NIL    ◯
               / \
              /   \     
             3     ◯    
                  / \   
                 /   \  
                4     ◯   
                     / \  
                    /   \ 
                   5    NIL

                                             
Left subtree
   is CAR
   ◯                  ◯          
  / \                / \         
 /   \              /   \        
1     ◯            3     ◯       
     / \                / \      
    /   \              /   \     
   2    NIL           4     ◯    
                           / \   
                          /   \  
                         5    NIL
                     Right subtree
                        is CDR

Generate result by processing CAR, processing CDR then CONSing together:
car -> car'
cdr -> cdr'
(cons car' cdr') => Result tree

Consider what MAPCAR does and extend to trees:
MAPCAR
• Transform single list into new list of same length with original elements replaced
  by results of applying function to them.
  (mapcar #'length '("cat" "antelope" "shrew" "platypus")) => (3 8 5 8)
• Transform multiple lists into single new list (of length constrained by shortest arg) whose
  elements result from applying n-ary function to corresponding elements of n lists.
  (mapcar #'(lambda (x y) (mod x y)) '(7 0 1 4) '(4 2 6 3)) => (3 0 1 1)
  (mapcar #'(lambda (x y) (mod x y)) '(7 0 1) '(4 2 6 3)) => (3 0 1)
• Only works with proper list args. (Top-level structures are proper lists. Elements may be anything.)
  (mapcar #'1+ '(1 2 . 3)) => TYPE-ERROR
  (mapcar #'car '((a . b) (c . d) (e . f))) => (A C E)

RMAPCAR
• Transform single tree into new tree of same "shape" with original leaves (non-NIL atoms) replaced with
  result of applying function to them.
• Transform multiple trees of same "shape" (or constrained by smallest subtrees of args) into
  new tree with elements resulting from application of function.
• Only works with proper trees?  

Simplified definitions with single input:
(defun simple-mapcar (f l)
  (if (endp l)
      '()
      (cons (funcall f (first l)) (simple-mapcar f (rest l)))) ) ; Build corresponding list structure

Graham style (list of lists):
(defun simple-rmapcar (fn arg)
  (if (atom arg)
      (funcall fn arg)
      (mapcar #'(lambda (arg) (simple-rmapcar fn arg)) arg))) ; Sublists become args to recursive call. Depth is reduced by one.
                         ^^^                           ^^^
Binary tree view:
(defun simple-rmapcar* (f obj)
  (cond ((null obj) '())
        ((atom obj) (funcall f obj))
        (t (cons (simple-rmapcar f (car obj))      ; Build corresponding tree structure
                 (simple-rmapcar f (cdr obj))))) )



Skeletal forms:
(defun copy-cons (c)
  (cons (first c) (rest c)))

(defun copy-list (l) ; List L is fundamentally a CONS
  (if (endp l)
      '()
      (cons (first l) (copy-list (rest l)))) )

E.g., (mapcar #'identity l)


(defun copy-tree (tree)
   (if (atom tree)
       tree
       (cons (copy-tree (car tree))
             (copy-tree (cdr tree)))) )

Graham style:
(defun copy-tree* (arg)
  (if (atom arg)
      arg
      (mapcar #'(lambda (arg) (copy-tree* arg)) arg)))

E.g., (rmapcar #'identity l)

[For a list of atoms, SIMPLE-RMAPCAR encompasses SIMPLE-MAPCAR's functionality.]

(simple-mapcar #'(lambda (x) (+ x 2)) '(5 4 3 2 1)) => (7 6 5 4 3)
(simple-mapcar #'length '("pung" "foo" "bar" "baz")) => (4 3 3 3)

(simple-rmapcar #'(lambda (x) (+ x 2)) '(5 4 3 2 1)) => (7 6 5 4 3)
(simple-rmapcar #'1+ '(1 2 (3 4 (5) 6) 7 (8 9))) => (2 3 (4 5 (6) 7) 8 (9 10))

Graham's version does not handle dotted pairs.

SIMPLE-RMAPCAR* does:
(simple-rmapcar* #'1+ '((1 . 2) (3 . 4) (5 . 6))) => ((2 . 3) (4 . 5) (6 . 7))

[*|*]------->[*|*]------->[*|*]--->NIL     =>      [*|*]------->[*|*]------->[*|*]--->NIL 
 |            |            |                        |            |            |           
 v            v            v                        v            v            v           
[*|*]--->2   [*|*]--->4   [*|*]--->6               [*|*]--->3   [*|*]--->5   [*|*]--->7   
 |            |            |                        |            |            |           
 v            v            v                        v            v            v           
 1            3            5                        2            4            6           

       ◯             =>              ◯             
      / \                           / \            
     ◯   \                         ◯   \           
    / \   \                       / \   \          
   1   2   ◯                     2   3   ◯         
          / \                           / \        
         ◯   \                         ◯   \       
        / \   \                       / \   \      
       3   4   ◯                     4   5   ◯     
              / \                           / \    
             ◯   \                         ◯   \   
            / \   \                       / \   \  
           5   6  NIL                    6   7  NIL

Arbitrary depth
(simple-rmapcar #'(lambda (x) (+ x 3)) '(1 2 (3 (4 (5) 6) (7)) 8 (9))) => (4 5 (6 (7 (8) 9) (10)) 11 (12))
(simple-rmapcar #'(lambda (x) (+ x 5)) '(((( (1)))) )) => (((((6)))))

Full MAPCAR (over multiple lists) is harder:
(defun mapcar (f &rest args)
  (if (some #'null args)
      '()
      (loop for arg in args
            collect (first arg) into firsts
            collect (rest arg) into rests
            finally (return (cons (apply f firsts) (apply #'mapcar f rests)))) ))

(defun mapcar (f &rest args)
  (cond ((null args) '())
        ((some #'null args) '())
        (t (multiple-value-bind (cars cdrs) (firsts-rests args) ; See below for FIRSTS-RESTS
             (cons (apply #'f cars)
                   (apply #'mapcar f cdrs)))) ))


Full RMAPCAR:
- Graham MAPCAR across top-level trees (LOLs)
  - Recursively apply RMAPCAR

(defun rmapcar (fn &rest args) ; Lazy choice of parameter name
  (if (some #'atom args)
      (apply fn args)
      (apply #'mapcar #'(lambda (&rest car-args)
			  (apply #'rmapcar fn car-args))
	     args)))

Examples:
A.
(mapcar #'+ '(1 2) '(3 4))
(+ 1 3) (2) (4)
(+ 2 4) () ()

B.
(mapcar #'+ '(1 2) '(3 4 5))
(+ 1 3) (2) (4 5)
(+ 2 4) () (5) <-- One sublist is empty: terminate

C.
(rmapcar #'+ '(1 2) '(3 4))
-> (mapcar #'F '(1 2) '(3 4))
(F 1 3) (2) (4)
(F 2 4) () ()

What is F?
(rmapcar #'+ 1 3)
(rmapcar #'+ 2 4)

D.
(rmapcar #'+ '(1 (2)) '(3 (4)))
-> (mapcar #'F '(1 (2)) '(3 (4))) => (4 (6))
(F 1 3) ((2)) ((4))
(F '(2) '(4)) () ()

(rmapcar #'+ 1 3) => 4
(rmapcar #'+ '(2) '(4))
-> (mapcar #'F '(2) '(4)) => (6)

(F 2 4) () ()

(rmapcar #'+ 2 4) => 6

E. Same shape trees
(rmapcar #'list '(1 ((2) 3) (4)) '(:a ((:b) :c) (:d)))
-> (mapcar #'F '(1 ((2) 3) (4)) '(:a ((:b) :c) (:d))) => ((1 :a) (((2 :b)) (3 :c)) ((4 :d)))
(F 1 :a) (((2) 3) (4)) (((:b) :c) (:d))
  (rmapcar #'list 1 :a) => (1 :a)

(F ((2) 3) ((:b) :c)) ((4)) ((:d))
  (rmapcar #'list '((2) 3) '((:b) :c))
  -> (mapcar #'F '((2) 3) '((:b) :c)) => (((2 :b)) (3 :c))
  (F (2) (:b)) (3) (:c)
    (rmapcar #'list '(2) '(:b))
    -> (mapcar #'F '(2) '(:b)) => ((2 :b))
    (F 2 :b) () () => (2 :b)
  (F 3 :c) () () => (3 :c)

(F (4) (:d)) () ()
  (rmapcar #'list '(4) '(:d))
  -> (mapcar #'F '(4) '(:d)) => ((4 :d))
  (F 4 :d) () () => (4 :d)

F. Different shape trees
(rmapcar #'list '(1 ((2)) (4)) '(:a ((:b) :c) (:d)))
-> (mapcar #'F '(1 ((2)) (4)) '(:a ((:b) :c) (:d))) => ((1 :a) (((2 :b))) ((4 :d)))
(F 1 :a) (((2)) (4)) (((:b) :c) (:d))
  (rmapcar #'list 1 :a) => (1 :a)

(F ((2)) ((:b) :c)) ((4)) ((:d))
  (rmapcar #'list '((2)) '((:b) :c))
  -> (mapcar #'F '((2)) '((:b) :c)) => (((2 :b)))
  (F (2) (:b)) () (:c)  <-- One sublist empty: terminate
    (rmapcar #'list '(2) '(:b))
    -> (mapcar #'F '(2) '(:b)) => ((2 :b))
    (F 2 :b) () () => (2 :b)

(F (4) (:d)) () ()
  (rmapcar #'list '(4) '(:d))
  -> (mapcar #'F '(4) '(:d)) => ((4 :d))
  (F 4 :d) () () => (4 :d)


Alternative.
TREE-MAP handles dotted trees.

(defun tree-map (f &rest trees)
  (cond ((null trees) '()) ; Pathological initial case: (tree-map f). Also recursive case where trees are not same size.
        ((some #'null trees) '())
        ((some #'atom trees) (apply f trees))
        (t (multiple-value-bind (cars cdrs) (firsts-rests trees)
             (cons (apply #'tree-map f cars)
                   (apply #'tree-map f cdrs)))) ))

(defun firsts-rests (lol)
  "Traverse LOL, a list of lists, and collect the first elements of each as well as the tails of each."
  (labels ((collect-heads-tails (lol heads tails)
             (cond ((null lol) (values (elements heads) (elements tails)))
                   (t (destructuring-bind (first . rest) lol
                        (cond ((atom first) (values '() '())) ; No CAR/CDR for this sublist. Results are meaningless. Abort.
                              (t (destructuring-bind (head . tail) first
                                   (enqueue heads head)
                                   (cond ((null tail) (collect-heads rest heads)) ; Encountering a single-elt list anywhere means all tails are discarded.
                                         (t (enqueue tails tail)
                                            (collect-heads-tails rest heads tails)))) )))) ))
           (collect-heads (lol heads)
             (cond ((null lol) (values (elements heads) '()))
                   (t (destructuring-bind (first . rest) lol
                        (cond ((atom first) (values '() '())) ; No CAR/CDR for this sublist. Results are meaningless. Abort.
                              (t (destructuring-bind (head . tail) first
                                   (declare (ignore tail))
                                   (enqueue heads head)
                                   (collect-heads rest heads)))) )))) )
    (collect-heads-tails lol (make-linked-queue) (make-linked-queue))))

(defun firsts-rests* (lol)
  (loop for list in lol
        collect (first list) into firsts
        collect (rest list) into rests
        finally (return (values firsts rests))))

Uniform structure
(firsts-rests '((a b c) (:d :e :f) (1 2 3) (#\x #\y #\z))) => (A :D 1 #\x); ((B C) (:E :F) (2 3) (#\y #\z))
Different structures
(firsts-rests '((a b c) (:d :e :f) (1 2) (#\x #\y #\z))) => (A :D 1 #\x); ((B C) (:E :F) (2) (#\y #\z))

(firsts-rests '((a (b c)) (:d (:e :f)) (1 (2 3)) (#\x (#\y #\z)))) => (A :D 1 #\x); (((B C)) ((:E :F)) ((2 3)) ((#\y #\z)))
(firsts-rests '((a (b c)) (:d (:e :f)) (1 2 3) (#\x (#\y #\z)))) => (A :D 1 #\x); (((B C)) ((:E :F)) (2 3) ((#\y #\z)))

Next pass
(firsts-rests '(((B C)) ((:E :F)) (2 3) ((#\y #\z)))) => ((B C) (:E :F) 2 (#\y #\z)); NIL
(firsts-rests* '(((B C)) ((:E :F)) (2 3) ((#\y #\z)))) => ((B C) (:E :F) 2 (#\y #\z)); (NIL NIL (3) NIL)

Same-shaped trees:
(a (b c))

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

(1 (2 3))

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

       ◯                    ◯       
      / \                  / \                                             
     /   \                /   \                                            
    A     ◯              1     ◯   
         / \                  / \  
        /   \                /   \ 
       B     C              2     3   

Different shape:
(1 (2))

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

   ◯      
  / \     
 /   \    
1     ◯   
     /
    /
   2



(rmapcar #'list '() '() '()) => (NIL NIL NIL)
(tree-map #'list '() '() '()) => NIL

Chapter 5
============================================================================
☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆
============================================================================
250625 水
https://en.wikipedia.org/wiki/Function_composition

g: A -> B
f: B -> C
f∘g: A -> C

General case: (Innermost function takes n args. All return 1 value.)
g : (A₁ X ... X Aₙ) -> B
f: B -> C
f∘g: (A₁ X ... X Aₙ) -> C

Hardwired:
(defun f∘g (a b c d)
  (f (g a b c d)))

COMPOSE as binary operator:
(defun compose (f g)
  #'(lambda (&rest args)
      (funcall f (apply g args))))

Example:
|xʸ|
(abs (expt x y))

(funcall (compose #'abs #'expt) -3 5) => 243
Expansion:
(funcall #'(lambda (&rest args) (funcall #'abs (apply #'expt args))) 2 9) => 512
-------------------------------------------
Compose arbitrary number of functions? 
Binary operator used repeatedly.

Example:
h(x) = 2x
g(x) = x + 1
f(x) = x³

(f∘g∘h)(x) = (2x + 1)³

(Composition is associative: (f∘g)∘h = f∘(g∘h))

(defun f (x) (expt x 3))
(defun g (x) (1+ x))
(defun h (x) (* 2 x))

(setf (symbol-function 'f∘g) (compose #'f #'g))
> #'(lambda (&rest args)
      (funcall #'f (apply #'g args)))

(setf (symbol-function 'g∘h) (compose #'g #'h))
> #'(lambda (&rest args)
      (funcall #'g (apply #'h args)))

(setf (symbol-function 'f∘g∘h) (compose #'f #'g∘h))
> #'(lambda (&rest args)
      (funcall #'f (apply #'g∘h args)))
>> #'(lambda (&rest args)
       (funcall #'f
                (apply #'(lambda (&rest args) (funcall #'g (apply #'h args))) args)))

(setf (symbol-function 'f∘g∘h*) (compose #'f∘g #'h))
> #'(lambda (&rest args)
      (funcall #'f∘g (apply #'h args)))
>> #'(lambda (&rest args)
       (funcall #'(lambda (&rest args) (funcall #'f (apply #'g args)))
                (apply #'h args)))

The above represents (f∘g)∘h. Equivalently:
(f∘g)∘h = (reduce #'compose (list #'f #'g #'h))     <-- Key to generalizing to N functions

Test associativity:
(loop for i from -1000 to 1000 unless (= (f∘g∘h i) (f∘g∘h* i)) do (print i)) => NIL

General definition:
(defun compose (&rest fs)
  (if (null fs)
      #'identity
      (reduce #'(lambda (f g)
                  #'(lambda (&rest args)
                      (funcall f (apply g args))))
              fs)))

[The semantics of REDUCE here are important. We must separately handle the case of no functions passed:
 (compose) => #'identity
 But otherwise, REDUCE does what we want. Given a single arg, REDUCE simply bails and returns that arg:
 (compose #'f) => #'f
 The more interesting case, of course, is 2+ args. Here REDUCE handles the functions pairwise from left to right.]

Redefine with X-rays:
Replace calls to APPLY and FUNCALL with stubs that allow tracing.
(defun func (f arg)
  (funcall f arg))

(defun app (f args)
  (apply f args))

(defun compose (&rest fs)
  (if (null fs)
      #'identity
      (reduce #'(lambda (f g)
                  #'(lambda (&rest args)
                      (func f (app g args))))
              fs)))    ^^^^    ^^^

Trace execution:
(trace func app)
(funcall (compose #'f #'g #'h) 8)
  0: (APP #<FUNCTION H> (8))
  0: APP returned 16
  0: (FUNC #<FUNCTION (LAMBDA (&REST ARGS) :IN COMPOSE) {10041AD6DB}> 16)
    1: (APP #<FUNCTION G> (16))
    1: APP returned 17
    1: (FUNC #<FUNCTION F> 17)
    1: FUNC returned 4913
  0: FUNC returned 4913
4913

Wikipedia examples:
I. Symbol SET -> SET!
(funcall (compose #'intern (partial #'format nil "~A!") #'symbol-name) 'set)
  0: (APP #<FUNCTION SYMBOL-NAME> (SET))
  0: APP returned "SET"
  0: (FUNC #<FUNCTION (LAMBDA (&REST ARGS) :IN COMPOSE) {10041B506B}> "SET")
    1: (APP #<FUNCTION (LAMBDA (&REST ARGS) :IN PARTIAL) {10041B503B}> ("SET"))
    1: APP returned "SET!"
    1: (FUNC #<FUNCTION INTERN> "SET!")
    1: FUNC returned SET! :INTERNAL
  0: FUNC returned SET! :INTERNAL
SET!
:INTERNAL


II. sqrt(-x²)
(funcall (compose #'sqrt #'- (partial* #'expt 2)) 5)
  0: (APP #<FUNCTION (LAMBDA (&REST ARGS) :IN PARTIAL*) {10041BDBDB}> (5))
  0: APP returned 25
  0: (FUNC #<FUNCTION (LAMBDA (&REST ARGS) :IN COMPOSE) {10041BDBFB}> 25)
    1: (APP #<FUNCTION -> (25))
    1: APP returned -25
    1: (FUNC #<FUNCTION SQRT> -25)
    1: FUNC returned #C(0.0 5.0)
  0: FUNC returned #C(0.0 5.0)
#C(0.0 5.0)

More examples
(funcall (compose #'length #'remove-if-not) #'evenp (loop for i from 1 to 10 collect i)) => 5 ; Innermost function takes 2 args
(funcall (compose #'first #'rest #'rest #'rest #'rest) '(a b c d e f g)) => E ; AKA FIFTH
(funcall (compose #'sqrt #'abs #'+) -1 -2 -3 -4 -5) => 3.8729835 ; Innermost function: 5 args
(mapcar (compose (partial* #'< 10000) #'abs) '(23 12345 -80 -80000)) => (T NIL T NIL)
-------------------------------------------
Only the innermost (last function) really needs APPLY in order to handle multiple args.
• This innermost function and all subsequent functions return a single value, which then
  serves as the single argument to all outer functions.

Thus, the expansion could be simplified:
#'(lambda (&rest args)
    (funcall #'(lambda (&rest args) (funcall #'f (apply #'g args))) (apply #'h args)))
                             ||
                             ||
                             \/
#'(lambda (&rest args)
    (funcall #'(lambda (x         ) (funcall #'f (funcall #'g x))) (apply #'h args)))
                        ^                         ^^^^^^^     ^     ^^^^^
(defun compose* (&rest fs)
  (cond ((null fs) #'identity)
        ((singlep fs) (first fs))
        (t (let ((chain (reduce #'(lambda (f g)
                                    #'(lambda (x)
                                        (funcall f (funcall g x))))
                                (butlast fs)))
                 (g (last1 fs)))
             #'(lambda (&rest args)
                 (funcall chain (apply g args)))) )))

(funcall (compose #'f #'g #'h) 8) => 4913
(funcall (compose* #'f #'g #'h) 8) => 4913

Do we lose associativity?
(funcall (compose #'f (compose #'g #'h)) 8) => 4913
(funcall (compose (compose #'f #'g) #'h) 8) => 4913

(funcall (compose* #'f (compose* #'g #'h)) 8) => 4913
(funcall (compose* (compose* #'f #'g) #'h) 8) => 4913

Different results for > 2 functions:
(funcall (compose #'f #'g #'h) 8)
  0: (APP #<FUNCTION H> (8))
  0: APP returned 16
  0: (FUNC #<FUNCTION (LAMBDA (&REST ARGS) :IN COMPOSE) {100450114B}> 16)
    1: (APP #<FUNCTION G> (16))
    1: APP returned 17
    1: (FUNC #<FUNCTION F> 17)
    1: FUNC returned 4913
  0: FUNC returned 4913
4913
(funcall (compose* #'f #'g #'h) 8)
  0: (APP #<FUNCTION H> (8))
  0: APP returned 16
  0: (FUNC #<FUNCTION (LAMBDA (X) :IN COMPOSE*) {1004508B9B}> 16)
    1: (FUNC #<FUNCTION G> 16)
    1: FUNC returned 17
    1: (FUNC #<FUNCTION F> 17)
    1: FUNC returned 4913
  0: FUNC returned 4913
4913

Identical when used pairwise!                       <-------------
(funcall (compose #'f (compose #'g #'h)) 8)
  0: (APP #<FUNCTION (LAMBDA (&REST ARGS) :IN COMPOSE) {100450FD6B}> (8))
    1: (APP #<FUNCTION H> (8))
    1: APP returned 16
    1: (FUNC #<FUNCTION G> 16)
    1: FUNC returned 17
  0: APP returned 17
  0: (FUNC #<FUNCTION F> 17)
  0: FUNC returned 4913
4913
(funcall (compose* #'f (compose* #'g #'h)) 8)
  0: (APP #<FUNCTION (LAMBDA (&REST ARGS) :IN COMPOSE*) {10045176DB}> (8))
    1: (APP #<FUNCTION H> (8))
    1: APP returned 16
    1: (FUNC #<FUNCTION G> 16)
    1: FUNC returned 17
  0: APP returned 17
  0: (FUNC #<FUNCTION F> 17)
  0: FUNC returned 4913
4913


But FUNCALL and APPLY are nearly equivalent:
CLHS: (funcall function arg1 arg2 ...) ≡ (apply function (list arg1 arg2 ...))

This rewrite may be cleaner by some criterion, but it disrupts the simplicity of the REDUCE
expression in COMPOSE above.

Nothing really wrong with the current definition.
-------------------------------------------
Using a macro we could condense things even further:
#'(lambda (&rest args)
    (funcall #'f (funcall #'g (apply #'h args))))

Or even:
#'(lambda (&rest args)
    (f (g (apply #'h args))))

[见 §15.1]
(defmacro compose (&rest fs)
  (let ((args (gensym)))
    (labels ((compose-fns (fs)
               (if (singlep fs)
                   `(apply ,(first fs) ,args)
                   (destructuring-bind (f . more) fs
                     (list (second f) (compose-fns more)))) ))
      (cond ((null fs) #'identity)
            ((singlep fs) (first fs))
            (t `#'(lambda (&rest ,args) ,(compose-fns fs)))) )))

Superficially it seems to work the same as the function version:
(macroexpand-1 '(compose #'f #'g #'h))
#'(LAMBDA (&REST #:G229) (F (G (APPLY #'H #:G229))))

(funcall (compose #'f #'g #'h) 8)
4913

Handles function literals too!
(macroexpand-1 '(compose #'(lambda (x) (expt x 3)) #'(lambda (x) (1+ x)) #'(lambda (x) (* 2 x))))
#'(LAMBDA (&REST #:G231)
    ((LAMBDA (X) (EXPT X 3))
     ((LAMBDA (X) (1+ X)) (APPLY #'(LAMBDA (X) (* 2 X)) #:G231))))

(funcall (compose #'(lambda (x) (expt x 3)) #'(lambda (x) (1+ x)) #'(lambda (x) (* 2 x))) 8)
4913

Looks like it works with partially applied functions (but this just got lucky):
(macroexpand-1 '(compose #'sqrt #'- (partial* #'expt 2)))
#'(LAMBDA (&REST #:G234) (SQRT (- (APPLY (PARTIAL* #'EXPT 2) #:G234))))

(funcall (compose #'sqrt #'- (partial* #'expt 2)) 5)
#C(0.0 5.0)

But it isn't foolproof:
(macroexpand-1 '(compose #'sqrt #'- (partial* #'expt 2) #'1+))
#'(LAMBDA (&REST #:G235) (SQRT (- (#'EXPT (APPLY #'1+ #:G235)))))                        <-- Oops. Partial function not built yet...


Furthermore, can't use COMPOSE itself as H.O. function:
- Args to COMPOSE (macro) must be known at compile time
(let* ((fns (list #'f #'g #'h))
       (f∘g∘h (apply #'compose fns)))
  (funcall f∘g∘h 8))

Preferable to use a function?
-------------------------------------------
Graham's version: [On Lisp 1994]
(defun compose (&rest fns)
  (if fns
      (let ((fn1 (car (last fns)))  <-- Forgot to use his own LAST1 function: (last1 fns)
            (fns (butlast fns)))
        #'(lambda (&rest args)
            (reduce #'funcall fns   <-- Composition occurs each time function is called!
                    :from-end t     <-- Can be costly to work backwards with list.
                    :initial-value (apply fn1 args)))) <-- Only innermost function gets APPLY
      #'identity))

Graham - process at runtime. Must fold right.
Me - compile nested LAMBDA. Normal function evaluation ensures innermost first.

Graham (ANSI Common Lisp 1996 110 页):
(defun compose (&rest fns)
  (destructuring-bind (fn1 . rest) (reverse fns)
    #'(lambda (&rest args)
        (reduce #'(lambda (v f) (funcall f v)) <-- Left fold. Must flip args around from above right fold.
                rest
                :initial-value (apply fn1 args)))) )
-------------------------------------------
Performance

** Hardwired
(flet ((f (x) (expt x 3))
       (g (x) (1+ x))
       (h (x) (* 2 x)))
  (let ((f∘g∘h #'(lambda (x) (f (g (h x)))) ))
    (time
      (loop for i from 1 to 1000000 do (funcall f∘g∘h i)))) )
Evaluation took:
  0.000 seconds of real time
  0.000180 seconds of total run time (0.000153 user, 0.000027 system)
  100.00% CPU
  569,522 processor cycles
  0 bytes consed
  
NIL

** Mine
(flet ((f (x) (expt x 3))
       (g (x) (1+ x))
       (h (x) (* 2 x)))
  (let ((f∘g∘h (compose #'f #'g #'h)))
    (time
      (loop for i from 1 to 1000000 do (funcall f∘g∘h i)))) )
Evaluation took:
  0.012 seconds of real time
  0.012374 seconds of total run time (0.008352 user, 0.004022 system)
  100.00% CPU
  39,456,382 processor cycles
  657 page faults
  2,686,992 bytes consed

** Modified (APPLY only on innermost function)
(flet ((f (x) (expt x 3))
       (g (x) (1+ x))
       (h (x) (* 2 x)))
  (let ((f∘g∘h (compose* #'f #'g #'h)))
    (time
      (loop for i from 1 to 1000000 do (funcall f∘g∘h i)))) )
Evaluation took:
  0.008 seconds of real time
  0.007957 seconds of total run time (0.007957 user, 0.000000 system)
  100.00% CPU
  25,384,992 processor cycles
  2,686,976 bytes consed
  
** Graham's
(flet ((f (x) (expt x 3))
       (g (x) (1+ x))
       (h (x) (* 2 x)))
  (let ((f∘g∘h (compose #'f #'g #'h)))
    (time
      (loop for i from 1 to 1000000 do (funcall f∘g∘h i)))) )
Evaluation took:
  0.028 seconds of real time
  0.028539 seconds of total run time (0.028410 user, 0.000129 system)
  [ Real times consist of 0.001 seconds GC time, and 0.027 seconds non-GC time. ]
  103.57% CPU
  90,961,333 processor cycles
  34,636,688 bytes consed
  
** MULTIPLE-VALUE-COMPOSE (see below)
(flet ((f (x) (expt x 3))
       (g (x) (1+ x))
       (h (x) (* 2 x)))
  (let ((f∘g∘h (multiple-value-compose #'f #'g #'h)))
    (time
      (loop for i from 1 to 1000000 do (funcall f∘g∘h i)))) )
Evaluation took:
  0.013 seconds of real time
  0.013333 seconds of total run time (0.013333 user, 0.000000 system)
  [ Real times consist of 0.001 seconds GC time, and 0.012 seconds non-GC time. ]
  100.00% CPU
  42,505,371 processor cycles
  34,652,208 bytes consed
  
-------------------------------------------
Handling functions that return multiple values

Binary operator:
(defun multiple-value-compose (f g)
  #'(lambda (&rest args)
      (apply f (multiple-value-list (apply g args)))) )

General-purpose:
(defun multiple-value-compose (&rest fs)
  (if (null fs)
      #'identity
      (reduce #'(lambda (f g)
                  #'(lambda (&rest args)
                      (multiple-value-call f (apply g args)))) ; Improved due to Alexandria
              fs)))

(funcall (multiple-value-compose #'mod #'floor) 11 3) => 1
(funcall (multiple-value-compose #'+ #'floor) 11 3) => 5
(funcall (multiple-value-compose #'expt #'truncate) 45 10) => 1024
(funcall (multiple-value-compose #'expt #'truncate) 4.5d0) => 2.0d0

This function handles all of the simpler cases above as well:
(funcall (multiple-value-compose #'abs #'expt) -3 5) => 243
(funcall (multiple-value-compose #'f #'g #'h) 8) => 4913
(funcall (multiple-value-compose #'intern (partial #'format nil "~A!") #'symbol-name) 'foo) => FOO!
(funcall (multiple-value-compose #'sqrt #'- (partial* #'expt 2)) 5) => #C(0.0 5.0)
-------------------------------------------
Define COMPLEMENT in terms of COMPOSE
(defun complement (pred)
  (compose #'not pred))

(partial #'compose #'not)


Clojure:
(defn comp
  "Takes a set of functions and returns a fn that is the composition
  of those fns.  The returned fn takes a variable number of args,
  applies the rightmost of fns to the args, the next
  fn (right-to-left) to the result, etc."
  {:added "1.0"
   :static true}
  ([] identity)
  ([f] f)
  ([f g] 
     (fn 
       ([] (f (g)))
       ([x] (f (g x)))
       ([x y] (f (g x y)))
       ([x y z] (f (g x y z)))
       ([x y z & args] (f (apply g x y z args)))))
  ([f g & fs]
     (reduce1 comp (list* f g fs))))

(defn complement
  "Takes a fn f and returns a fn that takes the same arguments as f,
  has the same effects, if any, and returns the opposite truth value."
  {:added "1.0"
   :static true}
  [f] 
  (fn 
    ([] (not (f)))
    ([x] (not (f x)))
    ([x y] (not (f x y)))
    ([x y & zs] (not (apply f x y zs)))))
-------------------------------------------
Function composition in Ruby:
https://en.wikipedia.org/wiki/Function_composition_(computer_science)#Ruby
f = proc{|x| x + 2}
g = proc{|x| x * 3}
(f << g).call(3) # -> 11; identical to f(g(3))
(f >> g).call(3) # -> 15; identical to g(f(3))
----------------------------------------------------------------------------
250710 木
Build a function that applies one function or another depending on result of a predicate:
(Hard to find a real use for this H.O. function...)

Example
Given a list of strings and symbols, map the symbols to lowercase strings of their names. Take strings "as is":
(mapcar #'(lambda (s) (if (symbolp s) (string-downcase (symbol-name s)) s)) '(a "foo" bar "PUNG"))
("a" "foo" "bar" "PUNG")

(mapcar (iffn #'symbolp (compose #'string-downcase #'symbol-name)) '(a "foo" bar "PUNG"))
("a" "foo" "bar" "PUNG")

[Graham FIF]
;(defun iffn (if then &optional (else (constantly nil)))
(defun iffn (if then &optional (else #'identity)) ; More useful??
  #'(lambda (x)
      (if (funcall if x)
	  (funcall then x)
	  (funcall else x))))

More (contrived?) examples
I. Given a list of integers, remove even numbers when negative, odd numbers when positive:
(remove-if (iffn #'evenp #'minusp #'plusp) (loop for i from -5 to 5 collect i))
(-5 -3 -1 0 2 4)

II. Given a list of numbers, take integers "as is", decompose floats into integer/fractional parts:
(mapcar (iffn #'integerp #'identity (multiple-value-compose #'list #'truncate)) (list 1 pi (sqrt 4) 6 (sqrt 8d0) 18/2))
(1 (3 0.14159265358979312d0) (2 0.0) 6 (2 0.8284271247461903d0) 9)
or
(mapcar (iffn (complement #'integerp) (multiple-value-compose #'list #'truncate)) (list 1 pi (sqrt 4) 6 (sqrt 8d0) 18/2))

III. Given a list of people, merely select first name for Ramones but collect first/last name for regular people:
(defclass person ()
  ((first-name :reader first-name :initarg :first)
   (last-name :reader last-name :initarg :last)))

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

(defvar *joey* (make-instance 'ramone :first "Joey"))
(defvar *dee-dee* (make-instance 'ramone :first "Dee Dee"))
(defvar *tommy* (make-instance 'ramone :first "Tommy"))
(defvar *johnny* (make-instance 'ramone :first "Johnny"))

(mapcar (iffn (partial* #'typep 'ramone) #'first-name (multiple-value-compose #'append (juxtapose #'first-name #'last-name))) (list *joey* *andy* *dee-dee*))
("Joey" ("Andy" "Warhol") "Dee Dee")
-------------------------------------------
Compute the conjunction or disjunction of a number of predicates
(and (integerp x) (plusp x) (evenp x))
(or (stringp x) (symbolp x) (numberp x))

Since AND and OR are macros, can't simply use APPLY/REDUCE, etc...

Graham defines the atrociously named FINT and FUN functions:
(defun fint (fn &rest fns)
  (if (null fns)
      fn
      (let ((chain (apply #'fint fns)))
        #'(lambda (x) 
            (and (funcall fn x) (funcall chain x))))))

(defun fun (fn &rest fns)
  (if (null fns)
      fn
      (let ((chain (apply #'fun fns)))
        #'(lambda (x)
            (or (funcall fn x) (funcall chain x))))))

(mapcar (fint #'integerp #'plusp #'evenp) '(-2 -1 0 1 2))
(NIL NIL NIL NIL T)
(mapcar (fun #'stringp #'symbolp #'numberp) '(a :a #\a "A" #xA))
(T T NIL T T)

Pro's
• One required predicate. Others allowed.
• Both short-circuit as AND/OR do.
• Entire function built at compile-time
• Preserve semantics of AND/OR WRT multiple values:
    (let ((x 8.2)) (or (truncate x))) => 8; 0.19999981                    
    (let ((x 8.2)) (funcall (fun #'truncate) x)) => 8; 0.19999981         
    (let ((x 8.2)) (or (truncate x) (integerp x))) => 8                   
    (let ((x 8.2)) (funcall (fun #'truncate #'integerp) x)) => 8          
                                                                          
    (let ((x 8.2)) (and (truncate x))) => 8; 0.19999981                   
    (let ((x 8.2)) (funcall (fint #'truncate) x)) => 8; 0.19999981        
    (let ((x 8.2)) (and (realp x) (truncate x))) => 8; 0.19999981         
    (let ((x 8.2)) (funcall (fint #'realp #'truncate) x)) => 8; 0.19999981

2 Deficiencies
1. Dumb names
2. Only single-arity predicates

1. Clojure has `every-pred' and `some-fn' functions:
• Slightly better names but weird semantics (See below)

(map (every-pred integer? pos? even?) '(-2 -1 0 1 2))
(false false false false true)
(map (some-fn string? symbol? number?) '(a :a \a "A" 16rA))
(true false false true true)

2. Can't do something like this:
Predicate with 2 args
(and (> x y) (zerop (mod x y)))

(funcall (fint #'> (compose #'zerop #'mod)) 4 3)
  invalid number of arguments: 2


Fixing Graham's names:
(defun every-pred (p &rest ps)
  (if (null ps)
      p
      (let ((chain (apply #'every-pred ps)))
        #'(lambda (x) (and (funcall p x) (funcall chain x)))) ))

(defun some-pred (p &rest ps)
  (if (null ps)
      p
      (let ((chain (apply #'some-pred ps)))
        #'(lambda (x) (or (funcall p x) (funcall chain x)))) ))

Still doesn't address 2nd point above.

Clojure's `every-pred' and `some-fn' take an odd turn. Rather than supporting multiple args, they
simply apply the compound predicate to single args in turn:

Expected:
((every-pred > #(zero? (mod %1 %2))) 4 2) ; Not 2-arg predicate
Wrong number of args (1) passed to: eval8025/fn--8026

Actual:
((every-pred integer? pos? even?) -2 -1 0 1 2) ; Repeatedly apply 1-arg predicate
false
((some-fn integer? pos? even?) -2 -1 0 1 2)
true
-------------------------------------------
In ANSI Common Lisp, Graham points out that the Lisp-influenced language Dylan defined `conjoin' and `disjoin'
functions (ACL 110 页)

They solve the 2nd issue above.

He gives the corresponding Common Lisp versions:
[Same fundamental design as his FINT/FUN]
(defun disjoin (fn &rest fns)
  (if (null fns)
      fn
      (let ((disj (apply #'disjoin fns)))
        #'(lambda (&rest args)
            (or (apply fn args) (apply disj args)))) ))

(defun conjoin (fn &rest fns)
  (if (null fns)
      fn
      (let ((conj (apply #'conjoin fns)))
        #'(lambda (&rest args)
            (and (apply fn args) (apply conj args)))) ))


Multiple args passed to predicate
(funcall (conjoin #'<) 2 3) => T

"Is x greater than y and is x divisible by y?"
(funcall (conjoin #'> (compose #'zerop #'mod)) 4 2) => T
(funcall (conjoin #'> (compose #'zerop #'mod)) 4 1) => T
(funcall (conjoin #'> (compose #'zerop #'mod)) 4 4) => NIL
(funcall (conjoin #'> (compose #'zerop #'mod)) 4 3) => NIL

Increasingly stricter criteria:
(funcall (conjoin #'>) 3 2) => T
(funcall (conjoin #'> (compose #'zerop #'mod)) 3 2) => NIL
-------------------------------------------
A different approach (inspired by Clojure):

Typical view of EVERY:
(every f args) ; Is F true for all ARGS?
(every #'evenp '(1 2 3 4 5))
           ^         ^
           |         |
           |         +-- Data
           +-- Predicate

Invert this so that the sequence of ARGS consists of the predicates:
(every #'(lambda (p) (funcall p -2)) (list #'integerp #'plusp #'evenp)) => NIL 
                                 ^      ^
                                 |      |
                                 |      +-- Multiple tests
                                 +-- Single datum
(every #'(lambda (p) (funcall p 2)) (list #'integerp #'plusp #'evenp)) => T

Generalize:
(defun disjoin (&rest ps)
  #'(lambda (&rest args)
      (some #'(lambda (p) (apply p args)) ps)))

(defun conjoin (&rest ps)
  #'(lambda (&rest args)
      (every #'(lambda (p) (apply p args)) ps)))

Achieve the Clojure behavior the normal way:
(every (conjoin #'> (compose #'zerop #'mod)) '(4 9 18) '(2 3 6)) => T
          ^                                    ^         ^
          |                                    |         |
          |                                    +---------+-- Potentially multiple sequences
          +-- Compound predicate
[This example takes both perspectives. Internally, the function built by CONJOIN
 uses EVERY to iterate across both supplied predicates. Then the explicit EVERY iterates
 pairwise over the 2 lists of numbers. Effectively:
(every #'(lambda (&rest args) (every #'(lambda (p) (apply p args)) (list #'> (compose #'zerop #'mod)))) '(4 9 18) '(2 3 6))]
   ^                             ^
   |                             |
   |                             +-- Iterate over predicates
   +-- Iterate over seq(s) of values
-------------------------------------------
Note that this version of CONJOIN has slightly different semantics than Graham's due
to the underlying behavior of EVERY vs. AND.

There are four sequence functions that allow us to examine 1+ sequences with respect to some predicate:
[https://www.lispworks.com/documentation/HyperSpec/Body/f_everyc.htm]
EVERY/SOME/NOTANY/NOTEVERY
EVERY and SOME are fundamental. The other two could be derived.
(every #'evenp '(1 2 3 4)) => NIL
(some #'evenp '(1 2 3 4)) => T
(some #'< '(1 2 3) '(2 3 4)) => T

CLHS says:
(notany predicate sequence*) ≡ (not (some predicate sequence*))
(notevery predicate sequence*) ≡ (not (every predicate sequence*))

Common Lisp exhibits a quirk here:
• EVERY returns true if the predicate is true when applied to all sequence elts.
• SOME returns the value returned by the predicate as soon as it is non-nil.
In other words, EVERY is itself a predicate, simply returning T or NIL. But SOME is
a pseudo-predicate in that SOME may return a "true" value other than T:
(some #'identity '(nil nil 5 nil)) => 5

[Due to this difference in semantics, Clojure stubbornly refuses to consider `some' a predicate.
 In Clojure, EVERY takes on the badge of a respectable predicate: every? but SOME is relegated
 to just `some'. This decision in turn opened the door to the entirely unrelated `some?' function
 resulting in no end of confusion. We see the same distinction between the `every-pred' and `some-fn' functions.]

This means that the behavior of SOME is more consistent with the behavior of OR, whereas
EVERY behaves differently from AND.

Graham sample definition (68 页):
[This is a rough sketch. The actual EVERY function operates on sequences rather than just lists
 (i.e., it handles vectors/strings too) and can process multiple sequences in parallel (i.e., 
 if F is a function of N variables -> N sequences).]
(defun every (f l)
  (if (null l)
      t
      (and (funcall f (first l))
           (every f (rest l)))) )

For example:
(or (char-upcase #\a) (char-upcase #\P)) => #\A
(some #'char-upcase '(#\a #\P)) => #\A

(and (char-upcase #\a) (char-upcase #\P)) => #\P; Value of last form
(every #'char-upcase '(#\a #\P)) => T ; Boolean

Consequently, building CONJOIN on top of EVERY produces slightly different results
than Graham's illustration which relies directly on AND:
(map 'list (conjoin #'alpha-char-p #'lower-case-p #'char-upcase) "Is this not pung?")
(NIL T NIL T T T T NIL T T T NIL T T T T NIL)
vs. Graham's version
(NIL #\S NIL #\T #\H #\I #\S NIL #\N #\O #\T NIL #\P #\U #\N #\G NIL)

[Since SOME is fundamentally more similar to OR, the difference doesn't show up in DISJOIN]

Go crazy!
(remove-if-not (conjoin #'evenp (partial* #'< 15)) #[1 20]) => (2 4 6 8 10 12 14)

(mapcar (conjoin #'integerp (disjoin (conjoin #'evenp #'plusp) (conjoin #'oddp #'minusp))) '(-4.0 -3 -2 -1 0 1 2 3 4.0))
(NIL T NIL T NIL NIL T NIL NIL)
vs.
(mapcar #'(lambda (x) (and (integerp x) (or (and (evenp x) (plusp x)) (and (oddp x) (minusp x)))) ) '(-4.0 -3 -2 -1 0 1 2 3 4.0))
(NIL T NIL T NIL NIL T NIL NIL)
-------------------------------------------
Using REDUCE (Not short-circuiting!!)
(defun conjoin (&rest ps)
  #'(lambda (&rest args)
      (reduce #'(lambda (b p) (and b (apply p args))) ps :initial-value t)))

(defun disjoin (&rest ps)
  #'(lambda (&rest args)
      (reduce #'(lambda (b p) (or b (apply p args))) ps :initial-value nil)))

Similar semantics to Graham's version:
(map 'list (conjoin #'alpha-char-p #'lower-case-p #'char-upcase) "Is this not pung?")
(NIL #\S NIL #\T #\H #\I #\S NIL #\N #\O #\T NIL #\P #\U #\N #\G NIL)
-------------------------------------------
Alexandria
日 250720

(defun ensure-function (function-designator)
  "Returns the function designated by FUNCTION-DESIGNATOR:
if FUNCTION-DESIGNATOR is a function, it is returned, otherwise
it must be a function name and its FDEFINITION is returned."
  (if (functionp function-designator)
      function-designator
      (fdefinition function-designator)))

(defun disjoin (predicate &rest more-predicates)
  "Returns a function that applies each of PREDICATE and MORE-PREDICATE
functions in turn to its arguments, returning the primary value of the first
predicate that returns true, without calling the remaining predicates.
If none of the predicates returns true, NIL is returned."
  (declare (optimize (speed 3) (safety 1) (debug 1)))
  (let ((predicate (ensure-function predicate))
	(more-predicates (mapcar #'ensure-function more-predicates)))
    (lambda (&rest arguments)
      (or (apply predicate arguments)                                <-- Why does this need special treatment?
	  (some (lambda (p)
		  (declare (type function p))
		  (apply p arguments))
		more-predicates)))))

(defun conjoin (predicate &rest more-predicates)
  "Returns a function that applies each of PREDICATE and MORE-PREDICATE
functions in turn to its arguments, returning NIL if any of the predicates
returns false, without calling the remaining predicates. If none of the
predicates returns false, returns the primary value of the last predicate."
  (if (null more-predicates)                                        <-- Why no ENSURE-FUNCTION?
      predicate
      (lambda (&rest arguments)
	(and (apply predicate arguments)
	     ;; Cannot simply use CL:EVERY because we want to return the    <-- As noted above, using EVERY is subtly different
	     ;; non-NIL value of the last predicate if all succeed.
	     (do ((tail (cdr more-predicates) (cdr tail))
		  (head (car more-predicates) (car tail)))
		 ((not tail)
		  (apply head arguments))
	       (unless (apply head arguments)
		 (return nil)))))))

They appear very concerned about preserving the semantics of AND in the definition of CONJOIN:
(let ((ch #\b)) (and (alpha-char-p ch) (lower-case-p ch) (char-upcase ch)))
#\B
(let ((ch #\B)) (and (alpha-char-p ch) (lower-case-p ch) (char-upcase ch)))
NIL

(let ((ch #\B)) (funcall (conjoin #'alpha-char-p #'lower-case-p #'char-upcase) ch))
NIL
(let ((ch #\b)) (funcall (conjoin #'alpha-char-p #'lower-case-p #'char-upcase) ch))
#\B

Multiple values with AND/OR:
• Quirk of AND/OR, multiple values only returned by last subform:
[https://www.lispworks.com/documentation/HyperSpec/Body/m_and.htm]
CLHS says:
    and passes back multiple values from the last subform but not from subforms other than the last.
Similarly for OR.

The issue is easier to observe with OR:
(or (floor 8 3)) => 2; 2
(or (floor 8 3) t) => 2

Normally, AND only returns a "true" value if all subforms including the last are true:
(let ((x 8)) (and (integerp x) (plusp x) (evenp x) (truncate x 3))) => 2; 2
Short-circuit evaluation typically fails with a simple NIL value:
(let ((x 5)) (and (integerp x) (plusp x) (evenp x) (truncate x 3))) => NIL 

However, in contrived cases we can see that AND only returns primary values for forms
other than the last subform just as with OR:
(and (values nil 8) t) => NIL
(and (values nil 8)) => NIL; 8


However, they don't quite maintain the behavior of OR in DISJOIN:
(let ((n 3)) (or (integerp n) (truncate n)))
T
(let ((n pi)) (or (integerp n) (truncate n)))
3
0.14159265358979312d0

(let ((n 3)) (funcall (disjoin #'integerp #'truncate) n))
T
(let ((n pi)) (funcall (disjoin #'integerp #'truncate) n))       <-- No multiple value
3

For what it's worth, CONJOIN goes all in:
(let ((n 3)) (and (floatp n) (truncate n)))
NIL
(let ((n pi)) (and (floatp n) (truncate n)))
3
0.14159265358979312d0

(let ((n 3)) (funcall (conjoin #'floatp #'truncate) n))
NIL
(let ((n pi)) (funcall (conjoin #'floatp #'truncate) n))
3
0.14159265358979312d0

-------------------------------------------
Partial functions revisited (improved by Alexandria)
日 250720

APPLY vs. MULTIPLE-VALUE-CALL (Special operator)

Different ways to invoke a function:
[In any case, invoked function does not know how it was called.]

(defun foo (a b c &optional d e)
  (list a b c d e))

(defun bar (a b c d e)
  (list a b c d e))


If everything is known at compile-time, just call the function:
(foo 1 2 3 4 5) => (1 2 3 4 5)


If some decisions need to be made at runtime: (e.g., H.O. function)
(let ((f #'foo))
  (funcall f 1 2 3 4 5))
=> (1 2 3 4 5)

(let ((f #'foo))
  (apply f '(1 2 3 4 5)))
=> (1 2 3 4 5)

(let ((f #'foo))
  (multiple-value-call f (values-list '(1 2 3 4 5)))) ; Flattened? Sort of like FUNCALL?
=> (1 2 3 4 5)


Two partial lists of args?
(let ((f #'foo))
  (apply f '(1 2) '(3 4 5))) ; Doesn't work!!
=> ((1 2) 3 4 5 NIL)

(let ((f #'foo))
  (apply f (append '(1 2) '(3 4 5)))) ; APPEND creates new list
=> (1 2 3 4 5)

(let ((f #'foo))
  (multiple-value-call f (values-list '(1 2)) (values-list '(3 4 5)))) ; No CONSing
=> (1 2 3 4 5)

With partial function application:
• Some args are fixed. Some are supplied when function is called.
(f fixed args) "Left curry"
(f args fixed) "Right curry"

Example:
• Is 2 < x?
(funcall (partial #'< 2) x)
• Is x < 2?
(funcall (partial* #'< 2) x)
[Alternatively: (funcall (partial #'> 2) x)]

Alexandria:
(defun curry (function &rest arguments)
  "Returns a function that applies ARGUMENTS and the arguments
it is called with to FUNCTION."
  (declare (optimize (speed 3) (safety 1)))
  (let ((fn (ensure-function function)))
    (lambda (&rest more)
      (declare (dynamic-extent more))
      ;; Using M-V-C we don't need to append the arguments.
      (multiple-value-call fn (values-list arguments) (values-list more)))))

(define-compiler-macro curry (function &rest arguments)
  (let ((curries (make-gensym-list (length arguments) "CURRY"))
        (fun (gensym "FUN")))
    `(let ((,fun (ensure-function ,function))
           ,@(mapcar #'list curries arguments))
       (declare (optimize (speed 3) (safety 1)))
       (lambda (&rest more)
         (declare (dynamic-extent more))
         (apply ,fun ,@curries more)))))

(defun rcurry (function &rest arguments)
  "Returns a function that applies the arguments it is called
with and ARGUMENTS to FUNCTION."
  (declare (optimize (speed 3) (safety 1)))
  (let ((fn (ensure-function function)))
    (lambda (&rest more)
      (declare (dynamic-extent more))
      (multiple-value-call fn (values-list more) (values-list arguments)))))


"Left curry"
(defun partial (f &rest fixed)
  "Create a partial function that calls F with 0+ fixed arguments. The remaining arguments are to be supplied when the function is called."
  (if (null fixed)
      f
      (destructuring-bind (fixed0 &rest fixed) fixed
        (if (null fixed)
            #'(lambda (&rest args) (apply f fixed0 args))
            (destructuring-bind (fixed1 &rest fixed) fixed
              (if (null fixed)
                  #'(lambda (&rest args) (apply f fixed0 fixed1 args))
                  (destructuring-bind (fixed2 &rest fixed) fixed
                    (if (null fixed)
                        #'(lambda (&rest args) (apply f fixed0 fixed1 fixed2 args))
                        #'(lambda (&rest args)
                            (multiple-value-call f fixed0 fixed1 fixed2 (values-list fixed) (values-list args)))) )))) )))
;                            (apply f fixed0 fixed1 fixed2 (append fixed args)))) )))) )))


"Right curry"
(defun partial* (f &rest fixed)
  "Create a partial function that calls F with 0+ fixed arguments following the remaining arguments supplied when the function is called."
  (if (null fixed)
      f
      #'(lambda (&rest args)
          (apply f (append args fixed)))) )

(defun partial** (f &rest fixed)
  "Create a partial function that calls F with 0+ fixed arguments following the remaining arguments supplied when the function is called."
  (if (null fixed)
      f
      (destructuring-bind (fixed0 &rest fixed) fixed
        (if (null fixed)
            #'(lambda (&rest args) (multiple-value-call f (values-list args) fixed0))
            (destructuring-bind (fixed1 &rest fixed) fixed
              (if (null fixed)
                  #'(lambda (&rest args) (multiple-value-call f (values-list args) fixed0 fixed1))
                  (destructuring-bind (fixed2 &rest fixed) fixed
                    (if (null fixed)
                        #'(lambda (&rest args) (multiple-value-call f (values-list args) fixed0 fixed1 fixed2))
                        #'(lambda (&rest args)
                            (multiple-value-call f (values-list args) fixed0 fixed1 fixed2 (values-list fixed)))) )))) )))

(defun partial*** (f &rest fixed)
  "Create a partial function that calls F with 0+ fixed arguments following the remaining arguments supplied when the function is called."
  (if (null fixed)
      f
      (destructuring-bind (fixed0 &rest fixed) fixed
        (if (null fixed)
            #'(lambda (&rest args)
                (if (null args)
                    (funcall f fixed0)
                    (destructuring-bind (arg0 &rest args) args
                      (if (null args)
                          (funcall f arg0 fixed0)
                          (destructuring-bind (arg1 &rest args) args
                            (if (null args)
                                (funcall f arg0 arg1 fixed0)
                                (destructuring-bind (arg2 &rest args) args
                                  (if (null args)
                                      (funcall f arg0 arg1 arg2 fixed0)
                                      (multiple-value-call f arg0 arg1 arg2 (values-list args) fixed0)))) )))) )
            (destructuring-bind (fixed1 &rest fixed) fixed
              (if (null fixed)
                  #'(lambda (&rest args)
                      (if (null args)
                          (funcall f fixed0 fixed1)
                          (destructuring-bind (arg0 &rest args) args
                            (if (null args)
                                (funcall f arg0 fixed0 fixed1)
                                (destructuring-bind (arg1 &rest args) args
                                  (if (null args)
                                      (funcall f arg0 arg1 fixed0 fixed1)
                                      (destructuring-bind (arg2 &rest args) args
                                        (if (null args)
                                            (funcall f arg0 arg1 arg2 fixed0 fixed1)
                                            (multiple-value-call f arg0 arg1 arg2 (values-list args) fixed0 fixed1)))) )))) )
                  (destructuring-bind (fixed2 &rest fixed) fixed
                    (if (null fixed)
                        #'(lambda (&rest args)
                            (if (null args)
                                (funcall f fixed0 fixed1 fixed2)
                                (destructuring-bind (arg0 &rest args) args
                                  (if (null args)
                                      (funcall f arg0 fixed0 fixed1 fixed2)
                                      (destructuring-bind (arg1 &rest args) args
                                        (if (null args)
                                            (funcall f arg0 arg1 fixed0 fixed1 fixed2)
                                            (destructuring-bind (arg2 &rest args) args
                                              (if (null args)
                                                  (funcall f arg0 arg1 arg2 fixed0 fixed1 fixed2)
                                                  (multiple-value-call f arg0 arg1 arg2 (values-list args) fixed0 fixed1 fixed2)))) )))) )
                        #'(lambda (&rest args)
                            (if (null args)
                                (multiple-value-call f fixed0 fixed1 fixed2 (values-list fixed))
                                (destructuring-bind (arg0 &rest args) args
                                  (if (null args)
                                      (multiple-value-call f arg0 fixed0 fixed1 fixed2 (values-list fixed))
                                      (destructuring-bind (arg1 &rest args) args
                                        (if (null args)
                                            (multiple-value-call f arg0 arg1 fixed0 fixed1 fixed2 (values-list fixed))
                                            (destructuring-bind (arg2 &rest args) args
                                              (if (null args)
                                                  (multiple-value-call f arg0 arg1 arg2 fixed0 fixed1 fixed2 (values-list fixed))
                                                  (multiple-value-call f arg0 arg1 arg2 (values-list args) fixed0 fixed1 fixed2 (values-list fixed)))) )))) )))) )))) ))



(let ((f (partial* #'< 5 6 7 8)))
(time (dotimes (i 1000000) (funcall f 1 2 3 4))))
Evaluation took:
  0.036 seconds of real time
  0.036869 seconds of total run time (0.036840 user, 0.000029 system)
  [ Real times consist of 0.002 seconds GC time, and 0.034 seconds non-GC time. ]
  [ Run times consist of 0.001 seconds GC time, and 0.036 seconds non-GC time. ]
  102.78% CPU
  117,450,751 processor cycles
  127,994,704 bytes consed
  
(let ((f (partial** #'< 5 6 7 8)))
(time (dotimes (i 1000000) (funcall f 1 2 3 4))))
Evaluation took:
  0.023 seconds of real time
  0.022132 seconds of total run time (0.022132 user, 0.000000 system)
  95.65% CPU
  70,534,957 processor cycles
  0 bytes consed
  
NIL
*

(let ((f (partial*** #'< 5 6 7 8)))
(time (dotimes (i 1000000) (funcall f 1 2 3 4))))
Evaluation took:
  0.029 seconds of real time
  0.029317 seconds of total run time (0.028318 user, 0.000999 system)
  [ Real times consist of 0.001 seconds GC time, and 0.028 seconds non-GC time. ]
  [ Run times consist of 0.002 seconds GC time, and 0.028 seconds non-GC time. ]
  100.00% CPU
  93,430,270 processor cycles
  63,988,432 bytes consed                   <--- ?????????????????????????
  
NIL
* 

* (let ((f (rcurry #'< 5 6 7 8)))
(time (dotimes (i 1000000) (funcall f 1 2 3 4))))
Evaluation took:
  0.016 seconds of real time
  0.016410 seconds of total run time (0.016410 user, 0.000000 system)
  100.00% CPU
  52,299,502 processor cycles
  0 bytes consed
  
NIL

PARTIAL** is competitive with RCURRY with the same declaration:
(declare (optimize (speed 3) (safety 1)))

Clojure style:
(defn partial
  "Takes a function f and fewer than the normal arguments to f, and
  returns a fn that takes a variable number of additional args. When
  called, the returned function calls f with args + additional args."
  {:added "1.0"
   :static true}
  ([f] f)
  ([f arg1]
   (fn
     ([] (f arg1))
     ([x] (f arg1 x))
     ([x y] (f arg1 x y))
     ([x y z] (f arg1 x y z))
     ([x y z & args] (apply f arg1 x y z args))))
  ([f arg1 arg2]
   (fn
     ([] (f arg1 arg2))
     ([x] (f arg1 arg2 x))
     ([x y] (f arg1 arg2 x y))
     ([x y z] (f arg1 arg2 x y z))
     ([x y z & args] (apply f arg1 arg2 x y z args))))
  ([f arg1 arg2 arg3]
   (fn
     ([] (f arg1 arg2 arg3))
     ([x] (f arg1 arg2 arg3 x))
     ([x y] (f arg1 arg2 arg3 x y))
     ([x y z] (f arg1 arg2 arg3 x y z))
     ([x y z & args] (apply f arg1 arg2 arg3 x y z args))))
  ([f arg1 arg2 arg3 & more]
   (fn [& args] (apply f arg1 arg2 arg3 (concat more args)))))

----------------------------------------------------------------------------
250725 金
§5.5 Recursion on CDRs
Pattern - recurse across list
(defun length (l)
  (if (null l)
      0
      (1+ (length (rest l)))) )

(defun every (f l)
  (if (null l)
      t
      (and (funcall f (first l))
           (every f (rest l)))) )

Substantial differences!
• Tail recursive vs. not
• EVERY may terminate before end of list.
• Different arity!

LREC ("List recurser")
Generalizes functions that recursively traverse a list.

Graham's original:
LABELS creates a named closure to allow recursive calls.
Can't just use #'(lambda ...) -- Anonymous.
[See also: Y-Combinator https://groups.google.com/g/clojure/c/yb1OeeWHemY]
(defun lrec (rec &optional base)
  (labels ((self (lst)
             (if (null lst)
                 (if (functionp base)
                     (funcall base)
                     base)
                 (funcall rec (car lst)
                              #'(lambda () 
                                  (self (cdr lst)))))))
    #'self))

But we know whether BASE is a function. Why not construct separate functions?
(defun lrec (rec &optional base)
  (labels ((function-base (l)
             (if (null l)
                 (funcall base)  ; 0-arg function?!?
                 (funcall rec (first l) #'(lambda () (function-base (rest l)))) ))
           (atom-base (l)
             (if (null l)
                 base
                 (funcall rec (first l) #'(lambda () (atom-base (rest l)))) )))
    (if (functionp base) #'function-base #'atom-base)))

LENGTH:
(funcall (lrec #'(lambda (x f) (declare (ignore x)) (1+ (funcall f))) 0) '()) => 0
(funcall (lrec #'(lambda (x f) (declare (ignore x)) (1+ (funcall f))) 0) '(a b c d)) => 4


EVERY:
(funcall (lrec #'(lambda (x f) (and (oddp x) (funcall f))) t) '(1 2 3 4)) => NIL ; Hard-wired ODDP. No general EVERY????
(funcall (lrec #'(lambda (x f) (and (oddp x) (funcall f))) t) '(1 3 5 7 9)) => T

Effectively:
(defun every-oddp (l)
  (if (null l)
      t
      (funcall #'(lambda (x f) (and (oddp x) (funcall f)))
               (first l)
               #'(lambda () (every-oddp (rest l)))) ))

vs.
Naive:
(defun every-oddp (l)
  (if (null l)
      t
      (and (oddp (first l))
           (every-oddp (rest l)))) )


(funcall (partial #'every #'oddp) '(1 3 5 7 9)) => T
(funcall (partial #'every #'oddp) '(1 2 3 4)) => NIL

Need wrapper?
(defun every (p l) ; Only works on single list (not multiple sequences...)
  (funcall (lrec #'(lambda (x f) (and (funcall p x) (funcall f))) t) l))

(every #'oddp '(1 3 5 7 9)) => T


FIND-IF:
(funcall (lrec #'(lambda (x f) (if (oddp x) x (funcall f)))) '(2 4 5 6 8)) => 5


SOME:
(funcall (lrec #'(lambda (x f) (or (oddp x) (funcall f)))) '(1 2 3 4)) => T


COPY-LIST:
(funcall (lrec #'(lambda (x f) (cons x (funcall f)))) '(a (b c) d e (f))) => (A (B C) D E (F))


ADJOIN-LIST:
(funcall (lrec #'(lambda (x f) (adjoin x (funcall f)))) '(a (b c) d e (f))) => (A (B C) D E (F))

(funcall (lrec #'(lambda (x f) (cons x (funcall f)))) '(a b c a c d a b)) => (A B C A C D A B) ; COPY-LIST (CONS)
(funcall (lrec #'(lambda (x f) (adjoin x (funcall f)))) '(a b c a c d a b)) => (C D A B) ; ADJOIN-LIST (ADJOIN)

Graham acknowledges that LREC (and other recurer generators, e.g., TREC) will not always produce
the most efficient implementation of a desired function. Moreover, the use of LREC precludes
tail-recursive function definitions. Consequently they should be used "in initial versions of a program,
or in parts where speed is not critical".

This guidance runs counter to his stated goals in ch. 4 (44 页):
    Such examples show that it’s especially important to write utilities for situations    
    we might otherwise handle inefficiently. A language augmented with the right           
    utilities will lead us to write more abstract programs. If these utilities are properly
    defined, it will also lead us to write more efficient ones.

Yet LREC is knowingly being used to produce less efficient utility functions.

In my view, LREC is a dud. It is a wrong turn down an alley for the sake of forced refactoring.
Not all patterns need an abstraction layer. Here the use of LREC results in convoluted, less flexible,
less efficient code than what one would ordinarily write.
-------------------------------------------
Similar forced refactoring
(defun member (obj set &key (test #'eql))
  (cond ((null set) nil)
        ((funcall test obj (first set)) set)
        (t (member obj (rest set) :test test))))

(defun union (a b)
  (cond ((null a) b)
        ((member (first a) b) (union (rest a) b))
        (t (cons (first a) (union (rest a) b)))) )

(defun intersection (a b)
  (cond ((null a) '())
        ((member (first a) b) (cons (first a) (intersection (rest a) b)))
        (t (intersection (rest a) b))))

(defun set-difference (a b)
  (cond ((null a) '())
        ((member (first a) b) (set-difference (rest a) b))
        (t (cons (first a) (set-difference (rest a) b)))) )

vs.

(defun set-operation (a b base in out)
  (cond ((null a) base)
        ((member (first a) b) (funcall in a b))
        (t (funcall out a b))))

(defun union (a b)
  (set-operation a b b #'(lambda (a b) (union (rest a) b)) #'(lambda (a b) (cons (first a) (union (rest a) b)))) )

(defun intersection (a b)
  (set-operation a b '() #'(lambda (a b) (cons (first a) (intersection (rest a) b))) #'(lambda (a b) (intersection (rest a) b))) )

(defun set-difference (a b)
  (set-operation a b '() #'(lambda (a b) (set-difference (rest a) b)) #'(lambda (a b) (cons (first a) (set-difference (rest a) b)))) )
-------------------------------------------
§5.6 Recursion on Subtrees
See RMAPCAR above

(defun ttrav (rec &optional (base #'identity))
  (labels ((self (tree)
             (if (atom tree)
                 (if (functionp base)
                     (funcall base tree)
                     base)
                 (funcall rec (self (car tree))
                              (if (cdr tree) 
                                  (self (cdr tree)))))))
    #'self))

Differences from LREC above:
• REC is function of 2 args. One for the CAR and one for the CDR.
• While traversing a list, base case is simply NIL (end of list).
  For tree, leaf node might have more interesting value. Thus, in LREC,
  BASE is simply a constant (0-arg function), whereas in TTRAV, BASE
  takes a single arg corresponding to the leaf node on which it is operating.

Examples
(Graham points out that these are stylized versions of the conventional functions
to "make the pattern obvious".)

COPY-TREE:
(defun copy-tree (obj)
  (if (atom obj)
      obj
      (cons (copy-tree (car obj))
            (if (cdr obj) (copy-tree (cdr obj)))) )) ; Idiosyncratic IF (no ELSE)

(funcall (ttrav #'cons) '(a (b c) (d ((e))))) => (A (B C) (D ((E))))

COUNT-LEAVES:
(defun count-leaves (obj)
  (if (atom obj)
      1 ; Counts NILs as leaves
      (+ (count-leaves (car obj))
         (or (if (cdr obj) (count-leaves (cdr obj)))
             1))))

(funcall (ttrav #'(lambda (l r) (+ l (or r 1))) 1) '((a b (c d)) (e) f)) => 10

FLATTEN:
(defun flatten (obj)
  (if (atom obj)
      (mklist obj)
      (nconc (flatten (car obj))
             (if (cdr obj) (flatten (cdr obj)))) ))

(funcall (ttrav #'nconc #'mklist) '(((1 (2 (3) (4 5 6)))))) => (1 2 3 4 5 6)

Functions built by TTRAV always traverse entire tree. To control when recursive calls are made:
TTRAV first arg -> function that operates on _results_ of recursive calls

Instead, create closures representing the recursive calls:
(defun trec (rec &optional (base #'identity))
  (labels 
    ((self (tree)
       (if (atom tree)
           (if (functionp base)
               (funcall base tree)
               base)
           (funcall rec tree 
                        #'(lambda () 
                            (self (car tree)))
                        #'(lambda () 
                            (if (cdr tree)
                                (self (cdr tree))))))))
    #'self))

Alternative FLATTEN:
(Unconditionally recurs through entire tree)
(funcall (trec #'(lambda (o l r) (declare (ignore o)) (nconc (funcall l) (funcall r))) #'mklist) '(((1 (2 (3) (4 5 6)))))) => (1 2 3 4 5 6)

RFIND-IF: (Not possible to define with TTRAV.)
Tree analog to FIND-IF sequence function

(defun rfind-if (fn obj)
  (if (atom obj)
      (and (funcall fn obj) obj)
      (or (rfind-if fn (car obj))
          (if (cdr obj) (rfind-if fn (cdr obj)))) ))

(funcall (trec #'(lambda (o l r) (declare (ignore o)) (or (funcall l) (funcall r))) #'(lambda (tree) (and (oddp tree) tree))) '(2 (3 4) 5)) => 3
                                                       ^^^^^^^^^^^^^^^^^^^^^^^^^
                                                       Conditional recursion down right subtree.
                                                       
Note that this once again conflates the general purpose (RFIND-IF) with the specific (ODDP). This
function would rightly be called RFIND-IF-ODDP (See EVERY-ODDP above).

These functions look like dead ends just like LREC.
-------------------------------------------
250801 金
Touretzky's recursion templates (ch. 8) preferable to Graham's "archetypal functions"?

Single-Test Tail Recursion

Template:
(DEFUN func (X)
  (COND (end-test end-value)
        (T (func reduced-x))))

Example:
Func: FIND-FIRST-ATOM
End-test: (ATOM X)
End-value: X
Reduced-x: (FIRST X)

(defun find-first-atom (x)
  (cond ((atom x) x)
        (t (find-first-atom (first x)))))


CAR/CDR Recursion (A Special Case of Multiple Recursion)

Template:

(DEFUN func (X)
  (COND (end-test-1 end-value-1)
        (end-test-2 end-value-2)
        (T (combiner (func (CAR X))
                     (func (CDR X))))))

Example:
Func: FIND-NUMBER
End-test-1: (NUMBERP X)
End-value-1: X
End-test-2: (ATOM X)
End-value-2: NIL
Combiner: OR

(defun find-number (x)
  (cond ((numberp x) x)
        ((atom x) nil)
        (t (or (find-number (car x))
               (find-number (cdr x))))))


Chapter 6
============================================================================
☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆
============================================================================
250821 木
Graham discusses using closures to represent "things" as an alternative to data structures.
  "To represent with closures" is another way of saying "to compile". (More extensive examples in ch. 23, 24)

Chapter 10 of The Little Lisper introduces a similar idea. Rather than representing a CONS as merely
a pair of pointers to its CAR and CDR, create a closure that captures the CAR and CDR values:
(shadow '(cons car cdr))
(defun cons (u v)
  #'(lambda (b)
      (cond (b u)
            (t v))))

(defvar *lunch* (cons 'apple '()))

*LUNCH* is a function. Pass in boolean value to select CAR/CDR:
(defun car (l)
  (funcall l t))

(defun cdr (l)
  (funcall l nil))

Building up a "list" does not produce recognizable CDRs. But operationally CAR works as expected.
(car *lunch*) => APPLE
(cdr *lunch*) => NIL
(cons 'banana *lunch*) => #<CLOSURE (LAMBDA (B) :IN CONS) {10026C861B}>
(car *) => BANANA
(cdr **) => #<CLOSURE (LAMBDA (B) :IN CONS) {100241F38B}>
(car (cdr ***)) => APPLE

(car (cons 'a '())) => A
(cdr (cons 'a '())) => NIL
(car (cons 'a (cons 'b (cons 'c '())))) => A
(cdr (cons 'a (cons 'b (cons 'c '())))) => #<FUNCTION (LAMBDA (B) :IN CONS) {1003DEFBBB}>
(car (cdr (cons 'a (cons 'b (cons 'c '()))))) => B

Example:
PERSON as closure rather than structure/object...
 - Parameters as fields
 - All of this could be bundled into a macro to define accessors.

(defun person (name age)
  #'(lambda (command)
      (case command
        (name name)
        (age age))))

(defun age (person)
  (funcall person 'age))

(defun name (person)
  (funcall person 'name))

(name (person "Ed" 25)) => "Ed"
(age (person "MJO" 24)) => 24

A related discussion in
Ron Garret's The Idiot's Guide to Special Variables and Lexical Closures [https://flownet.com/ron/]
    (defun up-n-down ()                                                                 
      (let ((x 0))                                                                      
        (list #'(lambda () (incf x))                                                    
              #'(lambda () (decf x)))) )                                                
                                                                                        
    (defvar *l1* (up-n-down))                                                           
    (defvar *l2* (up-n-down))                                                           
                                                                                        
    (funcall (first *l1*)) => 1                                                         
    (funcall (first *l1*)) => 2                                                         
    (funcall (first *l1*)) => 3                                                         
    (funcall (second *l1*)) => 2                                                        
                                                                                        
    (funcall (first *l2*)) => 1                                                         
    (funcall (first *l2*)) => 2                                                         
    (funcall (first *l2*)) => 3                                                         
    (funcall (second *l2*)) => 2                                                        
                                                                                        
    By now this should all make perfect sense. When we call up-n-down we get a new      
    binding for X (established by the LET). This binding is then captured by the        
    LAMBDA forms. Both lambdas in the list capture the same binding every time up-      
    n-down is called, and every time we call up-n-down we get a (one) new binding.      
                                                                                        
    Notice how much the list returned by up-n-down resembles an object with one         
    slot and two methods. That is in fact precisely what it is. This is why when a Lisp 
    programmer learns a new programming language one of the first questions they        
    will ask is, "does it have closures?" Because if you have closures you can build an 
    OO system (and just about anything else you need) out of them. It is, alas, much    
    harder to go the other way.


Chapter 7
============================================================================
☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆
============================================================================
250913 土
Touretzky (405 页):
    Think of macros as the computer equivalent of shorthand. Anything you write 
    in shorthand can also be written in plain English; it just takes longer.    
    Similarly, Common Lisp macros don’t let you say anything that can’t be      
    expressed with ordinary functions, but they do help you to say things more  
    concisely.

But Seibel (83 页) describes the power/efficiency/clarity achievable through the
proper use of macros as the "have-your-cake-and-eat-it-too style of programming".

Macros don't allow you to write code that you _couldn't_ write otherwise. Instead,
they allow you to write code that you _wouldn't_ write.

In chapter 8, Seibel (102 页) shows how to define simple macros "that save you a bit of typing
but don't provide radical new ways of expressing things". But he points out that there are more powerful
macros in later chapters "that allow you to express things in ways that would be virtually impossible without macros".

250906 土
Preface vi 页
"One of the aims of this book is to collect in one place 
 all that people have till now had to learn from experience about macros."

Ch. 7-10 Complete tutorial on macro technique

250822 金
Macros - define operators that are implemented by transformation

A macro is "a function that generates Lisp code--a program that writes programs".

Function ------> value
Macro ---------> expresion ----------> value
      expansion            evaluation

Expression generated by macro expansion is evaluated instead of original macro call.

Ultimately, code only consists of:
- Special forms
- Function forms

Graham's example:
Macro NIL! sets argument to NIL
(nil! x) => (setf x nil)

(defmacro nil! (var)
  (list 'setf var nil))

Single expansion step:
(macroexpand-1 '(nil! x))
(SETF X NIL)
T

Full expansion--SETF is itself a macro:
(macroexpand '(nil! x))
(SETQ X NIL)
T

CLHS says:
    In effect, macroexpand calls macroexpand-1 repeatedly until the secondary value it returns is nil. 

The place being set to NIL can be specified by arbitrary expression:
(macroexpand-1 '(nil! (aref a i)))
(SETF (AREF A I) NIL)
T

More complicated full expansion:
(macroexpand '(nil! (aref a i)))
(LET* ((#:A2108 A) (#:I2109 I) (#:NEW2107 NIL))
  (FUNCALL #'(SETF AREF) #:NEW2107 #:A2108 #:I2109))
T

By contrast, consider a function that builds the same expression:
(defun nil? (var)
  (list 'setf var nil))

(nil? 'x) => (SETF X NIL) ; This list is returned but not evaluated.
       ^
       |
       |
       Must quote symbol as part of function evaluation.

[*|*]--->[*|*]--->NIL
 |        |
 v        v
NIL?     [*|*]--->[*|*]--->NIL
          |        |
          v        v
         QUOTE     X

Alternative definition of NIL! using helper function:
(defmacro nil! (var)
  (nil? var))

Exactly same behavior as before:
(macroexpand-1 '(nil! x))
(SETF X NIL)
T

Possible to observe the expansion:
(trace nil?)
(NIL?)

(macroexpand-1 '(nil! x))
  0: (NIL? X)
  0: NIL? returned (SETF X NIL)
(SETF X NIL)
T

Below we will see a more convenient way to write the template list structure using backquote (`):
(defmacro nil! (var)
  `(setf ,var nil))
-------------------------------------------
Form created              Expansion for EVAL:
by reader:
[*|*]--->[*|*]--->NIL  => [*|*]--->[*|*]--->[*|*]--->NIL
 |        |                |        |        |          
 v        v                v        v        v          
NIL!      X               SETF      X       NIL          

 ^
 |
 |
 Macro form. CAR names macro.

CLHS Glossary
[https://www.lispworks.com/documentation/HyperSpec/Body/26_glo_m.htm#macro_form]
macro form n. a form that stands for another form (e.g., for the purposes of abstraction,
              information hiding, or syntactic convenience); that is, either a compound form
              whose first element is a macro name, or a form that is a symbol that names a symbol macro. 


https://www.lispworks.com/documentation/HyperSpec/Body/03_ababb.htm
    3.1.2.1.2.2 Macro Forms                                                                                                     
                                                                                                                                
    If the operator names a macro, its associated macro function is applied to the entire form                                  
    and the result of that application is used in place of the original form.                                                   
                                                                                                                                
    The function returned by MACRO-FUNCTION is a function of two arguments, called the expansion function.                      
                                                                                                                                
    The expansion function is invoked by calling the macroexpand hook with the expansion function as its first argument,        
    the entire macro form as its second argument, and an environment object (corresponding to the current lexical environment)  
    as its third argument.                                                                                                      
                                                                                                                                
    The macroexpand hook, in turn, calls the expansion function with the form as its first argument and                         
    the environment as its second argument. The value of the expansion function, which is passed through                        
    by the macroexpand hook, is a form. The returned form is evaluated in place of the original form.


      (Entire)        +------------------+          
   Original Form ---->|                  |          
                      |Expansion function|----> Form
     Environment ---->|                  |          
                      +------------------+          

MACRO-FUNCTION and SYMBOL-FUNCTION return different values???

(describe (macro-function 'nil!))
#<FUNCTION (MACRO-FUNCTION NIL!) {B800D08A0B}>
  [compiled function]


Lambda-list: (VAR)                                             <-- ??
Derived type: (FUNCTION (T T) (VALUES CONS &OPTIONAL))
Documentation:
  T
Source form:
  (LAMBDA (#1=#:EXPR #2=#:ENV)                                 <-- Actually takes 2 args: EXPR and ENV
    (DECLARE (SB-C::LAMBDA-LIST (VAR)))                        <-- ??
    (DECLARE (IGNORE #2#))
    (SB-INT:NAMED-DS-BIND (:MACRO NIL! . DEFMACRO)
        (VAR)
        (CDR #1#)
      (DECLARE (SB-C::CONSTANT-VALUE VAR))
      (BLOCK NIL! `(SETF ,VAR NIL))))

(describe (symbol-function 'nil!))                             <-- Implementation-dependent
#<FUNCTION (:MACRO NIL!) {1004FF70DB}>
  [compiled closure]


Lambda-list: (&REST ARGS)
Derived type: (FUNCTION (&REST T) NIL)
Documentation:
  T
Source file: SYS:SRC;CODE;SIMPLE-FUN.LISP
-------------------------------------------
DEFMACRO is itself a macro. DEFMACRO forms can be expanded:
(macroexpand-1 '(defmacro nil! (var)
                  (list 'setf var nil)))

(PROGN
 (EVAL-WHEN (:COMPILE-TOPLEVEL)
   (SB-C::%COMPILER-DEFMACRO :MACRO-FUNCTION 'NIL!))
 (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
   (SB-C::%DEFMACRO 'NIL!
                    (SB-INT:NAMED-LAMBDA (MACRO-FUNCTION NIL!)
                        (#:EXPR #:ENV)
                      (DECLARE (SB-C::LAMBDA-LIST (VAR)))
                      (DECLARE (IGNORE #:ENV))
                      (SB-INT:NAMED-DS-BIND (:MACRO NIL! . DEFMACRO)
                          (VAR)
                          (CDR #:EXPR)
                        (DECLARE (SB-C::CONSTANT-VALUE VAR))
                        (BLOCK NIL! (LIST 'SETF VAR NIL))))
                    (SB-C:SOURCE-LOCATION))))
-------------------------------------------
Variable *MACROEXPAND-HOOK* [https://www.lispworks.com/documentation/HyperSpec/Body/v_mexp_h.htm]
  a designator for a function that is equivalent to the function FUNCALL,
  but that might have additional implementation-dependent side-effects.

Define a custom macroexpansion hook that only treats NIL! forms specially:
(Don't want to debug every macro expansion!!!)

(defun hook (expander form env)
  (when (eq (first form) 'nil!)
    (format t "Expanding: ~S~%" form)
    (format t "Expansion function: ~S~%" expander)
    (describe expander)
    (format t "Environment: ~S~%" env))
  (funcall expander form env))                          <---- End with normal call to FUNCALL with 3 args: expander function, full form to expand, environment

(setf *macroexpand-hook* #'hook)

(macroexpand-1 '(nil! x))
Expanding: (NIL! X)
Expansion function: #<FUNCTION (MACRO-FUNCTION NIL!) {B800D08A0B}>       <---- FORMAT
#<FUNCTION (MACRO-FUNCTION NIL!) {B800D08A0B}>                           <---- DESCRIBE
  [compiled function]


Lambda-list: (VAR)
Derived type: (FUNCTION (T T) (VALUES CONS &OPTIONAL))
Documentation:
  T
Source form:
  (LAMBDA (#1=#:EXPR #2=#:ENV)
    (DECLARE (SB-C::LAMBDA-LIST (VAR)))
    (DECLARE (IGNORE #2#))
    (SB-INT:NAMED-DS-BIND (:MACRO NIL! . DEFMACRO)
        (VAR)
        (CDR #1#)
      (DECLARE (SB-C::CONSTANT-VALUE VAR))
      (BLOCK NIL! `(SETF ,VAR NIL))))
Environment: NIL
(SETF X NIL)                                                            <---- Expansion (Result of MACROEXPAND-1)
T
-------------------------------------------
Puzzling expansion results...

READ-EVAL-PRINT loop
Expectation
1. READ Build form from S-expression
2. EVAL Macro form detected -> expand first then evaluate result

Apparently (SBCL anyway) compiles before evaluation! Must expand all macro forms.

Start with default *MACROEXPAND-HOOK*:
(setf *macroexpand-hook* #'funcall)

Call to MACROEXPAND-1 function occurs after LET binding of *MACROEXPAND-HOOK*:
(let ((*macroexpand-hook* #'hook)) (macroexpand-1 '(nil! x)))        <---- Call MACROEXPAND-1 explicitly
Expanding: (NIL! X)
Expansion function: #<FUNCTION (MACRO-FUNCTION NIL!) {B800D08A0B}>
...
Environment: NIL
(SETF X NIL)
T

Actually using the NIL! macro:
(let ((*macroexpand-hook* #'hook)) (let ((y 2)) (nil! y) y))         <---- MACROEXPAND-1 called indirectly for expansion
NIL

HOOK function is ignored! Expansion occurs during compilation prior to evaluating LET form.
-------------------------------------------
By contrast, consider changes to reader's environment:

(let ((*read-base* 2)) (let ((8 9.)) (print 8)))                     <---- Reader does not see binding.
; in: LET ((*READ-BASE* 2))
;     (8 9)
; 
; caught ERROR:
;   8 is not a symbol and cannot be used as a local variable.
; 
; compilation unit finished
;   caught 1 ERROR condition

(setf *read-base* 2) ; Base changed before subsequent read
(let ((8 9.)) (print 8)) ; 8 is symbol not number

9 
9
-------------------------------------------
SBCL expands prior to evaluation??

Try the opposite. Set custom *MACROEXPAND-HOOK*:
(setf *macroexpand-hook* #'hook)

LET binding should output "foo!" and restore FUNCALL as *MACROEXPAND-HOOK*:
(let ((*macroexpand-hook* (progn (format t "foo!~%") #'funcall)))      <---- Sneak debugging output in as part of binding
  (let ((y 2)) (nil! y) y))
Expanding: (NIL! Y)
Expansion function: #<FUNCTION (MACRO-FUNCTION NIL!) {B800D08A0B}>
#<FUNCTION (MACRO-FUNCTION NIL!) {B800D08A0B}>
  [compiled function]
...
foo!              <---- Output from evaluating LET occurs after form is compiled (with HOOK in effect as *MACROEXPAND-HOOK*)
NIL

Graham first discusses macro expansion of a top-level form:
1. Typing (nil! x) into REPL, reader builds form
[*|*]--->[*|*]--->NIL
 |        |             
 v        v          
NIL!      X
2. This is passed to EVAL, which determines that this is a macro form (CAR NIL! names a macro), so
expansion is generated:
[*|*]--->[*|*]--->[*|*]--->NIL
 |        |        |          
 v        v        v          
SETF      X       NIL
3. This form, (setf x nil), is evaluated instead of the original--as though this were what was originally typed by user.

He points out that expansion must precede evaluation (Lisp only knows how to evaluate functions and special operators),
but evaluation does not always come _immediately_ after expansion as with toplevel. He specifically calls out compiling
function definitions: when a function is compiled any macro forms within it will be expanded, but the function has not
yet been called.

This also appears to apply to the LET form above. The contained NIL! form cannot be evaluated until expanded, and the compiler
apparently does this prior to beginning evaluation of the containing LET form.
-------------------------------------------
CLISP, as an interpreter, behaves differently:
With HOOK installed as the *MACROEXPAND-HOOK* value

(let ((*macroexpand-hook* #'funcall)) (let ((y 2)) (nil! y) y))
(let ((*macroexpand-hook* (progn (format t "foo!~%") #'funcall))) (let ((y 2)) (nil! y) y))
foo!
NIL

(let ((y 2)) (nil! y) y)
Expanding: (NIL! Y)
Expansion function: 
#<FUNCTION NIL! (SYSTEM::<MACRO-FORM> SYSTEM::<ENV-ARG>) (DECLARE (CONS SYSTEM::<MACRO-FORM>)) (DECLARE (IGNORE SYSTEM::<ENV-ARG>))
  (IF (NOT (SYSTEM::LIST-LENGTH-IN-BOUNDS-P SYSTEM::<MACRO-FORM> 2 2 NIL)) (SYSTEM::MACRO-CALL-ERROR SYSTEM::<MACRO-FORM>) (LET* ((VAR (CADR SYSTEM::<MACRO-FORM>))) (BLOCK NIL! `(SETF ,VAR NIL))))>

#<FUNCTION NIL! (SYSTEM::<MACRO-FORM> SYSTEM::<ENV-ARG>) (DECLARE (CONS SYSTEM::<MACRO-FORM>)) (DECLARE (IGNORE SYSTEM::<ENV-ARG>)) ...> is an interpreted function.
Argument list: (SYSTEM::<MACRO-FORM> SYSTEM::<ENV-ARG>)
Environment: #(#(Y 2 NIL) NIL)
NIL
-------------------------------------------
ABCL behaves the same as CLISP.
Clozure shows the same behavior as SBCL.

CMUCL goes into a stack overflow?!?
Until HOOK is compiled! Then it behaves like SBCL/Clozure:
(setq *macroexpand-hook* #'funcall) ; Have to use SETQ here since SETF triggers expansion!!

#<Function FUNCALL {10128909}>

(compile 'hook)
; Compiling LAMBDA (EXPANDER FORM ENV): 
; Compiling Top-Level Form: 

HOOK
NIL
NIL

(setf *macroexpand-hook* #'hook)

#<Function HOOK {69201B11}>

(macroexpand-1 '(nil! x))
Expanding: (NIL! X)
Expansion function: #<Interpreted Function NIL! {791D9E01}>
#<Interpreted Function NIL! {791D9E01}> is a function.
Arguments:
  (VAR)
Its defined argument types are:
  (&REST T)
Its result type is:
  NIL
Its definition is:
  (LAMBDA (#:WHOLE-3130 #:ENV-3131) (DECLARE #) (BLOCK NIL! #))Environment: NIL
(SETF X NIL)
T
-------------------------------------------
Macro expansion may involve multiple levels of expansion before code is fully resolved
into special operators/functions. Graham likens this to Russian dolls that contain other dolls.
(macroexpand-1 '(cond ((evenp x) 'even) ((oddp x) 'odd) (t 'huh?)))
(IF (EVENP X)
    'EVEN
    (IF (ODDP X)
        'ODD
        (THE T 'HUH?)))
T

(macroexpand-1 '(or (and (evenp x) 'even) (and (oddp x) 'odd) 'huh?))
(LET ((#:G2105 (AND (EVENP X) 'EVEN)))
  (IF #:G2105
      #:G2105
      (LET ((#:G2106 (AND (ODDP X) 'ODD)))
        (IF #:G2106
            #:G2106
            'HUH?))))
T

(macroexpand-1 '(AND (EVENP X) 'EVEN))
(IF (EVENP X)
    'EVEN)
T

Two observations:
1. People are often confused about the difference between MACROEXPAND and MACROEXPAND-1.
MACROEXPAND-1 only executes one level of expansion. We saw that earlier with NIL!

(macroexpand-1 '(nil! x))
(SETF X NIL)
T

Full expansion--SETF is itself a macro:
(macroexpand '(nil! x))
(SETQ X NIL)
T

(defun hook (expander form env)
  (format t "Expanding: ~S~%" form)
  (when (eq (first form) 'nil!)
    (format t "Expansion function: ~S~%" expander)
    (describe expander)
    (format t "Environment: ~S~%" env))
  (funcall expander form env))

(let ((*macroexpand-hook* #'hook)) (macroexpand-1 '(nil! x)))
Expanding: (NIL! X)
...
(SETF X NIL)

(let ((*macroexpand-hook* #'hook)) (macroexpand '(nil! x)))
Expanding: (NIL! X)
...
Expanding: (SETF X NIL)
(SETQ X NIL)
T

Only concerns outermost form though
(macroexpand-1 '(or (and (evenp x) 'even) (and (oddp x) 'odd) 'huh?))
(LET ((#:G2105 (AND (EVENP X) 'EVEN)))                <---- Unexpanded AND
  (IF #:G2105
      #:G2105
      (LET ((#:G2106 (AND (ODDP X) 'ODD)))            <---- Unexpanded AND
        (IF #:G2106
            #:G2106
            'HUH?))))
T

Exactly same result for MACROEXPAND since result is LET regardless of nested AND macros forms.

2. This is different for the compilation process as discussed above. All macros must be _fully_
expanded. That is, any macro form at any level of the form being compiled (prior to evaluation)
must be expanded.
----------------------------------------------------------------------------
250911 木
§7.2 Backquote







CLHS §2.4.6 Backquote
https://www.lispworks.com/documentation/HyperSpec/Body/02_df.htm
`(a b c) -> `(a b c . nil) -> (append (list `a) (list `b) (list `c) 'nil) -> (append (list 'a) (list 'b) (list 'c) '())

(defun f () '(a b c))
(defun g () `(a b c))
(defun g1 () (append (list `a) (list `b) (list `c) '()))
(defun h () (list 'a 'b 'c))

(eq (f) (f)) => T
(eq (g) (g)) => T  ; ?????
(eq (g1) (g1)) => NIL
(eq (h) (h)) => NIL


(f) => (A B C)
(setf (rest (f)) '(x y))
(f) => (A X Y)

(g) => (A B C)
(setf (rest (g)) '(x y))
(g) => (A X Y) ; ????????

(g1) => (A B C)
(setf (rest (g1)) '(x y))
(g1) => (A B C)

(h) => (A B C)
(setf (rest (h)) '(x y))
(h) => (A B C)

CLHS §3.7.1 Modification of Literal Objects
https://www.lispworks.com/documentation/HyperSpec/Body/03_ga.htm

    The consequences are undefined if literal objects are destructively modified.        
    For this purpose, the following operations are considered destructive:               
                                                                                         
    cons Changing the car[1] or cdr[1] of the cons, or performing a destructive operation
         on an object which is either the car[2] or the cdr[2] of the cons.              




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

----------------------------------------------------------------------------
250331 月
§2.4.8.15 Sharpsign Equal-Sign
https://www.lispworks.com/documentation/HyperSpec/Body/02_dho.htm
§2.4.8.16 Sharpsign Sharpsign
https://www.lispworks.com/documentation/HyperSpec/Body/02_dhp.htm

(defvar *circle* '(a b c . #1=(d e f . #1#)))

(let ((*print-circle* t)) (print *circle*) :foo)
                                           ^^^^  !!
(A B C . #1=(D E F . #1#)) 
:FOO
* 

(sdraw *circle*)

Not quite right:
[*|*]--->[*|*]--->[*|*]--->[*|*]--->[*|*]--->[*|*]--->[*|*]--->[*|*]--->etc.
 |        |        |        |        |        |        |        |
 v        v        v        v        v        v        v        v
 A        B        C        D        E        F        D        E

Accurate:
                            +-------------------+
                            |                   |
                            v                   |
[*|*]--->[*|*]--->[*|*]--->[*|*]--->[*|*]--->[*|*]
 |        |        |        |        |        |
 v        v        v        v        v        v
 A        B        C        D        E        F

(loop repeat 10 for elt in *circle* collect elt)
(A B C D E F D E F D)
(loop repeat 20 for elt in *circle* collect elt)
(A B C D E F D E F D E F D E F D E F D E)


(eq #1='(a b c) #1#) => T

[*|*]--->[*|*]------------------------------------>[*|*]--->NIL
 |        |                                         |
 |        | +---------------------------------------+
 |        | |
 v        v v
 EQ      [*|*]--->[*|*]--->NIL
          |        |
          v        v
         QUOTE    [*|*]--->[*|*]--->[*|*]--->NIL
                   |        |        |
                   v        v        v
                   A        B        C


(eq #1=(gensym) #1#) => NIL

(read)
(eq #1=(gensym) #1#)
(EQ (GENSYM) (GENSYM))

(eq (second *) (third *))
T

[*|*]--->[*|*]--------->[*|*]--->NIL
 |        |              |
 |        | +------------+
 |        | |
 v        v v
 EQ      [*|*]--->NIL
          |
          v
         GENSYM






(defun my-eq (a b) (eq a b))
(trace my-eq)

(my-eq #1=(gensym) #1#)
0: (MY-EQ #:G134 #:G135)
0: MY-EQ returned NIL
NIL
----------------------------------------------------------------------------
250409 水
Partial function application (not currying!)
[See further discussion above (日 250720) based on studying Alexandria libray.]

Why?
General-purpose function -> customized function (While you wait! Add Rhinestones $2.50)
Example: +

(defun add2 (x)
  (+ x 2))
(defun add3 (x)
  (+ x 3))
...

#'(lambda (x) (+ x 2))
(partial #'+ 2)


Divisibility
#'(lambda (p d) (zerop (mod p d)))

(defun divisible-by-3-p (n)
  (zerop (mod n 3)))
(defun divisible-by-4-p (n)
  (zerop (mod n 4)))
(defun divisible-by-5-p (n)
...
  
(compose (partial #'= 0) (partial* #'mod 3))
(complement (compose (partial #'= 0) (partial* #'mod 3)))



y = mx + b
• Consider m, b, x as variables
(defun linear3 (m b x) (+ (* m x) b))
(linear3 3 2 7) => 23

• Currying
((lambda (m) ((lambda (b) ((lambda (x) (+ (* m x) b)) 7)) 2)) 3)

((lambda (m)
   ((lambda (b)
      ((lambda (x)
         (+ (* m x) b))
       7))
    2))
 3)

(defun f (m)
  #'(lambda (b)
      #'(lambda (x)
          (+ (* m x) b))))

(f 3) => #<FUNCTION (LAMBDA (B) :IN F) {1002F5923B}>
(funcall * 2) => #<FUNCTION (LAMBDA (X) :IN F) {1002F59C1B}>
(funcall * 7) => 23

(funcall (funcall (funcall #'f 3) 2) 7) => 23

• Partial application
(defun linear2 (b x) (linear3 3 b x))
(defun linear1 (x) (linear2 2 x))
(defun linear0 () (linear1 7))

(= (linear3 3 2 7) (linear2 2 7))
(= (linear3 3 2 7) (linear1 7)
(= (linear3 3 2 7) (linear0))

Graham ACL 110 页 - Misnomer. Not currying but rather partial application.
(defun curry (fn &rest args)
  #'(lambda (&rest args2)
      (apply fn (append args args2))))

(defun rcurry (fn &rest args)
  #'(lambda (&rest args2)
      (apply fn (append args2 args))))

Clojure-influenced:
(defun partial (f &rest fixed)
  (if (null fixed)
      f
      (destructuring-bind (fixed0 &rest fixed) fixed
        (if (null fixed)
            #'(lambda (&rest args) (apply f fixed0 args))
            (destructuring-bind (fixed1 &rest fixed) fixed
              (if (null fixed)
                  #'(lambda (&rest args) (apply f fixed0 fixed1 args))
                  (destructuring-bind (fixed2 &rest fixed) fixed
                    (if (null fixed)
                        #'(lambda (&rest args) (apply f fixed0 fixed1 fixed2 args))
                        #'(lambda (&rest args)
                            (apply f fixed0 fixed1 fixed2 (append fixed args)))) )))) )))

(defun partial* (f &rest fixed)
  (if (null fixed)
      f
      #'(lambda (&rest args)
          (apply f (append args fixed)))) )

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

(< 4 3) => NIL
(funcall (partial #'< 4) 3) => NIL

(< 3 4) => T
(funcall (partial* #'< 4) 3) => T


(= (linear3 3 2 7) (funcall (partial #'linear3) 3 2 7))
(= (linear2 2 7) (funcall (partial #'linear3 3) 2 7))
(= (linear1 7) (funcall (partial #'linear3 3 2) 7))
(= (linear0) (funcall (partial #'linear3 3 2 7)) (funcall (partial (partial (partial #'linear3 3) 2) 7)))

(defun multiply-three (x y z) (* x y z))
(funcall (partial #'multiply-three 9) 7 2) => 126
(funcall (partial (partial #'multiply-three 9) 7) 2) => 126
(funcall (partial (partial (partial #'multiply-three 9) 7) 2)) => 126

Quiz:
(funcall (compose #'first #'rest #'rest #'rest #'rest) '(a b c d e f))
(mapcar (compose #'1+ #'1+) (loop for i from 1 to 10 collect i))
(mapcar (compose #'1+ #'1-) (loop for i from 1 to 10 collect i))
(mapcar (compose #'list (partial #'* 2)) (loop for i from 1 to 10 collect i))
(funcall (compose #'length (partial #'remove-if-not #'evenp)) (loop for i from 1 to 10 collect i))

(mapcar (compose #'not #'evenp) (loop for i from 1 to 10 collect i))
(mapcar (complement #'evenp) (loop for i from 1 to 10 collect i))

(funcall (partial #'reduce #'+) '(1 2 3))
(funcall (partial #'format nil "~@(~R~)") 12345)
(let ((xxs '((1 2 3 4 5) (5 4 5 4 3 2) (7 8 9 0 1 2 3)))) ; Learn You A Haskell 18 页
  (mapcar (partial #'remove-if-not #'evenp) xxs))

(funcall (partial* #'typep 'atom) 'a)
(funcall (partial* #'typep 'atom) '(1 2))
(funcall (complement (partial* #'typep 'atom)) '(1 2))
(funcall (partial #'- 1) 8)
(funcall (partial* #'- 1) 8)
(mapcar (compose (partial* #'< 10000) #'abs) '(23 12345 -80 -80000))

Some performance penalty for using PARTIAL(*)
(time (dotimes (i 10000) (funcall #'(lambda (x) (+ x 8)) 7)))
(time (dotimes (i 10000) (funcall (partial #'+ 8) 7)))
(let ((f (partial #'+ 8))) (time (dotimes (i 10000) (funcall f 7))))


(time (dotimes (i 10000) (funcall #'(lambda (n) (format nil "~@(~R~)" n)) 12345)))
(time (dotimes (i 10000) (funcall (partial #'format nil "~@(~R~)") 12345)))
(let ((f (partial #'format nil "~@(~R~)"))) (time (dotimes (i 10000) (funcall f 12345))))

(let ((xxs '((1 2 3 4 5) (5 4 5 4 3 2) (7 8 9 0 1 2 3))))
  (time (dotimes (i 10000)
          (mapcar #'(lambda (xs) (remove-if-not #'evenp xs)) xxs))))
(let ((xxs '((1 2 3 4 5) (5 4 5 4 3 2) (7 8 9 0 1 2 3))))
  (time (dotimes (i 10000)
          (mapcar (partial #'remove-if-not #'evenp) xxs))))
(let ((xxs '((1 2 3 4 5) (5 4 5 4 3 2) (7 8 9 0 1 2 3)))
      (f (partial #'remove-if-not #'evenp)))
  (time (dotimes (i 10000)
          (mapcar f xxs))))
----------------------------------------------------------------------------
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)))

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

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

(defun fizz-buzz (n)
  (flet ((fizz () "fizz")
         (buzz () "buzz"))
    (case (mod n 3)
      (0 (case (mod n 5)
           (0 (concatenate 'string (fizz) (buzz)))
           (otherwise (fizz))))
      (otherwise (case (mod n 5)
                   (0 (buzz))
                   (otherwise n)))) ))

(defun fizz-buzz (n)
  (flet ((fizz () "fizz")
         (buzz () "buzz"))
    (cond ((zerop (mod n 15)) (concatenate 'string (fizz) (buzz)))
          ((zerop (mod n 3)) (fizz))
          ((zerop (mod n 5)) (buzz))
          (t 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))