forked from kennytilton/utils-kt
-
Notifications
You must be signed in to change notification settings - Fork 1
/
detritus.lisp
executable file
·237 lines (190 loc) · 6.82 KB
/
detritus.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: utils-kt; -*-
#|
Utils-kt
Copyright (C) 1995, 2006 by Kenneth Tilton
This library is free software; you can redistribute it and/or
modify it under the terms of the Lisp Lesser GNU Public License
(http://opensource.franz.com/preamble.html), known as the LLGPL.
This library is distributed WITHOUT ANY WARRANTY; without even
the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
See the Lisp Lesser GNU Public License for more details.
|#
(in-package :utils-kt)
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '(eval-now! export! assocd rassoca class-proto brk eo subseq-ex)))
(defun subseq-ex (seq start end)
(subseq seq start (min end (length seq))))
(defmacro wdbg (&body body)
`(let ((*dbg* t))
,@body))
(defun assocd (x y) (cdr (assoc x y)))
(defun rassoca (x y) (car (assoc x y)))
(defmacro eo (x y)
`(if (zerop (random 2)) ,x ,y))
(defun class-proto (c)
(let ((cc (find-class c)))
;; all this was conditional on c being found, but if it isn't the find-class errors as coded so
;; let's take out the meaningless condition and see what happens
(finalize-inheritance cc)
#-(or sbcl ccl) (mop::class-prototype cc)
#+ccl (ccl:class-prototype cc)
#+sbcl(sb-mop:class-prototype cc)))
(defun brk (&rest args)
#+its-alive! (apply 'error args)
#-its-alive! (progn
;;(setf *ctk-dbg* t)
(apply 'break args)))
(defun find-after (x l)
(bif (xm (member x l))
(cadr xm)
(brk "find-after ~a not member of ~a" x l)))
(defun find-before (x l)
(loop with prior = nil
for i in l
if (eql i x)
return prior
else do (setf prior i)
finally (brk "find-before ~a not member of ~a" x l)))
(defun list-insert-after (list after new )
(assert (member after list)()"list-insert-after> after arg ~a not a member of list ~a" after list)
(let* ((new-list (copy-list list))
(m (member after new-list)))
(assert m)
(rplacd m (cons new (cdr m)))
new-list))
#+(and mcl (not openmcl-partial-mop))
(defun class-slots (c)
(nconc (copy-list (class-class-slots c))
(copy-list (class-instance-slots c))))
#-(or lispworks mcl)
(progn
(defun true (it) (declare (ignore it)) t)
(defun false (it) (declare (ignore it))))
(defun xor (c1 c2)
(if c1 (not c2) c2))
(export! collect collect-if find-after find-before list-insert-after)
(defun collect (x list &key (key 'identity) (test 'eql))
(loop for i in list
when (funcall test x (funcall key i))
collect i))
(defun collect-if (test list)
(remove-if-not test list))
;;; --- FIFO Queue -----------------------------
(defun make-fifo-queue (&rest init-data)
(let ((q (cons nil nil)))
(prog1 q
(loop for id in init-data
do (fifo-add q id)))))
(deftype fifo-queue () 'cons)
(defun fifo-data (q) (car q))
(defun fifo-clear (q) (rplaca q nil))
(defun fifo-empty (q) (not (fifo-data q)))
(defun fifo-length (q) (length (fifo-data q)))
(defun fifo-peek (q) (car (fifo-data q)))
(defun fifo-browse (q fn)
(map nil fn (fifo-data q)))
(defun fifo-add (q new)
(if (car q)
(let ((last (cdr q))
(newlast (list new)))
(rplacd last newlast)
(rplacd q newlast))
(let ((newlist (list new)))
(rplaca q newlist)
(rplacd q newlist))))
(defun fifo-delete (q dead)
(let ((c (member dead (fifo-data q))))
(assert c)
(rplaca q (delete dead (fifo-data q)))
(when (eq c (cdr q))
(rplacd q (last (fifo-data q))))))
(defun fifo-pop (q)
(unless (fifo-empty q)
(prog1
(fifo-peek q)
(rplaca q (cdar q)))))
(defun fifo-map (q fn)
(loop until (fifo-empty q)
do (funcall fn (fifo-pop q))))
(defmacro with-fifo-map ((pop-var q) &body body)
(let ((qc (gensym)))
`(loop with ,qc = ,q
while (not (fifo-empty ,qc))
do (let ((,pop-var (fifo-pop ,qc)))
,@body))))
#+(or)
(let ((*print-circle* t))
(let ((q (make-fifo-queue)))
(loop for n below 3
do (fifo-add q n))
(fifo-delete q 1)
(loop until (fifo-empty q)
do (print (fifo-pop q)))))
#+allegrosaveit
(defun line-count (path &optional show-files (max-depth most-positive-fixnum) no-semis (depth 0))
(cond
((excl:file-directory-p path)
(if (>= depth max-depth)
(progn
(format t "~&~v,8t~a dir too deep:" depth (pathname-directory path))
0)
(progn
(when show-files
(format t "~&~v,8t~a counts:" depth (pathname-directory path)))
(let ((directory-lines
(loop for file in (directory path :directories-are-files nil)
for lines = (line-count file show-files max-depth no-semis (1+ depth))
when (and show-files (plusp lines))
do (bwhen (fname (pathname-name file))
(format t "~&~v,8t~a ~,40t~d" (1+ depth) fname lines))
summing lines)))
(unless (zerop directory-lines)
(format t "~&~v,8t~a ~,50t~d" depth (pathname-directory path) directory-lines))
directory-lines))))
((find (pathname-type path) '("cl" "lisp" "c" "h" "java")
:test 'string-equal)
(source-line-count path no-semis))
(t 0)))
(defun source-line-count (path no-semis)
(with-open-file (s path)
(loop with block-rem = 0
for line = (read-line s nil nil)
for trim = (when line (string-trim '(#\space #\tab) line))
while line
when (> (length trim) 1)
do (cond
((string= "#|" (subseq trim 0 2))(incf block-rem))
((string= "|#" (subseq trim 0 2))(decf block-rem)))
unless (or (string= trim "")
(and no-semis (or (plusp block-rem)
(char= #\; (schar trim 0)))))
count 1)))
#+(or)
(line-count (make-pathname
:device "c"
:directory `(:absolute "0algcount" ))
nil 5 t)
#+(or)
(loop for d1 in '("cl-s3" "kpax" "puri-1.5.1" "s-base64" "s-http-client" "s-http-server" "s-sysdeps" "s-utils" "s-xml")
summing (line-count (make-pathname
:device "c"
:directory `(:absolute "0Algebra" "1-devtools" ,d1))))
(export! tree-includes tree-traverse tree-intersect)
(defun tree-includes (sought tree &key (test 'eql))
(typecase tree
(null)
(atom (funcall test sought tree))
(cons (or (tree-includes sought (car tree) :test test)
(tree-includes sought (cdr tree) :test test)))))
(defun tree-traverse (tree fn)
(typecase tree
(null)
(atom (funcall fn tree))
(cons (tree-traverse (car tree) fn)
(tree-traverse (cdr tree) fn)))
(values))
(defun tree-intersect (t1 t2 &key (test 'eql))
(tree-traverse t1
(lambda (t1-node)
(when (tree-includes t1-node t2 :test test)
(return-from tree-intersect t1-node)))))