genutils.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          gentils.lisp
   6 ;;;; Purpose:       Main general utility functions for KMRCL package
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; $Id: genutils.lisp,v 1.16 2003/04/28 21:12:27 kevin Exp $
  11 ;;;;
  12 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; KMRCL users are granted the rights to distribute and use this software
  15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  17 ;;;; *************************************************************************
  18
  19
  20 (in-package :kmrcl)
  21
  22 (defmacro let-when ((var test-form) &body body)
  23   `(let ((,var ,test-form))
  24       (when ,var ,@body)))
  25
  26 (defmacro let-if ((var test-form) if-true &optional if-false)
  27   `(let ((,var ,test-form))
  28       (if ,var ,if-true ,if-false)))
  29
  30 ;; Anaphoric macros
  31
  32 (defmacro aif (test then &optional else)
  33   `(let ((it ,test))
  34      (if it ,then ,else)))
  35
  36 (defmacro awhen (test-form &body body)
  37   `(aif ,test-form
  38         (progn ,@body)))
  39
  40 (defmacro awhile (expr &body body)
  41   `(do ((it ,expr ,expr))
  42        ((not it))
  43      ,@body))
  44
  45 (defmacro aand (&rest args)
  46   (cond ((null args) t)
  47         ((null (cdr args)) (car args))
  48         (t `(aif ,(car args) (aand ,@(cdr args))))))
  49
  50 (defmacro acond (&rest clauses)
  51   (if (null clauses)
  52       nil
  53       (let ((cl1 (car clauses))
  54             (sym (gensym)))
  55         `(let ((,sym ,(car cl1)))
  56            (if ,sym
  57                (let ((it ,sym)) ,@(cdr cl1))
  58                (acond ,@(cdr clauses)))))))
  59
  60 (defmacro alambda (parms &body body)
  61   `(labels ((self ,parms ,@body))
  62      #'self))
  63
  64
  65 (defmacro aif2 (test &optional then else)
  66   (let ((win (gensym)))
  67     `(multiple-value-bind (it ,win) ,test
  68        (if (or it ,win) ,then ,else))))
  69
  70 (defmacro awhen2 (test &body body)
  71   `(aif2 ,test
  72          (progn ,@body)))
  73
  74 (defmacro awhile2 (test &body body)
  75   (let ((flag (gensym)))
  76     `(let ((,flag t))
  77        (while ,flag
  78          (aif2 ,test
  79                (progn ,@body)
  80                (setq ,flag nil))))))
  81
  82 (defmacro acond2 (&rest clauses)
  83   (if (null clauses)
  84       nil
  85       (let ((cl1 (car clauses))
  86             (val (gensym))
  87             (win (gensym)))
  88         `(multiple-value-bind (,val ,win) ,(car cl1)
  89            (if (or ,val ,win)
  90                (let ((it ,val)) ,@(cdr cl1))
  91                (acond2 ,@(cdr clauses)))))))
  92
  93
  94 ;; Debugging
  95
  96 (defmacro mac (expr)
  97 "Expand a macro"
  98   `(pprint (macroexpand-1 ',expr)))
  99
 100 (defmacro print-form-and-results (form)
 101   `(format t "~&~A --> ~S~%" (write-to-string ',form) ,form))
 102
 103 (defun show (&optional (what :variables) (package *package*))
 104   (ecase what
 105     (:variables (show-variables package))
 106     (:functions (show-functions package))))
 107
 108 (defun show-variables (package)
 109   (do-symbols (s package)
 110     (multiple-value-bind (sym status)
 111         (find-symbol (symbol-name s) package)
 112       (when (and (or (eq status :external)
 113                      (eq status :internal))
 114                  (boundp sym))
 115         (format t "~&Symbol ~S~T -> ~S~%"
 116                 sym
 117                 (symbol-value sym))))))
 118
 119 (defun show-functions (package)
 120   (do-symbols (s package)
 121     (multiple-value-bind (sym status)
 122         (find-symbol (symbol-name s) package)
 123       (when (and (or (eq status :external)
 124                      (eq status :internal))
 125                  (fboundp sym))
 126         (format t "~&Function ~S~T -> ~S~%"
 127                 sym
 128                 (symbol-function sym))))))
 129
 130 #+allegro
 131 (ff:def-foreign-call (memory-status-dump "memory_status_dump")
 132     ()
 133   :strings-convert t)
 134
 135
 136 ;; Ensure functions
 137
 138 (defmacro ensure-integer (obj)
 139   "Ensure object is an integer. If it is a string, then parse it"
 140   `(if (stringp ,obj)
 141       (parse-integer ,obj)
 142     ,obj))
 143
 144 ;; Lists
 145
 146 (defun mklist (obj)
 147   "Make into list if atom"
 148   (if (listp obj) obj (list obj)))
 149
 150 (defun filter (fn lst)
 151   "Filter a list by function, eliminate elements where fn returns nil"
 152   (let ((acc nil))
 153     (dolist (x lst)
 154       (let ((val (funcall fn x)))
 155         (if val (push val acc))))
 156     (nreverse acc)))
 157
 158 (defun appendnew (l1 l2)
 159   "Append two lists, filtering out elem from second list that are already in first list"
 160   (dolist (elem l2)
 161     (unless (find elem l1)
 162       (setq l1 (append l1 (list elem)))))
 163   l1)
 164
 165 ;; Functions
 166
 167 (defun memo-proc (fn)
 168   "Memoize results of call to fn, returns a closure with hash-table"
 169   (let ((cache (make-hash-table :test #'equal)))
 170     #'(lambda (&rest args)
 171         (multiple-value-bind (val foundp) (gethash args cache)
 172           (if foundp
 173               val
 174               (setf (gethash args cache)
 175                     (apply fn args)))))))
 176
 177 (defun memoize (fn-name)
 178   (setf (fdefinition fn-name) (memo-proc (fdefinition fn-name))))
 179
 180 (defmacro defun-memo (fn args &body body)
 181   "Define a memoized function"
 182   `(memoize (defun ,fn ,args . ,body)))
 183
 184 (defmacro _f (op place &rest args)
 185   (multiple-value-bind (vars forms var set access)
 186                        (get-setf-expansion place)
 187     `(let* (,@(mapcar #'list vars forms)
 188             (,(car var) (,op ,access ,@args)))
 189        ,set)))
 190
 191 (defun compose (&rest fns)
 192   (if fns
 193       (let ((fn1 (car (last fns)))
 194             (fns (butlast fns)))
 195         #'(lambda (&rest args)
 196             (reduce #'funcall fns
 197                     :from-end t
 198                     :initial-value (apply fn1 args))))
 199       #'identity))
 200
 201 ;;; Loop macros
 202
 203 (defmacro until (test &body body)
 204   `(do ()
 205        (,test)
 206      ,@body))
 207
 208 (defmacro while (test &body body)
 209   `(do ()
 210        ((not ,test))
 211      ,@body))
 212
 213 (defmacro for ((var start stop) &body body)
 214   (let ((gstop (gensym)))
 215     `(do ((,var ,start (1+ ,var))
 216           (,gstop ,stop))
 217          ((> ,var ,gstop))
 218        ,@body)))
 219
 220 (defmacro with-each-stream-line ((var stream) &body body)
 221   (let ((eof (gensym))
 222         (eof-value (gensym))
 223         (strm (gensym)))
 224     `(let ((,strm ,stream)
 225            (,eof ',eof-value))
 226       (do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof)))
 227           ((eql ,var ,eof))
 228         ,@body))))
 229
 230 (defmacro with-each-file-line ((var file) &body body)
 231   (let ((stream (gensym)))
 232     `(with-open-file (,stream ,file :direction :input)
 233       (with-each-stream-line (,var ,stream)
 234         ,@body))))
 235
 236
 237 ;;; Keyword functions
 238
 239 (defun remove-keyword (key arglist)
 240   (loop for sublist = arglist then rest until (null sublist)
 241         for (elt arg . rest) = sublist
 242         unless (eq key elt) append (list elt arg)))
 243
 244 (defun remove-keywords (key-names args)
 245   (loop for ( name val ) on args by #'cddr
 246         unless (member (symbol-name name) key-names
 247                        :key #'symbol-name :test 'equal)
 248         append (list name val)))
 249
 250 (defmacro in (obj &rest choices)
 251   (let ((insym (gensym)))
 252     `(let ((,insym ,obj))
 253        (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
 254                      choices)))))
 255
 256 (defmacro mean (&rest args)
 257   `(/ (+ ,@args) ,(length args)))
 258
 259 (defmacro with-gensyms (syms &body body)
 260   `(let ,(mapcar #'(lambda (s) `(,s (gensym)))
 261           syms)
 262      ,@body))
 263
 264
 265 ;;; Mapping
 266
 267 (defun mapappend (fn list)
 268   (apply #'append (mapcar fn list)))
 269
 270
 271 (defun mapcar-append-string-nontailrec (func v)
 272   "Concatenate results of mapcar lambda calls"
 273   (aif (car v)
 274        (concatenate 'string (funcall func it)
 275                     (mapcar-append-string-nontailrec func (cdr v)))
 276        ""))
 277
 278
 279 (defun mapcar-append-string (func v &optional (accum ""))
 280   "Concatenate results of mapcar lambda calls"
 281   (aif (car v)
 282        (mapcar-append-string
 283         func
 284         (cdr v)
 285         (concatenate 'string accum (funcall func it)))
 286        accum))
 287
 288 (defun mapcar2-append-string-nontailrec (func la lb)
 289   "Concatenate results of mapcar lambda call's over two lists"
 290   (let ((a (car la))
 291         (b (car lb)))
 292     (if (and a b)
 293       (concatenate 'string (funcall func a b)
 294                    (mapcar2-append-string-nontailrec func (cdr la) (cdr lb)))
 295       "")))
 296
 297 (defun mapcar2-append-string (func la lb &optional (accum ""))
 298   "Concatenate results of mapcar lambda call's over two lists"
 299   (let ((a (car la))
 300         (b (car lb)))
 301     (if (and a b)
 302         (mapcar2-append-string
 303          func
 304          (cdr la)
 305          (cdr lb)
 306          (concatenate 'string accum (funcall func a b)))
 307       accum)))
 308
 309
 310 ;;; Output
 311
 312 (defun indent-spaces (n &optional (stream *standard-output*))
 313   "Indent n*2 spaces to output stream"
 314   (when (numberp n)
 315     (let ((fmt (format nil "~~~DT" (+ n n))))
 316       (format stream fmt))))
 317
 318 (defun print-list (l &optional (output *standard-output*))
 319   "Print a list to a stream"
 320   (if (consp l)
 321     (progn
 322       (mapcar (lambda (x) (princ x output) (princ #\newline output)) l)
 323       t)
 324     nil))
 325
 326 (defun print-rows (rows &optional (ostrm *standard-output*))
 327   "Print a list of list rows to a stream"
 328   (dolist (r rows)
 329     (mapcar (lambda (a) (princ a ostrm) (princ #\space ostrm)) r)
 330     (terpri ostrm)))
 331
 332
 333 ;;; IO
 334
 335
 336 (defstruct buf
 337   vec (start -1) (used -1) (new -1) (end -1))
 338
 339 (defun bref (buf n)
 340   (svref (buf-vec buf)
 341          (mod n (length (buf-vec buf)))))
 342
 343 (defun (setf bref) (val buf n)
 344   (setf (svref (buf-vec buf)
 345                (mod n (length (buf-vec buf))))
 346         val))
 347
 348 (defun new-buf (len)
 349   (make-buf :vec (make-array len)))
 350
 351 (defun buf-insert (x b)
 352   (setf (bref b (incf (buf-end b))) x))
 353
 354 (defun buf-pop (b)
 355   (prog1
 356     (bref b (incf (buf-start b)))
 357     (setf (buf-used b) (buf-start b)
 358           (buf-new  b) (buf-end   b))))
 359
 360 (defun buf-next (b)
 361   (when (< (buf-used b) (buf-new b))
 362     (bref b (incf (buf-used b)))))
 363
 364 (defun buf-reset (b)
 365   (setf (buf-used b) (buf-start b)
 366         (buf-new  b) (buf-end   b)))
 367
 368 (defun buf-clear (b)
 369   (setf (buf-start b) -1 (buf-used  b) -1
 370         (buf-new   b) -1 (buf-end   b) -1))
 371
 372 (defun buf-flush (b str)
 373   (do ((i (1+ (buf-used b)) (1+ i)))
 374       ((> i (buf-end b)))
 375     (princ (bref b i) str)))
 376
 377
 378 (defun file-subst (old new file1 file2)
 379   (with-open-file (in file1 :direction :input)
 380     (with-open-file (out file2 :direction :output
 381                          :if-exists :supersede)
 382       (stream-subst old new in out))))
 383
 384 (defun stream-subst (old new in out)
 385   (declare (string old new))
 386   (let* ((pos 0)
 387          (len (length old))
 388          (buf (new-buf len))
 389          (from-buf nil))
 390     (declare (fixnum pos len))
 391     (do ((c (read-char in nil :eof)
 392             (or (setf from-buf (buf-next buf))
 393                 (read-char in nil :eof))))
 394         ((eql c :eof))
 395       (declare (character c))
 396       (cond ((char= c (char old pos))
 397              (incf pos)
 398              (cond ((= pos len)            ; 3
 399                     (princ new out)
 400                     (setf pos 0)
 401                     (buf-clear buf))
 402                    ((not from-buf)         ; 2
 403                     (buf-insert c buf))))
 404             ((zerop pos)                   ; 1
 405              (princ c out)
 406              (when from-buf
 407                (buf-pop buf)
 408                (buf-reset buf)))
 409             (t                             ; 4
 410              (unless from-buf
 411                (buf-insert c buf))
 412              (princ (buf-pop buf) out)
 413              (buf-reset buf)
 414              (setf pos 0))))
 415     (buf-flush buf out)))
 416
 417
 418 ;;; Tree Functions
 419
 420 (defun remove-tree-if (pred tree)
 421   "Strip from tree of atoms that satistify predicate"
 422   (if (atom tree)
 423       (unless (funcall pred tree)
 424         tree)
 425     (let ((car-strip (remove-tree-if pred (car tree)))
 426           (cdr-strip (remove-tree-if pred (cdr tree))))
 427       (cond
 428        ((and car-strip (atom (cadr tree)) (null cdr-strip))
 429         (list car-strip))
 430        ((and car-strip cdr-strip)
 431         (cons car-strip cdr-strip))
 432        (car-strip
 433         car-strip)
 434        (cdr-strip
 435         cdr-strip)))))
 436
 437 (defun find-tree (sym tree)
 438   "Finds an atom as a car in tree and returns cdr tree at that positions"
 439   (if (or (null tree) (atom tree))
 440       nil
 441     (if (eql sym (car tree))
 442         (cdr tree)
 443       (aif (find-tree sym (car tree))
 444           it
 445         (aif (find-tree sym (cdr tree))
 446             it
 447           nil)))))
 448
 449 ;;; Files
 450
 451 (defun print-file-contents (file &optional (strm *standard-output*))
 452   "Opens a reads a file. Returns the contents as a single string"
 453   (when (probe-file file)
 454     (with-open-file (in file :direction :input)
 455       (let ((eof (gensym)))
 456         (do ((line (read-line in nil eof)
 457                    (read-line in nil eof)))
 458             ((eq line eof))
 459           (format strm "~A~%" line))))))
 460
 461 (defun read-file-to-string (file)
 462   "Opens a reads a file. Returns the contents as a single string"
 463   (with-output-to-string (out)
 464     (with-open-file (in file :direction :input)
 465       (let ((eof (gensym)))
 466         (do ((line (read-line in nil eof)
 467                    (read-line in nil eof)))
 468             ((eq line eof))
 469           (format out "~A~%" line))))))
 470
 471 (defun read-file-to-strings (file)
 472   "Opens a reads a file. Returns the contents as a list of strings"
 473   (let ((lines '()))
 474     (with-open-file (in file :direction :input)
 475       (let ((eof (gensym)))
 476         (do ((line (read-line in nil eof)
 477                    (read-line in nil eof)))
 478             ((eq line eof))
 479           (push line lines)))
 480       (nreverse lines))))
 481
 482
 483
 484 ;; Benchmarking
 485
 486 (defun print-float-units (val unit)
 487   (cond
 488     ((< val 1d-6)
 489      (format t "~,2,9F nano~A" val unit))
 490     ((< val 1d-3)
 491      (format t "~,2,6F micro~A" val unit))
 492     ((< val 1)
 493      (format t "~,2,3F milli~A" val unit))
 494     ((> val 1d9)
 495      (format t "~,2,-9F giga~A" val unit))
 496     ((> val 1d6)
 497      (format t "~,2,-6F mega~A" val unit))
 498     ((> val 1d3)
 499      (format t "~,2,-3F kilo~A" val unit))
 500     (t
 501      (format t "~,2F ~A" val unit))))
 502
 503 (defun print-seconds (secs)
 504   (print-float-units secs "sec"))
 505
 506 (defmacro time-iterations (n &body body)
 507   (let ((i (gensym))
 508         (count (gensym)))
 509     `(progn
 510        (let ((,count ,n))
 511          (format t "~&Test with ~d iterations: ~W" ,count (quote ,body))
 512          (let ((t1 (get-internal-real-time)))
 513            (dotimes (,i ,count)
 514              ,@body)
 515            (let* ((t2 (get-internal-real-time))
 516                   (secs (coerce (/ (- t2 t1)
 517                                    internal-time-units-per-second)
 518                                 'double-float)))
 519              (format t "~&Total time: ")
 520              (print-seconds secs)
 521              (format t ", time per iteration: ")
 522              (print-seconds (coerce (/ secs ,n) 'double-float))))))))
 523
 524
 525 (defun nsubseq (sequence start &optional (end (length sequence)))
 526   (make-array (- end start)
 527               :element-type (array-element-type sequence)
 528               :displaced-to sequence
 529               :displaced-index-offset start))