2 ;;; ch-util.cl -- various lisp utilities that make my life easier
4 ;;; Author: Cyrus Harmon <ch-lisp@bobobeach.com>
9 ;;; Miscellaneous list utilities
13 (let ((y (member x l2
)))
15 (defun closest-common-ancestor (itm &rest lis
)
18 (cca itm
(apply #'closest-common-ancestor lis
)))))
20 ;;; Miscellaneous class utilities
22 (defun subclassp (c1 c2
)
23 (subtypep (class-name c1
) (class-name c2
)))
25 ;;; Miscellaneous string utilities
27 (defun strcat (&rest strs
)
28 (apply #'concatenate
'string strs
))
30 (defun trim (seq suffix
)
31 (subseq seq
0 (search suffix seq
)))
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.
39 ;;; simple wrapper for intern to allow us
40 (defun make-intern (x &optional
(package *package
*))
41 (intern (interncase x
) package
))
43 (defun make-keyword (x)
44 (make-intern x
'keyword
))
46 (defun keywordicate (x)
47 (cond ((keywordp x
) x
)
48 (t (make-keyword x
))))
50 (defun keyword-list-names (k)
55 (defun double-float-divide (&rest args
)
56 (apply #'/ (mapcar #'(lambda (x) (coerce x
'double-float
)) args
)))
58 (defun single-float-divide (&rest args
)
59 (apply #'/ (mapcar #'(lambda (x) (coerce x
'single-float
)) args
)))
61 (defmacro mapv
(function &rest vals
)
62 `(values-list (mapcar ,function
(multiple-value-list ,@vals
))))
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.
69 (defmacro postincf
(x &optional
(step 1))
75 ;; another silly little function.
76 ;; this one to sum a 2d array.
77 ;; undoubtedly a better way to do this.
79 (destructuring-bind (height width
) (array-dimensions a
)
83 (incf acc
(aref a h w
))))
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
))))
92 (defun str-to-int (str)
94 (map nil
#'(lambda (c) (setf intval
(+ (ash intval
8) (char-code c
)))) str
)
97 (defun int-to-str (i &optional s
)
99 (let ((r (mod i
256)))
100 (int-to-str (ash i -
8) (cons (code-char r
) s
)))
104 (defparameter *months
*
118 (defun get-current-date ()
119 (multiple-value-bind (sec min hour date mon year dow dst tz
)
121 (declare (ignore sec min hour dow dst tz
))
124 (cdr (assoc mon
*months
*))
128 (defun find-nth-zero (vector n
)
129 "finds the nth zero in a vector."
130 (loop for i below
(length vector
)
134 do
(when (zerop (aref vector i
))
137 finally
(return (when (minusp rem
)
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
)))
145 (loop for i from n downto
(1+ (- n length
))
147 (let ((k (random i
)))
148 (let ((n (find-nth-zero a k
)))
153 ;;; this doesn't work yet!
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
))))))
163 (s2 (square (elt v
0))))
168 (let ((v (cond ((vectorp seq
) (copy-seq seq
))
169 ((listp seq
) (coerce seq
'vector
)))))
170 (when (and v
(plusp (length v
)))
172 (let ((f (floor (length v
) 2)))
173 (cond ((oddp (length v
))
181 (let ((v (cond ((vectorp seq
) (copy-seq seq
))
182 ((listp seq
) (coerce seq
'vector
)))))
183 (when (and v
(plusp (length v
)))
187 (defun variance (seq)
190 (let* ((v (cond ((vectorp seq
) (copy-seq seq
))
191 ((listp seq
) (coerce seq
'vector
))))
193 (when (and v
(plusp n
))
194 (let ((msq (square (mean seq
))))
195 (/ (reduce #'+ (mapcar #'(lambda (x)
200 (defun square-seq (seq)
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
)))))
208 (defun remove-keywordish-args (keywords &rest args
)
211 (loop for
(x y
) on args
215 (if (member x keywords
)
218 (pushnew (cons x y
) keys
)
221 (list (mapcan #'(lambda (x)
222 (list (car x
) (cdr x
)))
226 (defun keyword-arg-name (key)
227 (cond ((atom key
) key
)
228 ((listp key
) (car key
))))
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
239 (defun sort-copy (seq pred
&key key
)
240 (apply #'sort
(copy-seq seq
) pred
241 (when key
`(:key
,key
))))
246 (cons n
(%iota
(1- n
))))))
247 (nreverse (%iota n
))))