阅读 On Lisp

;; 宏定义
(defmacro for ((var start stop) &body body)
  `(do ((,var ,start (1+ ,var))
        (limit ,stop))
       ((> ,var limit))
     ,@body))

;; 使用case1
(for (x 1 5)
  (princ x))

;; 宏展开
(macroexpand-1 '(for (x 1 5)
                 (princ x)))

(DO ((X 1 (1+ X)) (LIMIT 5))
    ((> X LIMIT))
  (PRINC X))


;; 使用case2
(for (limit 1 5)
  (princ limit))

;; 宏展开
(macroexpand-1 '(for (limit 1 5)
                 (princ limit)))

(DO ((LIMIT 1 (1+ LIMIT)) (LIMIT 5))
    ((> LIMIT LIMIT))
  (PRINC LIMIT))

;; 使用case3
(let ((limit 5))
  (for (i 1 5)
    (when (> i limit)
      (princ i))))

;; 宏展开
(macroexpand-1 '(let ((limit 5))
                 (for (i 1 10)
                   (when (> i limit)
                     (princ i)))))
(LET ((LIMIT 5))
  (DO ((I 1 (1+ I))
       (LIMIT 10))
      ((> I LIMIT))
    (WHEN (> I LIMIT) (PRINC I))))

(defvar w nil)

; wrong 这里的w会和在调用环境中的w产生作用
(defmacro gripe (warning)
 `(progn (setq w (nconc w (list ,warning)))
  nil))

;; 定义
CL-USER> (defmacro our-let (binds &body body)
           `((lambda ,(mapcar #'(lambda (x)
                             (if (consp x)
                                 (car x)
                                 x))
                         binds)
               ,@body)
             ,@(mapcar #'(lambda (x)
                           (if (consp x)
                               (cadr x)
                               nil))
                       binds)))
       OUR-LET

;; 效果
CL-USER> (our-let ((x 1) (y 2))
           (+ x y))
3

;; 展开成(macroexpand):
((LAMBDA (X Y) (+ X Y)) 1 2)

;; 定义
CL-USER> (defmacro when-bind* (binds &body body)
           (if (null binds)
               `(progn ,@body)
               `(let (,(car binds))
                  (if ,(caar binds)
                      (when-bind* ,(cdr binds) ,@body)))))
WHEN-BIND*

CL-USER> (when-bind* ((x (find-if #'consp '(a (1 2) b)))
                      (y (find-if #'oddp x)))
           (+ y 10))
11
CL-USER>

;;  macroexpand
;; step1
(LET ((X (FIND-IF #'CONSP '(A (1 2) B))))
  (IF X
      (WHEN-BIND* ((Y (FIND-IF #'ODDP X)))
        (+ Y 10))))

;;step2
(LET ((X (FIND-IF #'CONSP '(A (1 2) B))))
  (IF X
      (LET ((Y (FIND-IF #'ODDP X)))
        (IF Y
            (WHEN-BIND* NIL
              (+ Y 10))))))

;; step3
(LET ((X (FIND-IF #'CONSP '(A (1 2) B))))
  (IF X
      (LET ((Y (FIND-IF #'ODDP X)))
        (IF Y
            (PROGN (+ Y 10))))))

CL-USER>  (defmacro with-gensyms (syms &body body)
            `(let ,(mapcar (lambda (s) `(,s (gensym))) syms)
               ,@body))

(condlet (((= 1 2) (x (princ ’a)) (y (princ ’b)))
          ((= 1 1) (y (princ ’c)) (x (princ ’d)))
          (t       (x (princ ’e)) (z (princ ’f))))
  (list x y z))

(condlet (((= 1 2) (x (princ 'a)) (y (princ 'b)))
                   ((= 1 1) (y (princ 'c)) (x (princ 'd)))
                   (t       (x (princ 'e)) (z (princ 'f))))
           (list x y z))
=>

CD
(D C NIL)


宏展开 =>

(LABELS ((#:G606 (Y X Z)
           (LIST X Y Z)))
  (COND
    ((= 1 2)
     (LET (#:G607 #:G608 #:G609)
       (LET ((#:G608 (PRINC ’A)) (#:G607 (PRINC ’B)))
         (#:G606 #:G607 #:G608 #:G609))))
    ((= 1 1)
     (LET (#:G607 #:G608 #:G609)
       (LET ((#:G607 (PRINC ’C)) (#:G608 (PRINC ’D)))
         (#:G606 #:G607 #:G608 #:G609))))
    (T
     (LET (#:G607 #:G608 #:G609)
       (LET ((#:G608 (PRINC ’E)) (#:G609 (PRINC ’F)))
         (#:G606 #:G607 #:G608 #:G609))))))

;; 定义
(defmacro condlet (clauses &body body)
  (let ((bodfn (gensym))
        ;; here vars is like ((Y . #:G613) (X . #:G614) (Z . #:G615))
        (vars (mapcar #'(lambda (v) (cons v (gensym))) (remove-duplicates
                                                   (mapcar #'car
                                                           (mappend #'cdr clauses)))))
)
    `(labels ((,bodfn ,(mapcar #'car vars)
                ,@body))
       (cond ,@(mapcar #'(lambda (cl)
                           (condlet-clause vars cl bodfn))  ; 由于生成每个子表达式除了clauses不够，还要vars bodfn, 所以用个闭包将它们引入
                       clauses)))))

;; 作用：生产对应cond 语句
(defun condlet-clause (vars cl bodfn)
  `(,(car cl) (let ,(mapcar #'cdr vars)
                (let ,(condlet-binds vars cl)
                  (,bodfn ,@(mapcar #'cdr vars))))))

;; 作用：将表达式中的变量绑定，替换为对对应gensym的绑定
;; (condlet-binds '((Y . #:G613) (X . #:G614) (Z . #:G615)) '((= 1 2) (x (princ ’a)) (y (princ ’b))))
;; =>
;; ((#:G614 (PRINC ’A)) (#:G613 (PRINC ’B)))
(defun condlet-binds (vars cl)
  (mapcar #'(lambda (bindform)
              (if (consp bindform)
                  (cons (cdr (assoc (car bindform) vars))
                        (cdr bindform))))
          (cdr cl)))

;; 作用:将fn应用到lsts子项，再非破坏连接起来
;; (((= 1 2) (X (PRINC ’A)) (Y (PRINC ’B)))
;;  ((= 1 1) (Y (PRINC ’C)) (X (PRINC ’D))) (T (X (PRINC ’E)) (Z (PRINC ’F))))
;; =>
;; ((X (PRINC ’A)) (Y (PRINC ’B)) (Y (PRINC ’C)) (X (PRINC ’D)) (X (PRINC ’E))
;;                 (Z (PRINC ’F)))
(defun mappend (fn &rest lsts)
  "maps elements in list and finally appends all resulted lists."
  (apply #'append (apply #'mapcar fn lsts)))

(mvdo* ((x 1 (1+ x))
        ((y z) (values 0 0) (values z x)))
    ((> x 5) (list x y z))
  (princ (list x y z)))

;; 展开成：

(LET ((X 1))
  (MULTIPLE-VALUE-BIND (Y Z)
      (VALUES 0 0)
    (PROG ()
       #:G593
       (IF (> X 5)
           (RETURN (PROGN (LIST X Y Z))))
       (PRINC (LIST X Y Z))
       (SETQ X (1+ X))
       (MULTIPLE-VALUE-SETQ (Y Z) (VALUES Z X))
       (GO #:G593))))

(defmacro mvdo* (parm-cl test-cl &body body)
  (mvdo-gen parm-cl parm-cl test-cl body)) ; Use function to help generate code

;; This function is mainly used as generate bind nested form, with recursive call self.
;; And pass rebind generate task to `mvdo-rebind-gen` function
(defun mvdo-gen (binds rebinds test body)
  (if (null binds)  ;; recursive function, incase this is the last call, so binds is null while rebinds is not.
      (let ((label (gensym)))
        `(prog () ;; Just like `do` macro, it expand mvdo* to `prog` form, use `go` to loop
            ,label
            (if ,(car test)  ;; test test-case here
                (return (progn ,@(cdr test)))) ;; use `progn` here in case of list of clauses
            ,@body ;; loop body
            ,@(mvdo-rebind-gen rebinds)  ;; As init binding has done, let's generate rebind form, use function to help
            (go ,label) ;; use `go label` to loop
            ))
      (let ((rec (mvdo-gen (cdr binds) rebinds test body)))  ;; recursive call self, put result in rec
        (let ((var/s (caar binds))
              (expr (cadar binds)))
          (if (atom var/s)            ;; check the init-form is single value or multi value
              `(let ((,var/s ,expr))  ;; single value case
                 ,rec)
              `(multiple-value-bind ,var/s ,expr  ;; multi value case
                 ,rec)
              )))))

;; This is also a recursive function. once handle a bind.
(defun mvdo-rebind-gen (rebinds)
  (cond ((null rebinds) nil)
        ((< (length (car rebinds)) 3) (mvdo-rebind-gen (cdr rebinds))) ;; the rebind don't have step-form, so just call next cyle
        (t (cons  ;; use `cons` to connect all generated-rebind-forms as a list
            (let ((var/s (caar rebinds))
                  (expr (caddar rebinds)))
              (if (atom var/s)  ;; check the init-form is single value or multi value
                  `(setq ,var/s ,expr)
                  `(multiple-value-setq ,var/s ,expr)))
            (mvdo-rebind-gen (cdr rebinds)) ;; call self recursively
            ))))

;; mvdo example
(mvdo ((x 1 (1+ x))
       ((y z) (values 0 0) (values z x)))
    ((> x 5) (list x y z))
  (princ (list x y z)))


; macro expand to:
(LET (#:G642 #:G643 #:G644)
  (MVPSETQ #:G642 1 (#:G643 #:G644) (VALUES 0 0))
  (PROG ((X #:G642) (Y #:G643) (Z #:G644))
     #:G641
     (PRINC (LIST X Y Z))
     (IF (> X 5)
         (RETURN (PROGN (LIST X Y Z))))
     (MVPSETQ X (1+ X) (Y Z) (VALUES Z X))
     (GO #:G641)))

(defmacro mvdo (parm-cl test-cl &body body)
  (let* ((label (gensym))
         (let-cl '()) ;; form like:  #:G593 #:G594 #:G595
         (mvsetq-cl '()) ;; form like:  #:G593 1 (#:G594 #:G595) (values 0 0)
         (prog-cl '()) ;; form like:  (X #:G593) (Y #:G594) (Z #:G595)
         )
    ;; Use a loop to generate three main clauses for macro
    ;; when generate gensym, the push it to different clauses according to different require
    ;; use loop with it's side effect
    (loop :for each :in parm-cl
          :do (if (listp (first each))
                  ;; ((y z) (values 0 0) -> (values z x)) (y z) -> ((y #:g1) (z #:g2))
                  (let ((var-g-pair-list (mapcar #'(lambda (x) (list x (gensym))) (first each))))
                    ;; construct let-cl
                    (mapcar #'(lambda (p) (push (second p) let-cl)) var-g-pair-list)
                    ;; construct mvsetq-cl
                    (push (mapcar #'second  var-g-pair-list) mvsetq-cl)
                    (push (second each) mvsetq-cl)
                    ;; construct prog-cl
                    (mapcar #'(lambda (p) (push p prog-cl)) var-g-pair-list)
                    )
                  (let ((g (gensym)))
                    ;; construct let-cl
                    (push g let-cl)
                    ;; construct mvsetq-cl
                    (push g mvsetq-cl)
                    (push (second each) mvsetq-cl)
                    ;; construct prog-cl
                    (push (list (first each) g) prog-cl)))
          :finally (progn
                     (setf let-cl (nreverse let-cl))
                     (setf mvsetq-cl (nreverse mvsetq-cl))
                     (setf prog-cl (nreverse prog-cl))))

    ;; just use the *-cl generated above
    `(let (,@let-cl)
       (mvpsetq ,@mvsetq-cl)
       (prog (,@prog-cl) ;; TODO init bind
          ,label
          (if ,(car test-cl)
              (return (progn ,@(cdr test-cl))))
          ,@body
          ;; construct rebind form here, because it has no relation to gensyms.
          (mvpsetq ,@(flatten-1
                      (mapcar #'(lambda (p)
                                  (when (third p)
                                    (list (first p)
                                          (third p))))
                              parm-cl)))
          (go ,label)))))

(defmacro mvdo (binds (test &rest result) &body body)
  (let ((label (gensym))
        (temps (mapcar #'(lambda (b)
                           (if (listp (car b))
                               (mapcar #'(lambda (x)
                                           (gensym))
                                       (car b))
                               (gensym)))
                       binds))) ;; temps like (#:G617 (#:G618 #:G619)), transfer binds to gensym symbols
    `(let ,(mappend #'ensure-list temps)
       (mvpsetq ,@(mapcan #'(lambda (b var)
                              (list var (cadr b)))
                          binds
                          temps))
       (prog ,(mapcar #'(lambda (b var) (list b var)) ;; mapcar 将下面两个列表一一配对
               (mappend #'ensure-list (mapcar 'car binds))  ;; 将所有的初始变量展平
               (mappend #'ensure-list temps)) ;; 将所有的temps展平
          ,label
          (if ,test
              (return (progn ,@result)))
          ,@body
          (mvpsetq ,@(mapcan #'(lambda (b)
                                 (if (third b)  ;; 判断是否有更新的表达式,来决定是否生成
                                     (list (car b)
                                           (third b))))
                             binds))
          (go ,label)))))

CL-USER> (flatten-1 '((a b c) d (e (f g) h) ((i)) i))
(A B C D E (F G) H (I) I)
CL-USER> (mappend #'ensure-list '((a b c) d (e (f g) h) ((i)) i))
(A B C D E (F G) H (I) I)

;;Macro expand example:
(let ((w 0) (x 1) (y 2) (z 3))
  (mvpsetq (w x x) (values 'a 'b) (y z) (values w x))
  (list w x y z))


(LET ((W 0) (X 1) (Y 2) (Z 3))
  (MULTIPLE-VALUE-BIND (#:G592 #:G593 #:G594)
      (VALUES 'A 'B)
    (MULTIPLE-VALUE-BIND (#:G595 #:G596)
        (VALUES W X)
      (PSETQ W #:G592
             X #:G593
             X #:G594
             Y #:G595
             Z #:G596)))
  (LIST W X Y Z))

;; use gen-cl to generate expression, because I need use recursion for multiple-value-bind
;; gen-lst is used for collect generate gensyms for psetq use
(defmacro mvpsetq (&rest args)
  (let (gen-lst)
    (gen-cl args args gen-lst)))

;; helper func for mvpsetq
(defun gen-cl (bind-cls set-cls gen-lst)
  (if (null bind-cls)
      `(psetq ,@(shuffle-1 (flatten-1 (loop :for x :in set-cls :by #'cddr :collect x))  ;; the loop here is to collect ((w x) (values 'a 'b) (y z) (values w x)) -> ((w x) (y z))
                           gen-lst)) ;; generate`( psetq x1 v1 x2 v2)` expression
      (let ((g-lst (mapcar #'(lambda (x) (gensym))
                           (first bind-cls))))  ;; generate list of gensyms for multiple-value-bind in this recursive
        (if (listp (first bind-cls))  ;; let's decide use `multiple-value-bind` or `let` to bind
            `(multiple-value-bind ,g-lst
                 ,(second bind-cls)
               ,(gen-cl (cddr bind-cls) set-cls (append gen-lst g-lst)))  ;; recusively call self, accumlate genyms to gen-list, for latter psetq
            `(let (((first bind-cls) ,(second bind-cls)))
               ,(gen-cl (cddr bind-cls) set-cls (append gen-lst g-lst)))  ;; recusively call self, accumlate genyms to gen-list, for latter psetq
            )
        )))


;; helper func, used to extract symbols need binding
;; ONLISP> (flatten-1 '(1 (2) 3 (4 (5) 6)))
;; (1 2 3 4 (5) 6)
(defun flatten-1 (l)
  (loop :with result := '()
        :for x :in l
        :if (listp x)
        :do (setf result (append result x))
        :else
        :do (setf result (append result (list x)))
        :finally (return result)))


;; helper func, used to create expression for psetq with a list of gensyms and a list of set symbols
;; ONLISP> (shuffle-1 '(1 2 3) '(a b c))
;; (1 A 2 B 3 C)
(defun shuffle-1 (l1 l2)  ;; name it shuffle-1 to escape shuffle fun in below, although they do same.
  (let (result)
    (mapcar #'(lambda (x y) (push x result) (push y result))
            l1
            l2)
    (nreverse result)))

(defmacro mvpsetq (&rest args)
  (let* ((pairs (group args 2))  ;; Group args to ( ((w x) (values 'a 'b))   ( (y z) (values w x))  )
         (syms (mapcar #'(lambda (p)
                           (mapcar #'(lambda (x) (gensym)) (ensure-list (car p))))
                       pairs))) ;; Pregenerate '(gensym1 ...) for latter bind use
    (labels ((rec (ps ss)
               (if (null ps)
                   `(setq ,@(mapcan #'(lambda (p s) (shuffle-it (ensure-list (car p)) s))
                                    pairs syms))
                   (let ((body (rec (cdr ps) (cdr ss)))) ;; recursive call self, because we have Got the syms list , not like my-own solution, generate in each recursion.
                     (let ((var/s (caar ps))
                           (expr (cadar ps)))
                       (if (consp var/s)
                           `(multiple-value-bind ,(car ss) ,expr
                              ,body)
                           `(let ((,@(car ss) ,expr))
                              ,body)))))))
      (rec pairs syms))))

;; Rename to shuffle-it, avoid conflict with alexandria:shuffle
(defun shuffle-it (x y)
  (cond ((null x) y)
        ((null y) x)
        (t (list* (car x) (car y)
                  (shuffle-it (cdr x) (cdr y))))))

(defun group (source n)
  "Group source into each with n numbers of elements unless the last is not enough"
  (when (<= n 0) (error "length not greater than zero"))
  (labels ((rec (source acc)
             (let ((rest (nthcdr n source)))
               (if (consp rest)
                   (rec rest (cons (subseq source 0 n) acc))
                   (nreverse (cons source acc))))))
    (if source (rec source nil) nil)))

;; allf 将args的值的值都设置成val
(defmacro allf (val &rest args)
  (with-gensyms (v)
    `(let ((,v ,val))
       (setf ,@(mapcan #'(lambda (a)
                           `(,a ,v))
                       args)))))

;; allf的特例，将参数的值都设置为nil
(defmacro nilf (&rest args)
  `(allf nil ,@args))

;; allf的特例，将参数的值都设置为t
(defmacro tf (&rest args)
  `(allf t ,@args))

;; 通常情况下会修改第一个参数为连接的值，将其返回
(let ((l1 '(a b c))
      (l2 '(d e))
      (l3 '(f g h)))
  (nconc l1 l2 l3)
  (print l1)
  (print l2)
  (print l3)
  nil)

=>

(A B C D E F G H)
(D E F G H)
(F G H)
NIL


;; 但要是第一个空列表，那么会修改第二个参数为连接的值，将其返回
(let ((l1 '())
      (l2 '(d e))
      (l3 '(f g h)))
  (nconc l1 l2 l3)
  (print l1)
  (print l2)
  (print l3)
  nil)

=>

NIL
(D E F G H)
(F G H)
NIL

(setq x (nconc x y))

;; concf 定义
(define-modify-macro concf (&rest lists) nconc)


;; concf 使用
(let ((l1 '())
      (l2 '(d e))
      (l3 '(f g h)))
  (concf l1 l2 l3)
  (print l1)
  (print l2)
  (print l3)
  nil)

=>

(D E F G H)
(D E F G H)
(F G H)
NIL

这时候，第一个参数一定是连接的结果。

;;; conc1f
(defun conc1f/function (place obj)
  (nconc place (list obj)))

(define-modify-macro conc1f (obj) conc1f/function)


;;; concnew
;;; 注意这里不同于onlisp书中的定义, 它的定义我认为有问题
(defun concnew/function (place obj &rest args)
  (if (apply #'member obj place args)
      place
      (nconc place (list obj))))

(define-modify-macro concnew (obj &rest args) concnew/function)

;; conc1f 使用
(let ((l1 '(a b c))
      (x 'd)
      (y 'b))
  (print (conc1f l1 x))
  (print l1)
  (print (conc1f l1 y))
  (print l1)
  nil)

=>

(A B C D)
(A B C D)
(A B C D B)
(A B C D B)
NIL


;; conc1f 第二个例子
(let ((l1 '())
      (x 'd)
      (y 'b))
  (print (conc1f l1 x))
  (print l1)
  (print (conc1f l1 y))
  (print l1)
  nil)

=>

(D)
(D)
(D B)
(D B)
NIL


;; concnew 使用
(let ((l1 '(a b c))
      (x 'd)
      (y 'b))
  (print (concnew l1 x))
  (print l1)
  (print (concnew l1 y))
  (print l1)
  nil)

(A B C D)
(A B C D)
(A B C D)
(A B C D)
NIL


;; concnew 第二个例子
(let ((l1 '())
      (x 'd)
      (y 'b)
      (z 'd))
  (print (concnew l1 x))
  (print l1)
  (print (concnew l1 y))
  (print l1)
  (print (concnew l1 z))
  (print l1)
  nil)

(D)
(D)
(D B)
(D B)
(D B)
(D B)
NIL

;;; --- Macro `_f` ---

(defmacro _f (op place &rest args)
  (multiple-value-bind (vars forms var set access)
      (get-setf-expansion place)
    `(let* (,@(mapcar #'list vars forms)
            (,(car var) (,op ,access ,@args)))
       ,set)))


;; Macro `conc1f` created with `_f`
;; name with `'` to avoid name conflict
(defmacro conc1f' (lst obj)
  `(_f nconc ,lst (list ,obj)))

;;; --- Macro `pull` ---

;; Use case
;; (let ((x '(1 2 (a b) 3)))
;;   (print (pull '(a b) (cdr x) :test #'equal))
;;   (print x)
;;   nil)
;; =>
;; (2 3)
;; (1 2 3)
;; NIL
(defmacro pull (obj place &rest args)
  (multiple-value-bind (vars forms var set access)
      (get-setf-expansion place)
    (let ((g (gensym)))
      `(let* ((,g ,obj)
              ,@(mapcar #'list vars forms)
              (,(car var) (delete ,g ,access ,@args)))
         ,set))))

;; Macro expansion example1
;; (let ((x '(1 2 (a b) 3)))
;;   (pull '(a b) (cdr x) :test #'equal))

;; expand to

;; (LET ((X '(1 2 (A B) 3)))
;;   (LET* ((#:G611 '(A B))
;;          (#:X610 X)
;;          (#:NEW1 (DELETE #:G611 (CDR #:X610) :TEST #'EQUAL)))
;;     (SB-KERNEL:%RPLACD #:X610 #:NEW1)))

;; ;; Macro expansion example2
;; (let ((x '(1 2 (a b) 3)))
;;   (onlisp::pull 3 (cddr x) :test #'equal))

;; expand to

;; (LET ((X '(1 2 (A B) 3)))
;;   (LET* ((#:G617 3)
;;          (#:LIST (CDR X))
;;          (#:NEW (DELETE #:G617 (CDR #:LIST) :TEST #'EQUAL)))
;;     (SB-KERNEL:%RPLACD #:LIST #:NEW)))






;;; --- Macro `pull-if`---

;; use case
;; CL-USER> (let ((l '(1 2  3 4 5)))
;;            (pull-if #'oddp l)
;;            l)
;; =>
;; (2 4)

;; expand to
;; (LET ((L '(1 2 3 4 5)))
;;   (LET* ((#:G619 #'ODDP) (#:NEW1 (DELETE-IF #:G619 L)))
;;     (SETQ L #:NEW1))
;;   L)


(defmacro pull-if (test place &rest args)
  (multiple-value-bind (vars forms var set access)
      (get-setf-expansion place)
    (let ((g (gensym)))
      `(let* ((,g ,test)
              ,@(mapcar #'list vars forms)
              (,(car var) (delete-if ,g ,access ,@args))) ;; the different with pull is here
         ,set))))

;;; --- Macro popn ---

;; Use case
;; (let ((l '(a b c d e f g)))
;;   (print (onlisp::popn 2 (cddr l)))
;;   (print l)
;;   nil)

;; =>

;; (C D)
;; (A B E F G)
;; NIL


(defmacro popn (n place)
  (multiple-value-bind (vars forms var set access)
      (get-setf-expansion place)
    (with-gensyms (gn glst)
      `(let* ((,gn ,n)
              ,@(mapcar #'list vars forms)
              (,glst ,access) ;; 由于两个地方要用到access, 所以这里采用临时变量来存储值
              (,(car var) (nthcdr ,gn ,glst)))
         (prog1 (subseq ,glst 0 ,gn)
           ,set)))))

;; Macro expansion

;; (LET ((L '(A B C D E F G)))
;;   (PRINT (LET* ((#:GN595 2)
;;                 (#:LIST (CDR L))
;;                 (#:GLST596 (CDR #:LIST))
;;                 (#:NEW (NTHCDR #:GN595 #:GLST596)))
;;            (PROG1 (SUBSEQ #:GLST596 0 #:GN595) (SB-KERNEL:%RPLACD #:LIST #:NEW))))
;;   (PRINT L)
;;   NIL)

;;; --- Macro sortf ---

(defmacro sortf (op &rest places)
  (let* ((meths (mapcar #'(lambda (p)
                            (multiple-value-list
                             (get-setf-expansion p)))
                        places))
         (temps (apply #'append (mapcar #'third meths))))
    `(let* ,(mapcar #'list
                    (mapcan #'(lambda (m)
                                (append (first m)
                                        (third m)))
                            meths)
                    (mapcan #'(lambda (m)
                                (append (second m)
                                        (list (fifth m))))
                            meths))
       ,@(mapcon #'(lambda (rest) ;; 1. use mapcon so `rest` arg will be (#:g1 #:g2 #:g3) (#:g2 #:g3) (#:g3) each time
                     (mapcar
                      ;; 3. so when the inner lambda get (#:g2 #:g3) passed, it will compare to `(car rest)` which is #:g1;
                      ;; when the inner lambda get (#:g3) passed, it will compare to `(car rest)` which is #:g2.
                      ;; So it creates three unless expression
                      #'(lambda (arg)
                          `(unless (,op ,(car rest) ,arg)
                             (rotatef ,(car rest) ,arg)))
                      (cdr rest)))  ;; 2. so (cdr list) passed to the `mapcar lambda` will be (#:g2 #:g3) (#:g3) ()
                 temps)
       ,@(mapcar #'fourth meths))))

;; (let ((x 1)
;;       (y 2)
;;       (z 3))
;;   (sortf > x y z)
;;   (list x y z))

;; => (3 2 1)

;; Macro expand result
;; (LET ((X 1) (Y 2) (Z 3))
;;   (LET* ((#:NEW1 X) (#:NEW2 Y) (#:NEW3 Z))
;;     (UNLESS (> #:NEW1 #:NEW2) (ROTATEF #:NEW1 #:NEW2))
;;     (UNLESS (> #:NEW1 #:NEW3) (ROTATEF #:NEW1 #:NEW3))
;;     (UNLESS (> #:NEW2 #:NEW3) (ROTATEF #:NEW2 #:NEW3))
;;     (SETQ X #:NEW1)
;;     (SETQ Y #:NEW2)
;;     (SETQ Z #:NEW3))
;;   (LIST X Y Z))


;; 这里宏采用mapcon以及嵌套的mapcar等来按照需求生成多个unless表达式，很精致，值得研究。

(defun compose (&rest fns)
  (if fns
      (let ((fn1 (car (last fns)))
            (fns (butlast fns)))
        #'(lambda (&rest args)
            (reduce #'funcall fns
                    :from-end t
                    :initial-value (apply fn1 args))))
      #'identity))

;; 将参数传给find-if，然后将结果传给1+
CL-USER> (funcall (compose #'1+ #'find-if) #'oddp '(2 3 4))
4

;; 如果有些arguments函数本身就是一个形如(operator arguments)的格式，那么参数作用于其上时，也按照相同的规则。

;; 比如：
(fn (and integerp oddp)) => #'(lambda (x) (and (integerp x) (oddp x)))

;; 再比如：
(fn (list (1+ truncate))) => #'(lambda (#:g1)
                                 (list ((lambda (#:g2) (1+ (truncate #:g2))) #:g1)))


;; 特例，如果参数operator是compose, 那么生成的函数就是复合所有arguments函数的函数。效果和直接调用compose类似.
;; 比如
(fn (compose list 1+ truncate)) => #'(lambda (#:g1) (list (1+ (truncate #:g1))))



;;; 关于compose特例的说明
;; 虽然这里将compose作为一种特殊情况处理，但并没有增加fn的功能，只是为了增加调用的可读性。如果把嵌套的参数传给fn就能形成函数的复合。
;; 其实上面的例子也就相当于
(fn (list (1+ truncate))) => #'(lambda (#:g1)
                                 (list ((lambda (#:g2) (1+ (truncate #:g2))) #:g1)))
等价于
(fn (compose list 1+ truncate)) => #'(lambda (#:g1) (list (1+ (truncate #:g1))))

(defmacro fn (expr)
  `#',(rbuild expr))  ;; 通过调用rbuild函数来构造来生成函数expression

(defun rbuild (expr)
  (if (or (atom expr) (eq (car expr) 'lambda)) ;; 判断传入的表达式是个atom或者是个lambda表达式，则返回该表达式自身
      expr
      (if (eq (car expr) 'compose)  ;; 根据operator是不是特殊情况compose，调用不同的函数来构造表达式
          (build-compose (cdr expr))
          (build-call (car expr) (cdr expr)))))

(defun build-compose (fns)
  (let ((g (gensym)))
    `(lambda (,g)  ;; 外层的lambda是因为我们需要构造一个函数返回
       ,(labels ((rec (fns) ;; 这里定一个临时的递归函数rec，该函数接受一些函数列表，嵌套调用，最左边的函数包装在最外边调用，也就是最后调用，最后生成函数递归调用的表达式
                   (if fns  ;; 递归的临界值检查
                       `(,(rbuild (car fns))
                         ,(rec (cdr fns))) ;; 生成函数递归调用的表达式， (rbuild (car fns)) 是防止operator又是一个(operator arguments)的形式
                       g))) ;; 临界值，复合函数最后的参数是最外面函数的参数
          (rec fns)))))

(defun build-call (op fns)
  (let ((g (gensym)))
    `(lambda (,g) ;; 外层的lambda是因为我们需要构造一个函数返回
       (,op ,@(mapcar #'(lambda (f)
                          `(,(rbuild f) ,g))  ;; 对每个fn都将参数g传入，最后的结果是list,使用,@展开，作为参数传给op。其中，防止fns里有嵌套的(operator arguments)形式，递归调用(rbuild f)
                      fns)))))

;;; 先回顾 chapter 5.5 在cdr上递归
;; 我们来看下面两个在list上以cdr递归的函数:
;; 第一个函数是求一个列表的长度 (实际上和内置length功能相同)
(defun our-length (lst)
  (if (null lst)
      0                             ;; 这里是最基础的值
      (1+ (our-length (cdr lst)))))  ;; 在cdr上递归，每次递归结果+1

;; 第二个函数是判断一个列表里的元素是否都是基数 (实际上和内置的every+oddp功能相同)
(defun our-every-oddp (lst)
  (if (null lst)
      t                                   ;; base case
      (and (oddp (car lst))               ;; 取出第一个元素判断是否是基数，
           (our-every-oddp (cdr lst)))))  ;; 然后在cdr上递归，将car的结果和cdr的结果用and连接

;; 甚至，让我们看看every函数
(defun our-every (fn lst)
  (if (null lst)
      t                                ;; base case
      (and (funcall fn (car lst))      ;; 取出第一个元素判断fn调用结果
           (our-every fn (cdr lst))))) ;; 然后在cdr上递归，将car的结果和cdr的结果用and连接


;; 这些函数无论从函数定义的表达式形状还是从逻辑（其实是一回事，毕竟逻辑由函数定义来展现）来看都有其共同之处：
;; 1. 他们都需要一个base case
;; 2. 他们都在cdr上做递归调用

;; 另外，前两个将函数逻辑将car上调用的逻辑 (our-length是不管什么，都认定为长度1，our-every-oddp是调用oddp)写死在函数实现里，
;; 而最后一个函数将逻辑以参数形式传入 (fn)。
;; 但这三者car 和 cdr 调用结果的连接逻辑都写死在了函数实现里 (第一个是+1,第二个和第三个是and)

;; 考虑到这些共同的模式，现在我们考虑构造一个通用的函数或者宏，用它来替代上面这些共同模式函数:
;; 1. base case            都不一样，由外界传入
;; 2. 在cdr上递归            是一个共同模式，写死在实现里
;; 3. car上的处理逻辑        不是共同模式，由外界传入
;; 4. 如何连接car和cdr的结果  不是共同模式， 由外界传入
(defun lrec (car-fn conc-fn base)
  (labels ((self (lst)       ;; 这里假设产生的函数只接受一个list参数，其他处理逻辑在生成函数的时候指定
             (if (null lst)
                 base        ;; base case
                 (funcall conc-fn
                          (funcall car-fn (car lst))
                          (self (cdr lst))))))  ;; 调用连接函数，将car的结果和cdr的结果连接
    #'self))  ;; 这里使用labels定义一个内置的函数self,在将其返回的原因是，在cdr上递归调用的时候，需要使用这个生成的self




;; 这样，our-length可以写成
(defun nil->0 (n) ;; 辅助函数
  (if n n 0))
;; 这个函数等价于our-length
(lrec (lambda (x) (declare (ignore x)))
      (lambda (x1 x2) (+ (nil->0 x1)
                    (nil->0 x2)))
      0)

;; 给他封装个名字
(defun our-length2 (lst)
  (funcall (lrec (lambda (x) (declare (ignore x)) 1)
                 (lambda (x1 x2) (+ (nil->0 x1)
                               (nil->0 x2)))
                 0)
           lst))

;; 这样our-every-oddp可以写成
(defun our-every-oddp2 (lst)
  (funcall (lrec (lambda (x) (oddp x))
                 (lambda (x1 x2) (and x1 x2))
                 t)
           lst))

;; 这样上面的our-every可以写成
;; 考虑到our-every的car-fn是以参数形式传入的
(defun our-every2 (fn lst)
  (funcall (lrec fn ;; 这里的fn就是car-fn
                 (lambda (x1 x2) (and x1 x2))
                 t)
           lst))

;; 利用lrec，我们再来定义以下函数
;; 复制列表的copy-list
(defun our-copy-list (lst)
  (funcall (lrec (lambda (x) x)
                 (lambda (x1 x2) (cons x1 x2))
                 nil)
           lst))

;; 移除重复元素的remove-duplicates
(defun our-remove-duplicates (lst)
  (funcall (lrec (lambda (x) x)
                 (lambda (x1 x2) (adjoin x1 x2))
                 nil)
           lst))
;; 另一个版本的find-if
(defun our-find-if (fn lst)
  (funcall (lrec (lambda (x) (and (funcall fn x) x))  ;; 这里用and是为了返回找到的这个元素，不然可以直接(funcall fn x)
                 (lambda (x1 x2) (if x1 x1 x2))
                 nil)
           lst))

;; 另一个版本的some
(defun our-some (fn lst)
  (funcall (lrec (lambda (x) (funcall fn x))
                 (lambda (x1 x2) (or x1 x2))
                 nil)
           lst))

;; 在onlisp书上5.5章节上提到的lrec和我这边的实现方式有些不同
;; 与我上面的版本相比，这个版本将如何处理递归放到一个函数里，而不像我逻辑上分成处理car的和处理conc的
;; 他是将conc-fn和car-fn合成一个函数rec传入
;; rec接收两个参数，第一个是(car lst), 第二个递归调用f, (funcall f)会返回递归调用之后项的结果
(defun lrec-onlisp-book-version (rec &optional base)
  (labels ((self (lst)
             (if (null lst)
                 base
                 (funcall rec (car lst)
                          #'(lambda ()
                              (self (cdr lst)))))))
    #'self))

;; 使用这个版本，our-length可以写成
(defun our-length3 (lst)
  (funcall (lrec-onlisp-book-version
            (lambda (x f)
              (declare (ignore x))
              (1+ (funcall f)))
            0)
           lst))

;; 使用这个版本，our-every-oddp可以写成
(defun our-every-oddp3 (lst)
  (funcall (lrec-onlisp-book-version
            (lambda (x f)
              (and (oddp x) (funcall f)))
            t)
           lst))

;; 使用这个版本，our-every可以写成
(defun our-every3 (fn lst)
  (funcall (lrec-onlisp-book-version
            (lambda (x f)
              (and (funcall fn x) (funcall f)))
            t)
           lst))