chiark - git - mdw - clg/blob - tools/utils.lisp

   1 ;; Common Lisp bindings for GTK+ v2.x
   2 ;; Copyright 1999-2005 Espen S. Johnsen <espen@users.sf.net>
   3 ;;
   4 ;; Permission is hereby granted, free of charge, to any person obtaining
   5 ;; a copy of this software and associated documentation files (the
   6 ;; "Software"), to deal in the Software without restriction, including
   7 ;; without limitation the rights to use, copy, modify, merge, publish,
   8 ;; distribute, sublicense, and/or sell copies of the Software, and to
   9 ;; permit persons to whom the Software is furnished to do so, subject to
  10 ;; the following conditions:
  11 ;;
  12 ;; The above copyright notice and this permission notice shall be
  13 ;; included in all copies or substantial portions of the Software.
  14 ;;
  15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  22
  23 ;; $Id: utils.lisp,v 1.3 2007-07-12 09:02:53 espen Exp $
  24
  25 (defpackage #:clg-utils
  26   (:use #:common-lisp)
  27   (:export #:read-lines #:mklist #:namep #:funcallable #:return-if #:when-bind
  28            #:visible-char-p #:whitespace-p #:split-string-if #:split-string
  29            #:concatenate-strings #:string-prefix-p #:get-all #:plist-remove
  30            #:delete-collect-if))
  31
  32 (in-package #:clg-utils)
  33
  34 (defun read-lines (&optional (stream *standard-input*))
  35   "Read lines from STREAM until end of file."
  36   (loop
  37    as line = (read-line stream nil)
  38    while line
  39    collect line))
  40
  41 (defun mklist (obj)
  42   (if (and obj (atom obj)) (list obj) obj))
  43
  44 (defun namep (obj)
  45   (and (symbolp obj) (not (member obj '(t nil)))))
  46
  47 (defun funcallable (object)
  48   (if (consp object)
  49       (fdefinition object)
  50     object))
  51
  52 (defmacro return-if (form)
  53   (let ((result (make-symbol "RESULT")))
  54     `(let ((,result ,form))
  55        (when ,result
  56          (return ,result)))))
  57
  58 (defmacro when-bind ((var expr) &body body)
  59   `(let ((,var ,expr))
  60      (when ,var
  61        ,@body)))
  62
  63 (defun visible-char-p (char)
  64   (and (graphic-char-p char) (char/= char #\space)))
  65
  66 (defun whitespace-p (char)
  67   (not (visible-char-p char)))
  68
  69 (defun split-string-if (string predicate)
  70   (declare (simple-string string))
  71   (let ((pos (position-if predicate string :start 1)))
  72     (if (not pos)
  73         (list string)
  74       (cons
  75        (subseq string 0 pos)
  76        (split-string-if (subseq string pos) predicate)))))
  77
  78 (defun split-string (string &key (delimiter #'whitespace-p)
  79                      (start 0) (end (length string)))
  80   (let* ((predicate (if (functionp delimiter)
  81                         delimiter
  82                       #'(lambda (char)
  83                           (find char (mklist delimiter) :test #'char=))))
  84          (from (position-if-not predicate string :start start)))
  85     (when from
  86       (let ((to (position-if predicate string :start from :end end)))
  87         (cons
  88          (subseq string from (or to end))
  89          (when to
  90            (split-string string :delimiter predicate :start to :end end)))))))
  91
  92 (defun concatenate-strings (strings &optional delimiter)
  93   (if (not (rest strings))
  94       (first strings)
  95     (concatenate
  96      'string
  97      (first strings)
  98      (if delimiter (string delimiter) "")
  99      (concatenate-strings (rest strings) delimiter))))
 100
 101 (defun string-prefix-p (prefix string)
 102   (and
 103    (>= (length string) (length prefix))
 104    (string= prefix string :end2 (length prefix))))
 105
 106 (defun get-all (plist property)
 107   (multiple-value-bind (property value tail)
 108       (get-properties plist (list property))
 109     (when tail
 110       (cons value (get-all (cddr tail) property)))))
 111
 112 (defun plist-remove (key plist &key (test #'eq))
 113   (loop
 114    for (%key value) on plist by #'cddr
 115    while (and %key value)
 116    unless (funcall test key %key)
 117    nconc (list %key value)))
 118
 119 (defun delete-collect-if (predicate seq)
 120   (let ((head (cons nil seq)))
 121     (values
 122      (loop
 123       for tmp on head
 124       while (cdr tmp)
 125       when (funcall predicate (second tmp))
 126       collect (let ((elm (second tmp)))
 127                 (setf (cdr tmp) (cddr tmp))
 128                 elm))
 129      (cdr head))))