-
Notifications
You must be signed in to change notification settings - Fork 0
/
misc.lisp
706 lines (654 loc) · 33 KB
/
misc.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
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
;; -*- lisp -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;**************************************************************************************************
;; FOMUS
;; misc.lisp
;;**************************************************************************************************
;; ***** UPDATED COMMENTS *****
(in-package :fomus)
(compile-settings)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; GENERAL
;; normalize print variables for printing to output file
(defmacro setprints (&body forms)
`(let ((*print-array* t) (*print-base* 10) (*print-case* :downcase) (*print-circle* nil) (*print-gensym* t) (*print-length* nil)
(*print-level* nil) (*print-pretty* t) (*print-radix* nil) (*print-readably* nil) (*print-escape* t))
,@forms))
;; cmu and sbcl prints out an annoying warning referring to some internal operation sometimes--this gets rid of it
#+(or cmu sbcl)
(defmacro muffwarn (&body forms)
`(handler-bind ((style-warning (lambda (x) (declare (ignore x)) (muffle-warning))))
,@forms))
;; catches errors and prints them with lispy ';;' marks without dying
(defmacro catcherr (&body forms)
`(handler-case (progn ,@forms)
(error (co)
(fresh-line)
(format t ";;; *****ERROR*****~%")
(loop with s = (make-string-input-stream (string-trim '(#\newline #\space) (princ-to-string co)))
for l = (read-line s nil 'eof)
until (eq l 'eof)
do (format t ";; ~A~%" l))
nil)))
;; concatenate strings and lists of strings (i hate typing the word concatenate)
(declaim (inline conc-strings conc-stringlist))
(defun conc-strings (&rest strings)
(apply #'concatenate 'string strings))
(defun conc-stringlist (list)
(declare (type list list))
(apply #'concatenate 'string list))
;; replaces only the parts of the filename given as keywords
;; tries to deal with implementation/playform-specific quirks involving trailing '/' characters
(declaim (inline change-filename))
(defun change-filename (filename &key (dir (pathname-directory filename)) (name (pathname-name filename)) (ext (pathname-type filename)))
(declare (type (or pathname string list) filename name ext) (type (or pathname string list) dir))
(namestring (make-pathname :device (pathname-device filename)
:directory
(if (or (stringp dir) (pathnamep dir))
(pathname-directory (conc-strings dir "/"))
dir)
:name name :type ext)))
;; tests for t
(declaim (inline truep))
(defun truep (x) (eq x t))
;; gets last element
(declaim (inline last-element))
(defun last-element (list)
(declare (type list list))
(car (last list)))
;; installs reader macro #Z
;; (when (get-dispatch-macro-character #\# #\Z) ; some Lisps return an error function, so don't bother printing warning
;; (format t ";; WARNING: Reinstalling dispatch macro #Z~%"))
(set-dispatch-macro-character
#\# #\Z
(lambda (s c n)
(declare (type stream s) (ignore c n))
(let ((r (read s t nil t)))
(apply #'make-instance r))))
;; generate methods to print fomus classes and structs
(declaim (type boolean *prepend-fm*))
(defparameter *prepend-fm* nil)
(defmacro defprint-class (class &rest slots)
(let ((sl (loop
for i in slots
unless (and (listp i) (null (second i)))
collect (if (listp i) (second i) (intern (string i) 'keyword))
collect (list 'slot-value 'x (list 'quote (if (listp i) (first i) i))))))
`(defmethod print-object ((x ,class) s)
(declare (type stream s))
(princ "#Z" s)
(if *prepend-fm*
(format s "(~A:~A~{ ~S~})"
(if (eq *print-case* :downcase) "fm" "FM")
,(list 'quote class)
,(cons 'list sl))
(prin1 ,(nconc (list 'list (list 'quote class)) sl)
s)))))
(defmacro defprint-struct (class &rest slots)
(let ((sl (loop
for i in slots
unless (and (listp i) (null (second i)))
collect (if (listp i) (second i) (intern (string i) 'keyword))
collect (list (if (listp i) (first i) i) 'x))))
`(defmethod print-object ((x ,class) s)
(declare (type stream s))
(princ "#S" s)
(if *prepend-fm*
(format s "(~A:~A~{ ~S~})"
(if (eq *print-case* :downcase) "fm" "FM")
,(list 'quote class)
,(cons 'list sl))
(prin1 ,(nconc (list 'list (list 'quote class)) sl)
s)))))
;; if list = an atom, forces it into a list
;; if list = a list, returns the list
(declaim (inline force-list force-newlist))
(defun force-list (list)
(if (listp list) list (list list)))
;; returns a new list regardless
(defun force-newlist (list)
(if (listp list) (copy-list list) (list list)))
;; returns doubly nested list, expecting that only some of the inner items might be lists
(defun force-list2some (list)
(let ((x (force-list list)))
(if (or (null x) (some #'consp x)) x
(list x))))
;; returns doubly nested list, expecting that all the inner items might be lists
(defun force-list2all (list)
(let ((x (force-list list)))
(if (or (null x) (every #'consp x)) x
(list x))))
;; objs = list
;; places = list of lists
;; prepends objs onto corresponding "places"
(defmacro cons-list (objs places)
`(mapcar #'cons ,objs ,places))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DIRECTORIES, FILENAMES, IMPLEMENTATION/PLATFORM SPECIFIC THINGS
;; wrapper for namestring function, accepts a NIL filname
(declaim (inline namestring*))
(defun namestring* (filename) (when filename (namestring filename)))
;; special function for Allegro to run external command (uses older function for compatibility--might have to be updated at some point)
#+allegro
(defun run-allegro-cmd (cmd &optional (wait t) (hide t))
(ignore-errors
(multiple-value-bind (ostr istr p) (excl:run-shell-command
#-(or mswindows win32) cmd
#+(or mswindows win32) (if (typep cmd 'string) cmd
(conc-stringlist (loop for e across cmd and i = nil then t when i collect e and collect " ")))
:input :stream :output :stream :error-output :stream :wait nil :show-window (if hide :hide :normal))
(declare (ignore istr))
(values (if wait (sys:os-wait nil p) 0) ostr))))
;; wrappers for probe-file and directory ignoring errors
(declaim (inline probe-file* directory*))
(defun probe-file* (fn) (ignore-errors (probe-file fn)))
(defun directory* (di &rest re) (ignore-errors (apply #'directory #+clisp (conc-strings di "/") #-clisp di re)))
;; looks for executable in likely places depending on operating system
;; returns a full pathname if found
(defun find-exe (filename &optional subdir)
(declare (ignorable subdir))
(namestring*
(or #+(or linux (or darwin macos) unix cygwin) (probe-file* (change-filename filename :dir "/usr/local/bin"))
#+(or linux (or darwin macos) unix cygwin) (probe-file* (change-filename filename :dir "/usr/bin"))
#+(or linux (or darwin macos) unix cygwin) (probe-file* (change-filename filename :dir "/bin"))
#+(or linux (or darwin macos) unix cygwin) (probe-file* (change-filename filename :dir "/usr/X11R6/bin"))
#+(or darwin macos) (probe-file* (change-filename filename :dir "/sw/bin"))
#+(or darwin macos) (probe-file* (change-filename filename :dir "/Applications"))
#+(or darwin macos)
(when subdir (find-if #'probe-file* (mapcar (lambda (x) (change-filename filename :dir (namestring x)))
(directory* (format nil "/Applications/~A" subdir) #+openmcl :directories #+openmcl t))))
#+(or darwin macos)
(when subdir (find-if #'probe-file* (mapcar (lambda (x) (change-filename filename :dir (namestring x)))
(directory* (format nil "/Applications/~A/*" subdir) #+openmcl :directories #+openmcl t))))
#+(or darwin macos)
(when subdir (find-if #'probe-file* (mapcar (lambda (x) (change-filename filename :dir (namestring x)))
(directory* (format nil "/Applications/~A/*/*" subdir) #+openmcl :directories #+openmcl t))))
#+(or darwin macos)
(when subdir (find-if #'probe-file* (mapcar (lambda (x) (change-filename filename :dir (namestring x)))
(directory* (format nil "/Applications/~A/*/*/*" subdir) #+openmcl :directories #+openmcl t))))
#+(or mswindows win32) (probe-file* (change-filename filename :dir "/Program Files"))
#+(or mswindows win32)
(when subdir (find-if #'probe-file* (mapcar (lambda (x) (change-filename filename :dir (namestring x)))
(directory* (format nil "/Program Files/~A" subdir) #+openmcl :directories #+openmcl t))))
#+(or mswindows win32)
(when subdir (find-if #'probe-file* (mapcar (lambda (x) (change-filename filename :dir (namestring x)))
(directory* (format nil "/Program Files/~A/*" subdir) #+openmcl :directories #+openmcl t))))
#+(or mswindows win32)
(when subdir (find-if #'probe-file* (mapcar (lambda (x) (change-filename filename :dir (namestring x)))
(directory* (format nil "/Program Files/~A/*/*" subdir) #+openmcl :directories #+openmcl t))))
#+(or mswindows win32)
(when subdir (find-if #'probe-file* (mapcar (lambda (x) (change-filename filename :dir (namestring x)))
(directory* (format nil "/Program Files/~A/*/*/*" subdir) #+openmcl :directories #+openmcl t))))
#+(or mswindows win32 cygwin) (probe-file* (change-filename filename :dir "/cygdrive/c/Program Files"))
#+(or mswindows win32 cygwin)
(when subdir (find-if #'probe-file* (mapcar (lambda (x) (change-filename filename :dir (namestring x)))
(directory* (format nil "/cygdrive/c/Program Files/~A" subdir) #+openmcl :directories #+openmcl t))))
#+(or mswindows win32 cygwin)
(when subdir (find-if #'probe-file* (mapcar (lambda (x) (change-filename filename :dir (namestring x)))
(directory* (format nil "/cygdrive/c/Program Files/~A/*" subdir) #+openmcl :directories #+openmcl t))))
#+(or mswindows win32 cygwin)
(when subdir (find-if #'probe-file* (mapcar (lambda (x) (change-filename filename :dir (namestring x)))
(directory* (format nil "/cygdrive/c/Program Files/~A/*/*" subdir) #+openmcl :directories #+openmcl t))))
#+(or mswindows win32 cygwin)
(when subdir (find-if #'probe-file* (mapcar (lambda (x) (change-filename filename :dir (namestring x)))
(directory* (format nil "/cygdrive/c/Program Files/~A/*/*/*" subdir) #+openmcl :directories #+openmcl t))))
#+(or mswindows win32) (probe-file* (change-filename filename :dir "/cygwin/usr/local/bin"))
#+(or mswindows win32) (probe-file* (change-filename filename :dir "/cygwin/usr/bin"))
#+(or mswindows win32) (probe-file* (change-filename filename :dir "/cygwin/bin"))
#+(or mswindows win32) (probe-file* (change-filename filename :dir "/cygwin/usr/X11R6/bin")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HEAP
;; the following functions implement a heap
(defstruct (heap (:constructor make-heap-aux) (:predicate heapp))
(fun #'+ :type (function (t t) t))
(arr #() :type (array t)))
(defun percdown (hp n)
(declare (type heap hp) (type (integer 0) n))
(let ((c1 (+ (ash n 1) 1))
(c2 (+ (ash n 1) 2)))
(let ((s (fill-pointer (heap-arr hp))))
(if (< c2 s)
(let ((an (aref (heap-arr hp) n))
(ac1 (aref (heap-arr hp) c1))
(ac2 (aref (heap-arr hp) c2)))
(if (or (funcall (heap-fun hp) ac1 an)
(funcall (heap-fun hp) ac2 an))
(if (funcall (heap-fun hp) ac1 ac2)
(progn (psetf (aref (heap-arr hp) c1) (aref (heap-arr hp) n) (aref (heap-arr hp) n) (aref (heap-arr hp) c1))
(percdown hp c1))
(progn (psetf (aref (heap-arr hp) c2) (aref (heap-arr hp) n) (aref (heap-arr hp) n) (aref (heap-arr hp) c2))
(percdown hp c2)))))
(if (< c1 s)
(if (funcall (heap-fun hp) (aref (heap-arr hp) c1) (aref (heap-arr hp) n))
(progn (psetf (aref (heap-arr hp) c1) (aref (heap-arr hp) n) (aref (heap-arr hp) n) (aref (heap-arr hp) c1))
(percdown hp c1))))))))
(defun percup (hp n)
(declare (type heap hp) (type (integer 0) n))
(if (> n 0)
(let ((p (ash (- n (if (oddp n) 1 2)) -1)))
(if (funcall (heap-fun hp) (aref (heap-arr hp) n) (aref (heap-arr hp) p))
(progn (psetf (aref (heap-arr hp) n) (aref (heap-arr hp) p) (aref (heap-arr hp) p) (aref (heap-arr hp) n))
(percup hp p))))))
(defun heap-ins (obj heap)
(declare (type heap heap))
(percup heap (vector-push-extend obj (heap-arr heap)))
obj)
(defun heap-rem (heap)
(declare (type heap heap))
(if (> (fill-pointer (heap-arr heap)) 0)
(let ((r (aref (heap-arr heap) 0)))
(setf (aref (heap-arr heap) 0) (aref (heap-arr heap) (decf (fill-pointer (heap-arr heap)))))
(percdown heap 0)
r)))
(declaim (inline heap-peek heap-size heap-empty-p heap-clear))
(defun heap-peek (heap)
(declare (type heap heap))
(if (> (fill-pointer (heap-arr heap)) 0) (aref (heap-arr heap) 0)))
(defun heap-size (heap)
(declare (type heap heap))
(fill-pointer (heap-arr heap)))
(defun heap-empty-p (heap)
(declare (type heap heap))
(= (fill-pointer (heap-arr heap)) 0))
(defun heap-clear (heap)
(declare (type heap heap))
(setf (fill-pointer (heap-arr heap)) 0)
heap)
(defun make-heap (fun &key initial-contents initial-size)
(declare (type (function (t t) t) fun) (type list initial-contents) (type (or (integer 0) null) initial-size))
(let ((hp (make-heap-aux :fun fun :arr (make-array (if initial-size (max (length initial-contents) initial-size) (length initial-contents)) :adjustable t :fill-pointer 0))))
(loop for e in initial-contents do (heap-ins e hp))
hp))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MORE GENERAL
;; tests for list of length > 1
;; list = a list
(declaim (inline list>1p list1p))
(defun list>1p (list)
(declare (type list list))
(cdr list))
;; tests for list of length = 1
(defun list1p (list)
(declare (type list list))
(and list (null (cdr list))))
;; utility functions for various operations over a list of numbers
(declaim (inline or-list and-list min-list max-list))
(defun or-list (list)
(declare (type list list))
(loop for e in list thereis e)) ; if list = nil, returns nil
(defun and-list (list)
(declare (type list list))
(loop for e in list always e)) ; if list = nil, returns t
(defun min-list (list)
(declare (type list list))
(when list (mloop for e of-type real in list minimize e)))
(defun max-list (list)
(declare (type list list))
(when list (mloop for e of-type real in list maximize e)))
(defun ave-list (nums)
(declare (type list nums))
(loop for e of-type real in nums and n from 1 sum e into s finally (return (/ s n))))
;; utility math functions
(declaim (inline roundint diff roundto))
(defun diff (a b)
(declare (type real a b))
(abs (- a b)))
(defun roundint (i)
(declare (type real i))
(nth-value 0 (truncate (if (< i 0) (- i 1/2) (+ i 1/2)))))
;; round to given precision value
(defun roundto (i prec)
(declare (type real i prec))
(* (roundint (/ i prec)) prec))
;; nconcs obj and place and sets place to the result (modifies both obj and place)
(defmacro prenconc (obj place)
`(setf ,place (nconc ,obj ,place)))
;; appends obj and place and sets place to the result (just modifies place)
(defmacro prepend (obj place)
`(setf ,place (append ,obj ,place)))
;; performs prepend over a list of objs and list of places, setting places to the returned list
(defmacro prepend-lists (objs places)
`(setf ,places (mapcar #'append ,objs ,places)))
;; split list into groups (results are unsorted)
;; key = function that returns a group id for each element
;; test = group id equality test
;; returns: list of lists (each inner list is a group)
(defun split-into-groups (list key &key (test 'eql)) ; groupfun should return objects unique to ea. group
(declare (type list list) (type (function (t) t) key) (type symbol test))
(let ((h (make-hash-table :test test)))
(loop for e in list do
(let ((k (funcall key e)))
(setf (gethash k h) (cons e (gethash k h)))))
(loop for e being each hash-value in h collect e)))
;; split a list into several lists given one or more test functions
;; funs = 1 or more predicate functions that return t if list item belongs in list 1, list 2, etc..
;; returns: (number of funs + 1) lists returned as separate values (last value represents list of no matches)
(defun split-list (list &rest funs)
(declare (type list list))
(loop
with r = (loop repeat (1+ (length funs)) collect (cons nil nil))
with re = (copy-list r)
for e in list
do (loop for a on r for f in funs
when (funcall f e) do (setf (car a) (setf (cdar a) (list e))) (return)
finally (setf (car a) (setf (cdar a) (list e))))
finally (return (values-list (mapcar #'rest re)))))
;; splits a list into several lists according to vals
;; vals = list of values to compare list items to and sort against
;; key = function to get comparison val from list item
;; test = test function to compare key val again vals list
;; returns: list of lists grouped according to vals
(defun split-list* (list vals &key (key #'identity) (test #'eql))
(declare (type list list vals) (type (function (t) t) key) (type (function (t t) t) test))
(loop
with r = (loop repeat (1+ (length vals)) collect (cons nil nil))
with re = (copy-list r)
for e in list
do (loop with k = (funcall key e)
for a on r for v in vals
when (funcall test k v) do (setf (car a) (setf (cdar a) (list e))) (return)
finally (setf (car a) (setf (cdar a) (list e))))
finally (return (mapcar #'rest re))))
;; some loop macros for finding argmaxes and mins
(defmacro loop-return-firstmin (form for var &rest loop)
(let ((mx (gensym)) (ev (gensym)) (rt (gensym)))
`(loop with ,mx and ,ev and ,rt
,for ,var ,@loop
do (setq ,ev ,form)
until (and ,mx (> ,ev ,mx))
when (or (null ,mx) (< ,ev ,mx))
do (setq ,mx ,ev ,rt ,var)
finally (return ,rt))))
(defmacro loop-return-lastmin (form for var &rest loop)
(let ((mx (gensym)) (ev (gensym)) (rt (gensym)))
`(loop with ,mx and ,ev and ,rt
,for ,var ,@loop
do (setq ,ev ,form)
until (and ,mx (> ,ev ,mx))
when (or (null ,mx) (<= ,ev ,mx))
do (setq ,mx ,ev ,rt ,var)
finally (return ,rt))))
(defmacro loop-return-argmax (form for var &rest loop) ; if several argmaxes are =, return first one
(let ((mx (gensym)) (ev (gensym)) (rt (gensym)))
`(loop with ,mx and ,ev and ,rt
,for ,var ,@loop
do (setq ,ev ,form) ; ev = arg eval
when (or (null ,mx) (> ,ev ,mx))
do (setq ,mx ,ev ,rt ,var)
finally (return ,rt))))
(defmacro loop-return-argmin (form for var &rest loop)
(let ((mx (gensym)) (ev (gensym)) (rt (gensym)))
`(loop with ,mx and ,ev and ,rt
,for ,var ,@loop
do (setq ,ev ,form) ; ev = arg eval
when (or (null ,mx) (< ,ev ,mx))
do (setq ,mx ,ev ,rt ,var)
finally (return ,rt))))
(defmacro loop-return-argmins (form for var &rest loop)
(let ((mx (gensym)) (ev (gensym)) (rt (gensym)))
`(loop with ,mx and ,ev and ,rt
,for ,var ,@loop
do (setq ,ev ,form) ; ev = arg eval
when (or (null ,mx) (< ,ev ,mx))
do (setq ,mx ,ev ,rt (list ,var))
else when (= ,ev ,mx)
do (push ,var ,rt)
finally (return ,rt))))
;; does an assoc on a list and returns the cdr of the found item
#-cmu (declaim (inline lookup))
(defun lookup (item list &rest keys)
(declare (type list list))
(cdr (apply #'assoc item list keys)))
;; merges consecutive items in a list into single items, depending on return value of fun
;; fun = function accepting two consecutive items, returning a merged item or nil if they aren't to be merged
;; returns: the new list
(defun merge-linear (list fun)
(declare (type list list) (type (function (t t) t) fun))
(if (cdr list)
(loop
with e1 = (first list)
for (e2 . re) on (rest list)
for m = (funcall fun e1 e2)
if m do (setf e1 m)
else collect e1 into r and do (setf e1 e2)
unless re collect e1 into r and do (return r))
list))
;; (defun merge-linear (list fun)
;; (declare (type list list) (type (function (t t) t) fun))
;; (when list
;; (loop
;; with e1 = (first list)
;; #-clisp while #-clisp list
;; for e2 in #-clisp (rest list) #+clisp (when list (rest list))
;; for m = (funcall fun e1 e2)
;; if m do (setf e1 m)
;; else collect e1 into r and do (setf e1 e2)
;; finally (return (nconc r (list e1))))))
;; merges all items in a list into single items, depending on return value of fun
;; fun = function accepting two items, returning a merged item or nil if they aren't to be merged
;; call-rev = t if fun is also to be called with items in reverse order (up to two calls are made with the same two items)
;; returns: the new list
(defun merge-all (list fun &key (call-rev t))
(declare (type list list) (type (function (t t) t) fun) (type boolean call-rev))
(if (rest list)
(loop
with x = (mapcar #'list list) with l of-type cons = (last-element x) and c of-type cons = (first x)
while (and (not (eq c l)) (rest x)) do
(setf x (loop for (e . er) of-type (cons . list) on (rest x)
for m = (if call-rev (or (funcall fun (car c) (car e)) (funcall fun (car e) (car c)))
(funcall fun (car c) (car e)))
if m do (let ((ms (list m))) (setf c ms l ms)) else collect e into rt
when (or (not er) (eq e l)) nconc er into rt and collect c into rt and do (return rt)))
(setf c (first x)) ; c = object being combined
finally (return (mapcar #'car x)))
list))
;; (defun merge-all (list fun &key (call-rev t))
;; (declare (type list list) (type (function (t t) t) fun) (type boolean call-rev))
;; (when list
;; (loop
;; with x = (copy-list list) with l = (last-element x)
;; until (eq (first x) l)
;; do (let* ((y (first x))
;; (z (delete-if (lambda (e)
;; (let ((s (if call-rev (or (funcall fun y e) (funcall fun e y))
;; (funcall fun y e))))
;; (when s (setf y s l s))))
;; (rest x))))
;; (setf x (nconc z (list y))))
;; finally (return x))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PROGRESS PRINTING
;; print a string if a certain amount of time has elapsed (set by track-progress function)
(declaim (type (integer 0) *print-prog-time* *print-prog-secs*))
(declaim (special *print-prog-time* *print-prog-secs*))
(defun progress (string)
(declare (type string string))
(when (>= (get-internal-run-time) *print-prog-time*)
(when (> *verbose* 0)
(format t string)
(finish-output))
(setf *print-prog-time* (+ (get-internal-run-time) (* *print-prog-secs* internal-time-units-per-second)))))
;; initialize progress printer
;; secs = seconds between each printing progress
(defmacro track-progress (secs &body forms)
`(let ((*print-prog-time* (+ (get-internal-run-time) (* ,secs internal-time-units-per-second)))
(*print-prog-secs* ,secs))
,@forms))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SEARCH ENGINE
;; the following implement a BFS algorithm with an optional limited heap
(declaim (type (integer -1) *a*-id*))
(declaim (special *a*-id*))
(defstruct (a*-node (:copier nil) (:predicate nil))
(id (incf *a*-id*) :type (integer 0) :read-only t)
data score (val t :type boolean)) ; val = valid
;; init-nodes = list of initial search nodes
;; scorefun = function that returns a score value when passed a node
;; expandfun = function that returns list of child nodes when passed a parent node
;; solutfun = functino that returns t if solution is found
;; heaplim = number of highest-scoring nodes to keep track of (or nil if no limit is desired)
;; scoregreaterfun = comparison function for scores (ex. set to #'< if lowest score if best)
;; remscoregreaterfun = comparison function for scores used when removing lowest ones from heap
;; retdefault = return value if no init-nodes are provided (if engine can't return anything)
;; returns: the best node!
(defun bfs*-engine (init-nodes scorefun expandfun solutfun &key heaplim (scoregreaterfun #'>) (remscoregreaterfun #'<) retdefault)
(declare (type (function (t) t) scorefun solutfun) (type (function (t) list) expandfun)
(type (or null (integer 0)) heaplim) (type (function (t t) t) scoregreaterfun remscoregreaterfun))
(let ((*a*-id* -1)
(hs (length init-nodes)))
(declare (type (integer 0) hs))
(flet ((pp (h) (loop for n = (heap-rem h) always n until (a*-node-val n)
finally (decf hs) (setf (a*-node-val n) nil) (return n))))
(let ((ic (mapcar (lambda (e) (make-a*-node :data e :score (funcall scorefun e))) init-nodes)))
(let ((h (make-heap (lambda (x y)
(or (funcall scoregreaterfun (a*-node-score x) (a*-node-score y))
(unless (funcall scoregreaterfun (a*-node-score y) (a*-node-score x))
(< (a*-node-id x) (a*-node-id y)))))
:initial-contents ic :initial-size (* heaplim 2)))
(rh (when heaplim (make-heap (lambda (x y)
(or (funcall remscoregreaterfun (a*-node-score x) (a*-node-score y))
(unless (funcall remscoregreaterfun (a*-node-score y) (a*-node-score x))
(> (a*-node-id x) (a*-node-id y)))))
:initial-contents ic :initial-size (* heaplim 2)))))
(loop
for n = (pp h)
unless n do (return retdefault)
do (if (funcall solutfun (a*-node-data n))
(return (a*-node-data n))
;;(if (<= hs 0) (return (a*-node-data n)) (ii n))
(mapcar (lambda (e)
(if heaplim
(let ((o (make-a*-node :data e :score (funcall scorefun e))))
(heap-ins o h) (heap-ins o rh))
(heap-ins (make-a*-node :data e :score (funcall scorefun e)) h))
(incf hs))
(funcall expandfun (a*-node-data n))))
when heaplim do (loop while (> hs heaplim) do (pp rh))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TYPE CHECKING
;; slightly more complicated type checking that checks for unique values, values within structs and classes, keyword-argument pairs,
;; allows things to be wrapped into let statements, customizable error strings, etc..
;; if satisfies could pass arguments, this could all just be implemented with deftypes
(defun check-type* (obj type &optional er un lt)
(declare (type (or null string) er) (type list un lt))
(flet ((get-error (x)
(apply #'format nil (typecase (first x) (symbol (symbol-value (first x))) (otherwise (first x)))
(mapcar (lambda (z)
(if (truep z) obj
(cond ((functionp z) (funcall z obj))
((and (listp z) (eq (first z) 'function)) (funcall (second z) obj))
(t z))))
(rest x)))))
(typecase type
(cons (let ((ty (mapcar (lambda (x) (let ((z (find x lt :key #'car))) (if z (cdr z) x))) (rest type))))
(destructuring-bind (&optional fi se th &rest xxx) ty
(declare (ignore xxx))
(case (first type)
(cons* (and (consp obj) (check-type* (car obj) fi er un lt) (check-type* (cdr obj) se er un lt)))
(cons-of* (and (consp obj) (check-type* (car obj) fi er un lt) (check-type* (cdr obj) fi er un lt)))
(list* (and (consp obj) (= (length obj) (length ty)) (loop for o in obj and y in ty always (check-type* o y er un lt))))
(list-of* (and (consp obj) (loop for o in obj always (check-type* o fi er un lt))))
(list-of-unique* (and (listp obj)
(loop for o2 on obj for o1 = (car o2) never (find o1 (rest o2) :test #'equal))
(loop for o in obj always (check-type* o fi er un lt))))
(vector* (and (vectorp obj) (= (length obj) (length ty)) (loop for i from 0 below (length obj) and y in ty always (check-type* (svref obj i) y er un lt))))
(vector-of* (and (vectorp obj) (loop for i from 0 below (length obj) always (check-type* (svref obj i) fi er un lt))))
(array-of* (and (arrayp obj) (loop for i from 0 below (array-total-size obj) always (check-type* (row-major-aref obj i) fi er un lt))))
(struct* (and (typep obj fi) (loop for (s y) in (rest ty) always (check-type* (funcall s obj) y er un lt))))
(class* (and (typep obj fi) (loop for (s y) in (rest ty) always (check-type* (slot-value obj s) y er un lt))))
(key-arg-pairs* (and (listp obj) (evenp (length obj)) (loop for k in obj by #'cddr always (and (keywordp k) (find k ty)))))
(type* (check-type* obj (symbol-value fi) er un lt))
(check* (if (check-type* obj fi er un lt) t
(let ((x (get-error (rest ty)))) (if er (error er x) (error x)))))
(or* (loop for y in ty for cp = (mapcar (lambda (u) (cons (car u) (cdr u))) un) for re = (check-type* obj y er cp lt) until re
finally (when re (mapcar (lambda (u c) (setf (cdr u) (cdr c))) un cp) (return t))))
(and* (loop for y in ty for cp = (mapcar (lambda (u) (cons (car u) (cdr u))) un) for re = (check-type* obj y er cp lt) while re
finally (when re (mapcar (lambda (u c) (setf (cdr u) (cdr c))) un cp) (return t))))
(length* (funcall fi (length obj) se))
(with-unique* (check-type* obj se er (nconc (mapcar #'list fi) un) lt))
(unique* (let ((x (assoc fi un))
(o (if th se obj)))
(unless (find o (cdr x) :test #'equal)
(push o (cdr x))
(check-type* obj (or th se) er un lt))))
(let* (mapcar (lambda (x) (push (cons (first x) (second x)) lt)) fi) (check-type* obj se er un lt))
(error* (let ((x (get-error ty))) (if er (error er x) (error x))))
(with-error* (if (or (stringp (first fi)) (check-type* obj (first fi) er un lt))
(let ((x (get-error (if (stringp (car fi)) fi (rest fi)))))
(check-type* obj se (if er (format nil er x) x) un lt))
(check-type* obj se er un lt)))
(if* (if (check-type* obj fi er un lt) (check-type* obj se er un lt) (check-type* obj th er un lt)))
(when* (if (funcall fi obj) (check-type* obj se er un lt) t))
(unless* (if (funcall fi obj) t (check-type* obj se er un lt)))
(otherwise (typep obj type))))))
(symbol (case type
(key-arg-pairs* (and (listp obj) (evenp (length obj)) (loop for k in obj by #'cddr always (keywordp k))))
(otherwise (typep obj type))))
(function (funcall type obj))
(otherwise (typep obj type)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MORE GENERAL
;; removes newlines and double spaces from a string
(defun remove-newlines (str &optional (and2xs t))
(declare (type string str))
(loop with c = 0
for p = #\space then x
for x0 across str
for x = (if (char= x0 #\newline) #\space x0)
unless (and and2xs (char= p #\space) (char= x #\space))
collect x into r and do (incf c)
finally (return (make-array c :element-type 'character :initial-contents r))))
;; the return string needs to be run through FORMAT
(defun commentify (str in)
(declare (type string str) (type (integer 1) in))
(loop with in = (format nil "~%~A " (make-string in :initial-element #\;))
and sr = (string-trim '(#\newline) str)
for p = (position #\newline sr :start (if p (1+ p) 0))
while p do (setf sr (conc-strings (subseq sr 0 p) in (subseq sr (1+ p))))
finally (return sr)))
;; cartesian distance
(declaim (inline distance))
(defun distance (x y)
(declare (type real x y))
(sqrt (+ (* x x) (* y y))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; pathname compatibility - deliberately borrowed from cl-fad
;; SAVE THIS (don't need at the moment, the directory function causes silly errors in some Lisps)
;; (declaim (inline component-present-p #|directory-pathname-p|#))
;; (defun component-present-p (value)
;; "Helper function for DIRECTORY-PATHNAME-P which checks whether VALUE
;; is neither NIL nor the keyword :UNSPECIFIC."
;; (and value (not (eql value :unspecific))))
;; (defun directory-pathname-p (pathspec)
;; "Returns NIL if PATHSPEC \(a pathname designator) does not designate
;; a directory, PATHSPEC otherwise. It is irrelevant whether file or
;; directory designated by PATHSPEC does actually exist."
;; (and
;; (not (component-present-p (pathname-name pathspec)))
;; (not (component-present-p (pathname-type pathspec)))
;; pathspec))
;; ;; pathspec/dirname won't have wildcards in it
;; (defun pathname-as-directory (pathspec)
;; "Converts the non-wild pathname designator PATHSPEC to directory
;; form."
;; (let ((pathname (pathname pathspec)))
;; (when (wild-pathname-p pathname)
;; (error "Can't reliably convert wild pathnames."))
;; (cond ((not (directory-pathname-p pathspec))
;; (make-pathname :directory (append (or (pathname-directory pathname)
;; (list :relative))
;; (list (file-namestring pathname)))
;; :name nil
;; :type nil
;; :defaults pathname))
;; (t pathname))))
;; (defun directory-wildcard (dirname)
;; "Returns a wild pathname designator that designates all files within
;; the directory named by the non-wild pathname designator DIRNAME."
;; (when (wild-pathname-p dirname)
;; (error "Can only make wildcard directories from non-wildcard directories."))
;; (make-pathname :name #-:cormanlisp :wild #+:cormanlisp "*"
;; :type #-(or :clisp :cormanlisp) :wild
;; #+:clisp nil
;; #+:cormanlisp "*"
;; :defaults (pathname-as-directory dirname)))