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