my-idioms.lisp

;;; anaphoras and the like

(defmacro aif (tst thn &optional els) `(let ((it ,tst)) (if it ,thn ,els)))
(defmacro awhen (tst &body body)      `(let ((it ,tst)) (when it ,@body)))
(defmacro aprog1 (f . fs)             `(let ((it ,f)) ,@fs it))

(defmacro acond (&rest cls)
  (if (null cls) nil
    (let ((cl1 (car cls)) (sym (gensym)))
      `(let ((,sym ,(car cl1)))
         (if ,sym
           (let ((it ,sym)) (declare (ignorable it)) ,@(cdr cl1))
             (acond ,@(cdr cls)))))))

(defmacro and-let* (bindings . body)    ; recommended to use it instead of AAND
  (labels ((expand (bs bdy)
             (cond ((null bs)
                    ;; ()
                    `(progn ,@bdy))
                   ((symbolp (car bs))
                    ;; bound-variable
                    `(if ,(car bs) ,(expand (cdr bs) bdy)))
                   ((and (consp (car bs)) (symbolp (caar bs)) (null (cddar bs)))
                    ;; (variable expression)
                    `(let (,(car bs)) (if ,(caar bs) ,(expand (cdr bs) bdy))))
                   ((and (consp (car bs)) (null (cdar bs)))
                    ;; (expression), i.e. a variable is abbreviated
                    `(if ,(caar bs) ,(expand (cdr bs) bdy)))
                   (t (error "and-let*")))))
    (expand bindings body)))

;;; begins-with / ends-with (for vector, not for list)

(defun begins-with (s sub &aux (l1 (length s)) (l2 (length sub)))
  (and (>= l1 l2)
       (aif (mismatch s sub)
         (= l2 it)
         t)))

(defun ends-with (s sub &aux (l1 (length s)) (l2 (length sub)))
  (and (>= l1 l2)
       (aif (mismatch s sub :from-end t)
         (= (- l1 l2) it)
         t)))

;;; function application utilities

(defun compose   (f g)    (lambda (x) (funcall f (funcall g x))))
(defun rcurry    (f b)    (lambda (a) (funcall f a b)))
(defun lcurry    (f a)    (lambda (b) (funcall f a b)))
(defun lcurry*   (f a)    (lambda (&rest r) (apply f a r)))
(defun lcurry2   (f a b)  (lambda (c) (funcall f a b c)))
(defun aset (a v &rest s) (setf (apply #'aref a s) v))

(defun zip       (xs ys)  (map 'list #'cons xs ys))
(defun k-zip     (x  ys)  (map 'list (lcurry #'cons x) ys))
(defun zip-k     (xs y)   (map 'list (rcurry #'cons y) xs))
(defun foldl     (f z xs) (reduce f xs :initial-value z))

(defun mapvec      (fn &rest seqs)     (apply #'map 'simple-vector fn seqs))
(defun filter      (fn seq &rest rest) (apply #'remove-if-not fn seq rest))
(defun random-vref (vec)               (aref vec (random (length vec))))
(defun n-random    (n limit)           (loop repeat n collect (random limit)))

(defun iota (count &optional (start 0) (step 1))
  (loop repeat count
        for i = start then (+ i step)
        collect i))

;; argmax/argmin 
;;   - arg SEQ should have at least one element.
;;   - see also stackoverflow.com/questions/24166155/largest-sublist-in-common-lisp
(defun argbest (cmp seq &rest rest &key key from-end start end)
  (declare (ignorable start end))
  (check-type cmp FUNCTION)
  (check-type key FUNCTION)
  ;; note: INITIAL-VALUE keyword for REDUCE is always nil
  (let* ((null (cons nil nil)) (best-arg null) arg)
    (labels ((fn (x y)
               (if from-end (keep-better x y) (keep-better y x)))
             (keep-better (new old)
               (if (funcall cmp new old) (progn (setq best-arg arg) new) old))
             (key+ (x)
               (when (eq best-arg null) (setq best-arg x))
               (funcall key (setq arg x))))
      (let ((best-val (apply #'reduce #'fn seq :key #'key+ rest)))
        (values best-arg best-val)))))
(defun argmax (fn seq &rest rest &key from-end start end)
  (declare (ignorable from-end start end))
  (apply #'argbest #'> seq :key fn rest))
(defun argmin (fn seq &rest rest &key from-end start end)
  (declare (ignorable from-end start end))
  (apply #'argbest #'< seq :key fn rest))

;; maximize/minimize
;;   (defun maximize (seq &rest rest) (apply #'reduce #'max seq rest))
;;   might suffice, if KEY keyword is nil.
;
;(defun maximize (seq &rest rest &key key from-end start end)
;  (declare (ignorable from-end start end))
;  (apply #'argmax (or key #'identity) seq rest))
;(defun minimize (seq &rest rest &key key from-end start end)
;  (declare (ignorable from-end start end))
;  (apply #'argmin (or key #'identity) seq rest))
;(defun remove-keyargs (key keyarg-pairs)
; (loop for (p v) on keyarg-pairs by #'cddr unless (eq p key) nconc (list p v)))

;;; staff for something like tconc/lconc
;;; (there are some examples in https://gist.github.com/nfunato/eafdc624f1f0a25caf84#file-xconc-lisp)
(defun empty-q   (&aux (z (list nil)))   (cons z z)) ; add a dummy 1st item
(defun q-empty?  (q)                     (eq (car q) (cdr q)))
(defun q-content (q)                     (cdar q))   ; remove the 1st item
(defun q-head    (q)                     (cadar q))
(defun q-deque   (q)              (prog1 (cadar q) (setf (cdar q) (cddar q))))
(defun q-enque   (q x &aux (z (list x))) (setf (cddr q) z (cdr q) z) q)
(defun q-collect (q x)                   (q-enque q x))
(defun q-nconc   (q z)                   (setf (cddr q) z (cdr q) (last z)) q)
(defun q-append  (q z)                   (q-nconc q (copy-seq z)))

;;;

(defun foldM (f z xs)   ; Maybe m => (a -> b -> m a) -> a -> [b] -> m a
  (flet ((g (acc v)
           (when (null acc) (return-from foldM nil))
           (funcall f acc v)))
    (reduce #'g xs :initial-value z)))

;;; integer-digits conversion 

(defun mapconcat (fn seq &optional (type 'list))
  (apply #'concatenate type (map 'list fn seq)))

(defun digits-to-int (seq &optional (base 10))
  (reduce (lambda (acc d) (+ (* acc base) d)) seq))

(defun bits-to-int (bits)
  (digits-to-int bits 2))

(defun digits (n &optional (base 10))
  (labels ((rec (n acc len)
             (multiple-value-bind (q r) (floor n base)
               (if (zerop n)
                   (if (null acc) (values '(0) 1) (values acc len))
                   (rec q (cons r acc) (1+ len))))))
    (rec n '() 0)))

(defun int-to-digits (n &optional (base 10) (column 1))
  (multiple-value-bind (digits len) (digits n base)
    (nconc (make-list (max (- column len) 0) :initial-element 0) digits)))

(defun int-to-bits (n &optional (column 1))
  (int-to-digits n 2 column))

;;; dictionary API like python

(defmacro dict ((key val) keys)
  `(aprog1 (make-hash-table :test #'equal)
           (mapc (lambda (,key) (setf (gethash ,key it) ,val))
                 ,keys)))

(defun dict-copy (ht)   ; you can use alexandria:copy-hash-table instead of it
  (loop with ht2 = (make-hash-table :test (hash-table-test ht))
        for k being the hash-keys in ht
        using (hash-value v)
        do (setf (gethash k ht2) v)
        finally (return ht2)))

(defun dict-get (ht key &optional (error-ctrl nil ec-sup) default)
  (or (gethash key ht)
      (if (and ec-sup (null error-ctrl))
          default
          (error error-ctrl))))

(defun dict-set! (ht val key)
  (setf (gethash key ht) val)
  ht)

(defun dict-set (ht val key)
  (dict-set! (dict-copy ht) val key))

(defun dict-items (ht &key (test (constantly t)))
  (loop for k being the hash-keys in ht using (hash-value v)
        when (funcall test k v) collect (cons k v)))

;;; dimension-independent array operations

(defun array-foreach1 (f a)
  (loop for i from 0 below (array-total-size a) do
    (funcall f (row-major-aref a i))))

(defun array-map1! (a2 f a)
  (loop for i from 0 below (array-total-size a) do
    (setf (row-major-aref a2 i) (funcall f (row-major-aref a i))))
  a2)

;; from Common Lisp Recipes
(defun copy-array (a &aux (dims (array-dimensions a)))
  (adjust-array (make-array dims
                            :element-type (array-element-type a)
                            :displaced-to a)
                dims))

(defun array-map1    (f a) (array-map1! (copy-array a) f a))

(defun vectorize-array (a)
  (make-array (array-total-size a)
              :element-type (array-element-type a)
              :displaced-to a))

;;; string operations

;; from https://gist.github.com/shirok/20c63902b195b0e03a55ecf066ca30bf
(defun join (sep xs)
  (format nil "~{~a~#,1^~a~}" (mapcan (lambda (x) (list x sep)) xs)))

(defun concat (strings)
  (apply #'concatenate 'string strings))

(defun read-file (path)
  (with-open-file (st path :direction :input)
    (concat (loop for l = (read-line st nil) while l collect l))))

;;; input readers

(defun read-with-prompt (&optional prompt)
  (when prompt
    (format *query-io* prompt)
    (finish-output *query-io*))
  (read *query-io*))

;; we can separate syntax checker from (semantic) checker below,
;; and replace read-with-prompt below with read-with-syntax-check
;; which wraps read-with-prompt with syntax-only checker
;; (defun read-with-syntax-check (prompt)
;;   (loop for x = (read-with-prompt prompt)
;;         if (check-syntax x) return it))

(defun read-input (prompt &key (restart-format "Input again") checker)
  (flet ((fn (x) (if (funcall (or checker #'identity) x) x)))
    (loop
      (with-simple-restart (try-again restart-format)
        (awhen (funcall #'fn (read-with-prompt prompt))
          (return it))))))

;;; population counter -- use it with (declaim (inline popcnt)) if needed

(defun popcnt (i)
  (declare (type fixnum i))             ; prompt compilers to use CPU POPCNT
  (logcount i))

;;; randomization

(defun shuffle-vector (vec)             ; Fisher-Yates shuffle
  (loop for i from (1- (length vec)) downto 1
        for j = (random (1+ i))
        do (rotatef (aref vec i) (aref vec j))
        finally (return vec)))

(defun shuffle-list (lst)
  (coerce (shuffle-vector (coerce lst 'simple-vector)) 'list))

;;; with-gensyms / once-only -- from Practical Common Lisp by Peter Seibel

(defmacro with-gensyms ((&rest names) &body body)
  `(let ,(loop for n in names collect `(,n (gensym)))
     ,@body))

(defmacro once-only ((&rest names) &body body)
  (let ((gensyms (loop for n in names collect (gensym))))
    `(let (,@(loop for g in gensyms collect `(,g (gensym))))
       `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
          ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
                ,@body)))))

(defmacro with-accessors+ (slot-entries form . body)  ; by nfunato
  "Provide light-weight syntax for WITH-ACCESSORS, similar to WITH-SLOTS. 
Each SLOT-ENTRY can take form either (VARIABLE-NAME ACCESSOR-NAME) or VARIABLE-NAME. The latter is expanded into the former, where VARIABLE-NAME and ACCESSOR-NAME is same. Writing a definition of such ACCESSOR is responsible for programmers. 
Note that one of differences between WITH-ACCESSORS and WITH-SLOTS is that the former is high-level and obtains the benefits of method combination while the latter does not."
  (once-only (form)
    (flet ((canonicalize-slot-entry (se)
             (if (symbolp se) (list se se) se)))
      `(with-accessors ,(mapcar #'canonicalize-slot-entry slot-entries) ,form
         ,@body))))

;;; destructure-case -- placed to public domain by me

(defmacro destructure-case (value-expr &rest clauses)
  (assert clauses)
  (let ((var (gensym "V-")))
    (labels ((normalize-clauses (cls)
               (if (eq (caar (last cls)) 'otherwise)
                   cls
                   (let ((default '(otherwise (error "No macthing clause."))))
                     (append cls (list default)))))
             (gen-destructure-clause (var pat body-expr next)
               (labels ((cons?  (p) (and (consp p) (not (eq (car p) 'quote))))
                        (quote? (p) (and (consp p) (eq (car p) 'quote)))
                        (lit?   (p) (or (KEYWORDP p) (integerp p) (stringp p)))
                        (ign (v)
                          (if (char= (aref (symbol-name v) 0) #\_)
                              `((declare (IGNORABLE ,v)))))
                        (dc (v p e)
                          (cond ((cons? p)
                                 `(if (consp ,v)
                                      ,(dc `(car ,v)
                                           (car p)
                                           (dc `(cdr ,v) (cdr p) e))
                                      (,next)))
                                ((eq p T)    e)
                                ((quote? p)  `(if (eq ,v ,p)    ,e (,next)))
                                ((lit? p)    `(if (equal ,v ,p) ,e (,next)))
                                ((null p)    `(if (null ,v)     ,e (,next)))
                                ((symbolp p) `(let ((,p ,v)) ,@(IGN p) ,e))
                                (t (error "Illegal pattern: ~s" p)))))
                 (if (eq pat 'otherwise)
                     body-expr
                     (dc var pat body-expr))))
             (gen-labels-clause (curr next clause)
               (destructuring-bind (pat . body) clause
                 `(,curr ()
                   ,(gen-destructure-clause var pat `(progn ,@body) next)))))
      (let* ((clauses* (normalize-clauses clauses))
             (currs (loop for nil in clauses* collect (gensym "L-")))
             (nexts (append (cdr currs) '(nil))))
        `(let ((,var ,value-expr))
           (labels ,(mapcar #'gen-labels-clause currs nexts clauses*)
             (,(car currs))))))))

;;; debugging staff

(defparameter *break-on-words*
  '(
;   "hoge"
;   "fuga"
    ))

(defun break-on (word &rest fmt-and-args &key (test (constantly t)))
  ;; For example, put (break-on "hoge") or (break-on "hoge" "~s" ..) 
  ;; in the line where you'd like to break, and tweak *break-on-words* 
  (when (and (some (lambda (w) (search w word)) *break-on-words*)
             (funcall test))
    (apply #'break fmt-and-args)))