external/ch-util/src/ch-util.cl

   1 ;;;
   2 ;;; ch-util.cl -- various lisp utilities that make my life easier
   3 ;;;
   4 ;;; Author: Cyrus Harmon <ch-lisp@bobobeach.com>
   5 ;;;
   6
   7 (in-package :ch-util)
   8
   9 ;;; Miscellaneous list utilities
  10
  11 (flet ((cca (l1 l2)
  12          (dolist (x l1)
  13            (let ((y (member x l2)))
  14              (if y (return y))))))
  15   (defun closest-common-ancestor (itm &rest lis)
  16     (if (null lis)
  17         itm
  18         (cca itm (apply #'closest-common-ancestor lis)))))
  19
  20 ;;; Miscellaneous class utilities
  21
  22 (defun subclassp (c1 c2)
  23   (subtypep (class-name c1) (class-name c2)))
  24
  25 ;;; Miscellaneous string utilities
  26
  27 (defun strcat (&rest strs)
  28   (apply #'concatenate 'string strs))
  29
  30 (defun trim (seq suffix)
  31   (subseq seq 0 (search suffix seq)))
  32
  33 ;;; This is a hack so that one day we might run under a case-sensitive lisp
  34 ;;; like Allegro mlisp (modern lisp). For now we encapsulate the uppercasing
  35 ;;; here so we can do the right thing later.
  36 (defun interncase (x)
  37   (string-upcase x))
  38
  39 ;;; simple wrapper for intern to allow us
  40 (defun make-intern (x &optional (package *package*))
  41   (intern (interncase x) package))
  42
  43 (defun make-keyword (x)
  44   (make-intern x 'keyword))
  45
  46 (defun keywordicate (x)
  47   (cond ((keywordp x) x)
  48         (t (make-keyword x))))
  49
  50 (defun keyword-list-names (k)
  51   (mapcar #'(lambda (x)
  52             (symbol-name x))
  53         k))
  54
  55 (defun double-float-divide (&rest args)
  56   (apply #'/ (mapcar #'(lambda (x) (coerce x 'double-float)) args)))
  57
  58 (defun single-float-divide (&rest args)
  59   (apply #'/ (mapcar #'(lambda (x) (coerce x 'single-float)) args)))
  60
  61 (defmacro mapv (function &rest vals)
  62   `(values-list (mapcar ,function (multiple-value-list ,@vals))))
  63
  64 ;;
  65 ;; Silly little macro to do a postincrement, that is
  66 ;; return the value of the place prior to incrementing
  67 ;; it. Like incf, this only works on valid places.
  68 ;;
  69 (defmacro postincf (x &optional (step 1))
  70   (let ((pre (gensym)))
  71     `(let ((,pre ,x))
  72        (incf ,x ,step)
  73        ,pre)))
  74
  75 ;; another silly little function.
  76 ;; this one to sum a 2d array.
  77 ;; undoubtedly a better way to do this.
  78 (defun array-sum (a)
  79   (destructuring-bind (height width) (array-dimensions a)
  80     (let ((acc 0))
  81       (dotimes (h height)
  82         (dotimes (w width)
  83           (incf acc (aref a h w))))
  84       acc)))
  85
  86 (defun array-from-string (str)
  87   (let ((a (make-array (length str) :element-type '(unsigned-byte 8))))
  88     (dotimes (i (length str))
  89       (setf (aref a i) (char-code (elt str i))))
  90     a))
  91
  92 (defun str-to-int (str)
  93   (let ((intval 0))
  94     (map nil #'(lambda (c) (setf intval (+ (ash intval 8) (char-code c)))) str)
  95     intval))
  96
  97 (defun int-to-str (i &optional s)
  98   (if (> i 0)
  99       (let ((r (mod i 256)))
 100         (int-to-str (ash i -8) (cons (code-char r) s)))
 101       (coerce s 'string)))
 102
 103
 104 (defparameter *months*
 105   '((1 . "January")
 106     (2 . "February")
 107     (3 . "March")
 108     (4 . "April")
 109     (5 . "May")
 110     (6 . "June")
 111     (7 . "July")
 112     (8 . "August")
 113     (9 . "September")
 114     (10 . "October")
 115     (11 . "November")
 116     (12 . "December")))
 117
 118 (defun get-current-date ()
 119   (multiple-value-bind (sec min hour date mon year dow dst tz)
 120       (get-decoded-time)
 121     (declare (ignore sec min hour dow dst tz))
 122     (format nil
 123             "~A ~A, ~A"
 124             (cdr (assoc mon *months*))
 125             date
 126             year)))
 127
 128 (defun find-nth-zero (vector n)
 129   "finds the nth zero in a vector."
 130   (loop for i below (length vector)
 131      with count = 0
 132      with rem = n
 133      while (<= count n)
 134      do (when (zerop (aref vector i))
 135           (incf count)
 136           (decf rem))
 137      finally (return (when (minusp rem)
 138                        (1- i)))))
 139
 140 (defun generate-random-permutation (n &key (length n))
 141   "returns a random permutation of length length of the
 142 integers from 0 to n-1."
 143   (let ((a (make-array n)))
 144     (let ((randlist
 145            (loop for i from n downto (1+ (- n length))
 146               collect
 147               (let ((k (random i)))
 148                 (let ((n (find-nth-zero a k)))
 149                   (setf (aref a n) 1)
 150                   n)))))
 151       randlist)))
 152
 153 ;;; this doesn't work yet!
 154 #+nil
 155 (defun robust-mean (vector-or-list)
 156   (flet ((square (a) (* a a)))
 157     (let ((v (cond ((vectorp vector-or-list) vector-or-list)
 158                    ((listp vector-or-list (coerce vector-or-list 'vector))))))
 159       (when v
 160         (let ((n (length v))
 161               (b 1)
 162               (s1 (elt v 0))
 163               (s2 (square (elt v 0))))
 164           (loop for a below n
 165              do ))))))
 166
 167 (defun median (seq)
 168   (let ((v (cond ((vectorp seq) (copy-seq seq))
 169                  ((listp seq) (coerce seq 'vector)))))
 170     (when (and v (plusp (length v)))
 171       (sort v #'<)
 172       (let ((f (floor (length v) 2)))
 173         (cond ((oddp (length v))
 174                (elt v f))
 175               (t
 176                (/ (+ (elt v (1- f))
 177                      (elt v f))
 178                   2)))))))
 179
 180 (defun mean (seq)
 181   (let ((v (cond ((vectorp seq) (copy-seq seq))
 182                  ((listp seq) (coerce seq 'vector)))))
 183     (when (and v (plusp (length v)))
 184       (/  (reduce #'+ v)
 185           (length v)))))
 186
 187 (defun variance (seq)
 188   (flet ((square (x)
 189            (* x x)))
 190     (let* ((v (cond ((vectorp seq) (copy-seq seq))
 191                     ((listp seq) (coerce seq 'vector))))
 192            (n (length v)))
 193       (when (and v (plusp n))
 194         (let ((msq (square (mean seq))))
 195           (/ (reduce #'+ (mapcar #'(lambda (x)
 196                                      (- (square x) msq))
 197                                  seq))
 198              (1- n)))))))
 199
 200 (defun square-seq (seq)
 201   (flet ((square (x)
 202            (* x x)))
 203     (let ((v (cond ((vectorp seq) (copy-seq seq))
 204                    ((listp seq) (coerce seq 'vector)))))
 205       (when (and v (plusp (length v)))
 206         (mapcar #'square seq)))))
 207
 208 (defun remove-keywordish-args (keywords &rest args)
 209   (let ((keys))
 210     (let ((non-keys
 211            (loop for (x y) on args
 212               with skip = nil
 213               append (if skip
 214                          (setf skip nil)
 215                          (if (member x keywords)
 216                              (progn
 217                                (setf skip t)
 218                                (pushnew (cons x y) keys)
 219                                nil)
 220                              (list x))))))
 221       (list (mapcan #'(lambda (x)
 222                         (list (car x) (cdr x)))
 223                     (nreverse keys))
 224             non-keys))))
 225
 226 (defun keyword-arg-name (key)
 227   (cond ((atom key)  key)
 228         ((listp key) (car key))))
 229
 230 (defmacro with-keyword-args (((&rest args) rest) list &body body)
 231   `(destructuring-bind ((&key ,@args) (&rest ,rest))
 232        (apply #'remove-keywordish-args
 233               (mapcar #'keywordicate
 234                       (mapcar #'keyword-arg-name
 235                               ',args))
 236               ,list)
 237      ,@body))
 238
 239 (defun sort-copy (seq pred &key key)
 240   (apply #'sort (copy-seq seq) pred
 241          (when key `(:key ,key))))
 242
 243 (defun iota (n)
 244   (labels ((%iota (n)
 245              (when (plusp n)
 246                (cons n (%iota (1- n))))))
 247     (nreverse (%iota n))))
 248