You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
273 lines
7.8 KiB
273 lines
7.8 KiB
;;;; utils.lisp -- some random utils I collect. might be useful, probably won't be.
|
|
|
|
(if (boundp '*-utils-lisp*) "Already loaded" (progn
|
|
|
|
;;; --- internally maintained config, don't put anything above these!!
|
|
|
|
(defparameter *-utils-lisp* t)
|
|
(defparameter *-utils-depends* '(#:cl-ppcre))
|
|
|
|
(defparameter *-utils-version* "0.1.4")
|
|
|
|
;;; -- Handle internal exporting --
|
|
|
|
(defmacro insystem? (thing &optional (else nil))
|
|
`(if (boundp '*-utils-system*)
|
|
,thing
|
|
,else))
|
|
|
|
(defmacro export? (val)
|
|
`(if (boundp '*-utils-system*)
|
|
(export ',val)
|
|
nil))
|
|
|
|
(defmacro export* (&rest syms)
|
|
`(mapc #'export '(,@syms)))
|
|
|
|
(defmacro eval-all (syms)
|
|
`(mapcar #'eval '(,@syms)))
|
|
(export? eval-all)
|
|
|
|
(defmacro export*! (&rest syms)
|
|
`(mapc #'export (eval-all ,syms)))
|
|
|
|
(export? export*)
|
|
(export? export*!)
|
|
|
|
(defmacro export*? (&rest val)
|
|
`(insystem? (export*! ,@val)
|
|
(mapc #'eval '(,@val))))
|
|
|
|
(defun file-get-contents (filename)
|
|
(with-open-file (stream filename)
|
|
(let ((contents (make-string (file-length stream))))
|
|
(read-sequence contents stream)
|
|
contents)))
|
|
(export? file-get-contents)
|
|
|
|
;(export? val-if-or)
|
|
|
|
(defun utils->system (input output &key (name :flan-utils) (description "Some random utilities") (author "Ringo <flanchan@cumallover.me>") (license "None"))
|
|
"Write this file to an ASDF system."
|
|
(let ((this (cadddr (read-from-string (file-get-contents input))))
|
|
(sysdef `(asdf:defsystem ,name
|
|
:description ,description
|
|
:author ,author
|
|
:license ,license
|
|
:version ,*-utils-version*
|
|
:serial t
|
|
:depends-on ,*-utils-depends*
|
|
:components ((:file ,(car (last (cl-ppcre:split "/" output))))))))
|
|
(rplaca this `(defpackage ,name (:use #:cl)))
|
|
(rplaca (cdr this) `(in-package ,name))
|
|
(rplaca (cddr this) '(defparameter *-utils-system* t))
|
|
(with-open-file (output-lisp (concatenate 'string output ".lisp") :direction :output :if-exists :supersede)
|
|
(with-open-file (output-asd (concatenate 'string output ".asd") :direction :output :if-exists :supersede)
|
|
(mapc #'(lambda (stmt) (write stmt :stream output-lisp)) this)
|
|
(write sysdef :stream output-asd :case :downcase )))))
|
|
|
|
(defun utils->create-for (utils for &key (name 'flan-utils) (package nil) ) ;;; TODO: Make this work for structs
|
|
"Export `utils' functions used in file into own file"
|
|
(let ((this (cadddr (read-from-string (file-get-contents utils))))
|
|
(for (read-from-string (file-get-contents for))))
|
|
(labels ((sieve (li) ;; find all `,name:' functions in list
|
|
(mapcan #'(lambda (part)
|
|
(if (atom part)
|
|
(if (cl-ppcre:scan (concatenate 'string "^" (write-to-string name) ":")
|
|
(write-to-string part))
|
|
(list part)
|
|
nil)
|
|
(sieve part)))
|
|
li)))
|
|
(let ((syms (sieve for))
|
|
(allowed-definitions '(defun
|
|
defmacro
|
|
defparameter))) ;;;; STRUCT
|
|
(labels ((find-func (sym-name l) ;;; TODO: here
|
|
(mapcan #'(lambda (part)
|
|
(when (not (atom part))
|
|
(if (eql (cadr part) sym-name) ;; symbol found
|
|
(list part)
|
|
(when (eql (car part) 'export*?) ;; export*?
|
|
(find-func sym-name part)))))
|
|
l)))
|
|
(let ((defs (mapcan #'(lambda (sym)
|
|
(find-func (read-from-string (cadr (cl-ppcre:split (concatenate 'string "^" (write-to-string name) ":") (write-to-string sym)))) this))
|
|
syms)))
|
|
(mapcan #'(lambda (def)
|
|
(when (member (car def) allowed-definitions)))
|
|
defs)))))))
|
|
(export*?
|
|
|
|
;;; --- actual (exported) code goes here ---
|
|
|
|
(defmacro val-if-or (val test or)
|
|
`(let ((vv ,val))
|
|
(if (funcall ,test vv) vv ,or)))
|
|
|
|
(defun where (expr items)
|
|
(mapcan #'(lambda (x)
|
|
(when (funcall expr x) (list x)))
|
|
items))
|
|
|
|
(defun true (f)
|
|
(not (null f)))
|
|
|
|
(defun nop ()
|
|
nil)
|
|
|
|
(defun yep ()
|
|
t)
|
|
|
|
(defun mapline (input fi &key (read-line #'read-line))
|
|
"Map lines from stream"
|
|
(loop for line = (funcall read-line input nil)
|
|
while line do (funcall fi line)))
|
|
|
|
(defun strcat (&rest str)
|
|
(apply #'concatenate (cons 'string str)))
|
|
|
|
(defmacro until (stmt)
|
|
`(let ((ret nil))
|
|
(loop while (null (setf ret ,stmt)))
|
|
ret))
|
|
|
|
(defmacro until-trace (stmt)
|
|
`(let ((ret nil))
|
|
(loop while (null (setf ret ,stmt))
|
|
collect ret)))
|
|
|
|
(defmacro popor (li or)
|
|
`(if (atom ,li) ,or
|
|
(pop ,li)))
|
|
|
|
(defun rand-in (l &key (random #'random) )
|
|
"Random member of, slide right if nil"
|
|
(let ((rng (funcall random (list-length l))))
|
|
(let ((nl (nthcdr rng l)))
|
|
(until (pop nl)))))
|
|
|
|
(defun regex-replace-many (str matches replwith)
|
|
"Replace list of regexes with list of new string"
|
|
(let ((ret str))
|
|
(loop for match in matches
|
|
for repl in replwith
|
|
do (setf ret (cl-ppcre:regex-replace-all match ret repl)))))
|
|
|
|
(defun in-range(num r s)
|
|
(and (>= num r)
|
|
(<= num s)))
|
|
|
|
(defun format-string (fmt &rest r)
|
|
(with-output-to-string (stream)
|
|
(apply #'format `(,stream ,fmt . ,r))))
|
|
|
|
|
|
(defun get-all-symbols ()
|
|
(let ((lst '()))
|
|
(do-all-symbols (s lst)
|
|
(push s lst))
|
|
lst))
|
|
|
|
(defun symbol-match (scan &optional (symbols nil))
|
|
(let ((symbols (val-if-or symbols #'true
|
|
(get-all-symbols))))
|
|
(where #'(lambda (x) (cl-ppcre:scan scan (write-to-string x)))
|
|
symbols)))
|
|
|
|
(defun index (i max)
|
|
(if (< i 0)
|
|
(index (+ max i) max)
|
|
(mod i max)))
|
|
|
|
(defun slice (seq start end)
|
|
"only works with lists i guess"
|
|
(let ((start (index start (length seq)))
|
|
(end (index end (length seq))))
|
|
(rplacd (nthcdr end seq) nil)
|
|
(nthcdr start seq)))
|
|
|
|
(defun flatten-top-level (li)
|
|
(mapcan #'(lambda (x)
|
|
(if (atom x) (list x) x))
|
|
li))
|
|
|
|
(defun flatten (li)
|
|
(mapcan #'(lambda (x)
|
|
(if (atom x)
|
|
(list x)
|
|
(flatten x)))
|
|
li))
|
|
|
|
(defun strjoin (delim &rest strs)
|
|
(let ((strs (flatten-top-level strs)))
|
|
(apply #'strcat
|
|
(slice
|
|
(mapcan #'(lambda (x)
|
|
(list x delim))
|
|
strs)
|
|
0 -2))))
|
|
|
|
(defun export-struct (struct &optional (symbols nil))
|
|
(mapc #'export (symbol-match (strcat "^" (write-to-string struct) "-?") symbols)))
|
|
|
|
(defun -export*-struct (structs &optional (symbols nil))
|
|
(mapc #'export (symbol-match
|
|
(strcat
|
|
"^("
|
|
(strjoin "|" (mapcar #'write-to-string structs))
|
|
")-?")
|
|
symbols)))
|
|
|
|
(defmacro export*-struct (&rest structs)
|
|
`(-export*-struct '(,@structs)))
|
|
|
|
(defmacro popto (li val &key (test #'eql))
|
|
"pop() list <li> until (car li) is equal to <val>, return elements pop()ed in new list"
|
|
`(loop while (not (funcall ,test (car ,li) ,val))
|
|
collect (pop ,li)))
|
|
|
|
(defmacro popn (li n)
|
|
"pop() list <li> <n> times, return elements pop()ed in a new list."
|
|
(if (numberp n)
|
|
(list 'let '((tmp 'nil))
|
|
(apply #'list 'progn
|
|
(loop for x from 1 to n
|
|
collect `(setf tmp (cons (pop ,li) tmp))))
|
|
'(reverse tmp))
|
|
`(loop for x from 1 to ,n collect (pop ,li))))
|
|
|
|
(defun make-paged-vector (blocksize &key (element-type 'integer))
|
|
"Vector that increases size in blocks"
|
|
(list (make-array blocksize :element-type element-type :fill-pointer 0 :adjustable t) blocksize 0 1))
|
|
|
|
(defun paged-vector<-size (vec) (caddr vec))
|
|
(defun paged-vector<-blocksize (vec) (cadr vec))
|
|
(defun paged-vector<-blocks (vec) (cadddr vec))
|
|
|
|
(defmacro paged-vector->push (vec elem)
|
|
"add <elem> to end, extending if needed"
|
|
`(if (>= (1+ (mod (paged-vector<-size ,vec) (paged-vector<-blocksize ,vec))) (paged-vector<-blocksize ,vec))
|
|
(progn
|
|
(adjust-array (car ,vec)
|
|
(* (1+ (paged-vector<-blocks ,vec))
|
|
(paged-vector<-blocksize ,vec)))
|
|
(incf (cadddr ,vec))
|
|
(incf (caddr ,vec))
|
|
(vector-push ,elem (car ,vec))
|
|
,vec)
|
|
(progn (incf (caddr ,vec)) (vector-push ,elem (car ,vec)) ,vec)))
|
|
|
|
(defun make-paged-vector-s (elements blocksize)
|
|
"make-paged-vector with default elements"
|
|
(let ((out (make-paged-vector blocksize)))
|
|
(mapc #'(lambda (x) (paged-vector->push out x)) elements) out))
|
|
|
|
(defmacro paged-vector<- (vec) `(car ,vec))
|
|
|
|
) ;; -- end export
|
|
|
|
(mapc #'fmakunbound '(insystem? export? export*?))
|
|
|
|
)) ;; -- end guard
|