36cf086d |
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 | |
6bc4028b |
23 | ;; $Id: utils.lisp,v 1.3 2007-07-12 09:02:53 espen Exp $ |
36cf086d |
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 |
6bc4028b |
29 | #:concatenate-strings #:string-prefix-p #:get-all #:plist-remove |
2e8f5edb |
30 | #:delete-collect-if)) |
36cf086d |
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 | |
2e8f5edb |
78 | (defun split-string (string &key (delimiter #'whitespace-p) |
79 | (start 0) (end (length string))) |
36cf086d |
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 |
2e8f5edb |
90 | (split-string string :delimiter predicate :start to :end end))))))) |
36cf086d |
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))))) |
2e8f5edb |
111 | |
6bc4028b |
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))) |
2e8f5edb |
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)))) |