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.
541 lines
15 KiB
541 lines
15 KiB
;;;; utils.lisp -- some random utils I collect. might be useful, probably won't be.
|
|
|
|
(defpackage :flan-utils (:use :cl))
|
|
(in-package :flan-utils)
|
|
|
|
(defmacro export* (&rest syms)
|
|
"Export all symbols"
|
|
(cons 'progn (mapcan #'(lambda (x) `((export ',x))) syms)))
|
|
|
|
(defmacro eval-all (syms)
|
|
"Eval all statements, return in list."
|
|
`(mapcar #'eval '(,@syms)))
|
|
(export 'eval-all)
|
|
|
|
(defmacro export*! (&rest syms)
|
|
"Eval all statements export return values"
|
|
`(mapc #'export (eval-all ,syms)))
|
|
|
|
(export 'export*)
|
|
(export 'export*!)
|
|
|
|
|
|
(defmacro defexport (&rest val)
|
|
"Same as export*! for some reason"
|
|
`(export*! ,@val))
|
|
(export 'defexport)
|
|
|
|
(defun file-get-contents (filename)
|
|
"Read file into string"
|
|
(with-open-file (stream filename)
|
|
(let ((contents (make-string (file-length stream))))
|
|
(read-sequence contents stream)
|
|
contents)))
|
|
(export 'file-get-contents)
|
|
|
|
(defparameter *old-readtables* nil)
|
|
|
|
(defexport
|
|
|
|
;;; --- actual (exported) code goes here --
|
|
|
|
(defmacro val-if-or (val test or)
|
|
"(if (test val) val 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 ()
|
|
"Do nothing"
|
|
nil)
|
|
|
|
(defun yep ()
|
|
"Do nothing"
|
|
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)
|
|
"Concat all strings, if item is not string it is written to one."
|
|
(apply #'concatenate (cons 'string (mapcar #'(lambda (x)
|
|
(typecase x
|
|
(string x)
|
|
(character (string x))
|
|
(t (write-to-string x))))
|
|
str))))
|
|
|
|
(defmacro until (stmt)
|
|
"Repeat stmt until its return is not NIL, then return that value."
|
|
`(let ((ret nil))
|
|
(loop while (null (setf ret ,stmt)))
|
|
ret))
|
|
|
|
(defmacro popor (li or)
|
|
"If li is list, pop it, else return or"
|
|
`(if (atom ,li) ,or
|
|
(pop ,li)))
|
|
|
|
(defun rand-in (l &key (random #'random) )
|
|
"Random member of, slide right if nil"
|
|
"Pretty sure this doesn't work"
|
|
(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)
|
|
"Like sprintf I guess"
|
|
(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))
|
|
"Return all symbols whose names match regex `scan'. If symbols are not provided, get them all."
|
|
(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)
|
|
"Looping index"
|
|
(if (< i 0)
|
|
(index (+ max i) max)
|
|
(mod i max)))
|
|
|
|
(defun slice (seq start end)
|
|
"Like JS slice()?"
|
|
(let ((start (index start (length seq)))
|
|
(end (index end (length seq))))
|
|
(rplacd (nthcdr end seq) nil)
|
|
(nthcdr start seq)))
|
|
|
|
(defun flatten-top-level (li)
|
|
"'( (1 2) 3 4 (5 6 7) (8) ((9 10))) -> ( 1 2 3 4 5 6 7 8 (9 10))"
|
|
(mapcan #'(lambda (x)
|
|
(if (atom x) (list x) x))
|
|
li))
|
|
|
|
(defun flatten (li)
|
|
"'( (1 2) 3 4 (5 6 7) (8) ((9 10))) -> ( 1 2 3 4 5 6 7 8 9 10)"
|
|
(mapcan #'(lambda (x)
|
|
(if (atom x)
|
|
(list x)
|
|
(flatten x)))
|
|
li))
|
|
|
|
(defun strjoin (delim &rest strs)
|
|
"Join strings with deliminator"
|
|
(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)) ;;XXX: Exporting make-* does not check for $
|
|
"Export all symbols relating to `struct'"
|
|
(mapc #'export (symbol-match (strcat "^(MAKE-)?" (write-to-string struct) "-?") symbols)))
|
|
|
|
(defun -export*-struct (structs &optional (symbols nil)) ;;XXX
|
|
(mapc #'export (symbol-match
|
|
(strcat
|
|
"^(MAKE-)?("
|
|
(strjoin "|" (mapcar #'write-to-string structs))
|
|
")-?")
|
|
symbols)))
|
|
|
|
(defmacro export*-struct (&rest structs)
|
|
"Export all symbols relating to multiple structs"
|
|
`(-export*-struct '(,@structs)))
|
|
|
|
|
|
(defun mapn (lam &rest lists)
|
|
"Map and return last"
|
|
(let ((ret '()))
|
|
(mapc #'(lambda (x)
|
|
(setf ret (funcall lam x)))
|
|
(flatten-top-level lists))
|
|
ret))
|
|
|
|
(defun cyclic (list)
|
|
"Simple circular list"
|
|
(cdr (rplacd (last list) list)))
|
|
|
|
(defun map1 (lam &rest lists)
|
|
"Map and return first"
|
|
(let ((ret '())
|
|
(change t))
|
|
(mapc #'(lambda (x)
|
|
(if change
|
|
(progn
|
|
(setf ret (funcall lam x))
|
|
(setf change nil))
|
|
(funcall lam x)))
|
|
(flatten-top-level lists))
|
|
ret))
|
|
|
|
(defun mapnth (lam n &rest args)
|
|
"Map and return nth or nil (second value t if match found)"
|
|
(let ((index 0)
|
|
(ret '())
|
|
(match nil))
|
|
(mapc #'(lambda (x)
|
|
(if (= n index)
|
|
(progn (setf ret (funcall lam x)) (setf match t))
|
|
(funcall lam x))
|
|
(incf index))
|
|
(flatten-top-level args))
|
|
(values ret match)))
|
|
|
|
(defun mapv (lam &rest args)
|
|
"Map and return values()"
|
|
(apply #'values
|
|
(mapcar lam (flatten-top-level args))))
|
|
|
|
(defmacro lexical-boundp (lex)
|
|
"XXX: Use (declare (special ...)) instead"
|
|
`(when (ignore-errors ,lex) t))
|
|
|
|
;; --- progressive evals
|
|
|
|
(defmacro progen (&rest things)
|
|
`(mapn #'eval '(,@things)))
|
|
|
|
(defmacro proge1 (&rest things)
|
|
`(map1 #'eval '(,@things)))
|
|
|
|
(defmacro progenth (n &rest things)
|
|
`(mapnth #'eval ,n '(,@things)))
|
|
|
|
(defmacro progev (&rest things)
|
|
`(mapv #'eval '(,@things)))
|
|
|
|
(defmacro progel (&rest things)
|
|
`(mapcar #'eval '(,@things)))
|
|
|
|
(defmacro yield-return (&rest things)
|
|
"Create yield block, returns last of push()ed outputs of yield() (so, last is first etc)"
|
|
`(let ((--yield-vars '())
|
|
(--yield-var nil))
|
|
(declare (special --yield-vars
|
|
--yield-var))
|
|
,@things
|
|
(apply #'values --yield-var)))
|
|
|
|
(defmacro yield (value)
|
|
"Yield return value `value' if in yield-return(...) block."
|
|
`(when (boundp '--yield-vars)
|
|
(setf --yield-var (multiple-value-list ,value))
|
|
(push (car --yield-var) --yield-vars)))
|
|
|
|
(defparameter *yield-global-vars* '())
|
|
|
|
(defmacro yield-return-global (name &rest things)
|
|
"Like yield-return but stores values by key in alist and is accessable outside of current lexenv"
|
|
`(car (yield-return
|
|
(push (cons ,name '()) *yield-global-vars*)
|
|
,@things
|
|
(yield (cdr (assoc ,name *yield-global-vars*)))
|
|
(setf *yield-global-vars* (remove ,name *yield-global-vars* :key #'car :count 1)))))
|
|
|
|
(defmacro yield-global (name value)
|
|
`(when (assoc ,name *yield-global-vars*)
|
|
(push ,value (cdr (assoc ,name *yield-global-vars*)))))
|
|
|
|
;; ---
|
|
|
|
(defmacro push-unique (thing things &key (key nil) (test #'eql))
|
|
"Push if not member"
|
|
`(let ((lex-thing ,thing))
|
|
(if (member lex-thing ,things :key ,key :test ,test)
|
|
(values ,things nil)
|
|
(values (push lex-thing ,things) t))))
|
|
|
|
(defmacro import* (&rest args)
|
|
"Import all symbols"
|
|
(cons 'progn (mapcan #'(lambda (x) `((import ',x))) args)))
|
|
|
|
(defmacro shadowing-import* (&rest args)
|
|
"Import all symbols (shadowing)"
|
|
(cons 'progn (mapcan #'(lambda (x) `((shadowing-import ',x))) args)))
|
|
|
|
(defmacro import*! (&rest args)
|
|
"Map eval then import all returns"
|
|
`(mapc #'import (progel ,args)))
|
|
|
|
(defmacro shadowing-import*! (&rest args)
|
|
"Map eval then import all returns (shadowing)"
|
|
`(mapc #'shadowing-import (progel ,args)))
|
|
|
|
(defmacro import*-from (package &rest args)
|
|
"Import all symbols from package. NOTE: You shouldn't prefix the symbols with the package name"
|
|
(let ((ret (mapcar #'(lambda (x) (read-from-string (strcat (subseq (write-to-string package) 1) ":" (write-to-string x)))) args)))
|
|
`(shadowing-import* @,ret)))
|
|
|
|
;(defun restrain-index (i max)
|
|
;
|
|
; (if nil
|
|
; (if (>= i max) (1- max)
|
|
; (if (< i 0) 0
|
|
; i))
|
|
; i))
|
|
|
|
(defun many-equals (items &key (test #'eql))
|
|
"For some reason equality comparers don't like more than 2 args"
|
|
(let ((comp (car items)))
|
|
(labels ((compare (x to)
|
|
(when (null x) t)
|
|
(when (funcall test (car x) to)
|
|
(compare (cdr x) to))))
|
|
(compare (cdr items) comp))))
|
|
|
|
(defun many-eql (&rest items)
|
|
(many-equals items :test #'eql))
|
|
|
|
; --- async stuff
|
|
|
|
(defstruct async-info
|
|
thread
|
|
handlers
|
|
lock)
|
|
|
|
(defmacro push-handler (name lam)
|
|
"Push new handler to current async-info with name"
|
|
"NOTE: Should only be used inside an async() body."
|
|
`(bt:with-lock-held
|
|
((async-info-lock current-async-info))
|
|
(push (cons ,name ,lam)
|
|
(async-info-handlers current-async-info))))
|
|
|
|
(defmacro async (&rest form)
|
|
"Run form(s) async"
|
|
`(let ((current-async-info (make-async-info)))
|
|
(setf (async-info-handlers current-async-info) nil)
|
|
(setf (async-info-lock current-async-info) (bt:make-lock))
|
|
(setf (async-info-thread current-async-info)
|
|
(bt:make-thread
|
|
#'(lambda ()
|
|
,@form)))
|
|
current-async-info))
|
|
|
|
(defun async-info-handler (async name &key (test 'eql))
|
|
"Get handler from async-info of name"
|
|
(bt:with-lock-held ((async-info-lock async))
|
|
(let ((as (assoc name (async-info-handlers async) :test test )))
|
|
(and as
|
|
(cdr as)))))
|
|
|
|
(defun wait (handle)
|
|
"Wait on async()"
|
|
(if (async-info-p handle)
|
|
(wait (async-info-thread handle))
|
|
(bt:join-thread handle)))
|
|
|
|
(defun async-kill (handle)
|
|
"Kill async()"
|
|
(if (async-info-p handle)
|
|
(async-kill (async-info-thread handle))
|
|
(bt:destroy-thread handle)))
|
|
|
|
(defun async-alive (handle)
|
|
"Is async() alive"
|
|
(if (async-info-p handle)
|
|
(async-alive (async-info-thread handle))
|
|
(bt:thread-alive-p handle)))
|
|
|
|
(defun val (v) v)
|
|
|
|
(defun groupn (n list)
|
|
"Group list into sublists every `n' items."
|
|
(let ((last nil)
|
|
(ret nil))
|
|
(loop for x in list
|
|
for y from 0 below (length list)
|
|
do (if (= 0 (mod y n))
|
|
(push x last)
|
|
(progn
|
|
(push x last)
|
|
(setf ret (cons (reverse last) ret))
|
|
(setf last nil))))
|
|
(reverse ret)))
|
|
|
|
; --- reader macros
|
|
|
|
(defun sexpr-reader (stream char &key (func 'val))
|
|
"Read next token only if S expression, else return as is"
|
|
(if (char= (peek-char t stream t nil t) #\()
|
|
(values (funcall func (read stream t nil t)) t)
|
|
(let ((*readtable* (copy-readtable)))
|
|
(set-macro-character char nil)
|
|
(values (read-from-string (strcat (string char) (write-to-string (read stream t nil t)))) nil))))
|
|
|
|
(defun bang-reader (stream char)
|
|
(declare (ignore char))
|
|
(list (quote not) (read stream t nil t)))
|
|
|
|
(defun read-delimiter (stream char)
|
|
(declare (ignore stream char)))
|
|
|
|
(defun read-next-until (stream char)
|
|
(if (char= (peek-char t stream t nil t) char)
|
|
(progn
|
|
(read-char stream t nil t) nil)
|
|
(read stream t nil t)))
|
|
|
|
(defun export-reader (stream char)
|
|
(declare (ignore char))
|
|
(loop for next = (read-next-until stream #\])
|
|
while next
|
|
collect next into objects
|
|
finally (return `(defexport ,@objects))))
|
|
|
|
(defun top-level-reader (stream char)
|
|
(multiple-value-bind (thing okay) (sexpr-reader stream char)
|
|
(if okay
|
|
(append (list 'eval-when '(:compile-toplevel :load-toplevel :execute)) (list thing))
|
|
thing)))
|
|
|
|
(defun async-reader (stream char)
|
|
(multiple-value-bind (thing okay) (sexpr-reader stream char)
|
|
(if okay
|
|
(cons 'async (list thing))
|
|
thing)))
|
|
|
|
(defun lambda-reader (stream char)
|
|
(declare (ignore char))
|
|
`(lambda () ,(read stream t nil t)))
|
|
|
|
(defmacro enable-all-readers ()
|
|
"Turn on reader macros"
|
|
'(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(push *readtable* *old-readtables*)
|
|
(setq *readtable* (copy-readtable))
|
|
|
|
(set-macro-character #\[ 'export-reader) ;"Exports all in brackets []"
|
|
(set-macro-character #\] 'read-delimiter)
|
|
(set-macro-character #\$ 'async-reader) ;"Run statement in seperate thread"
|
|
(set-macro-character #\¬ 'bang-reader) ;"Negates next statement"
|
|
(set-macro-character #\£ 'lambda-reader) ;"Wrap statement in lambda"
|
|
(set-macro-character #\€ 'top-level-reader))) ;"Run at compile,load and execute"
|
|
|
|
(defmacro disable-all-readers()
|
|
"Turn off reader macros"
|
|
'(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(setq *readtable* (pop *old-readtables*))))
|
|
|
|
; ((defun map-parallel (func seq &key (map #'mapcar) (split 0.25) (debug nil)) ;;; TODO: make this work lol
|
|
; (flet ((dprint (x) (when debug (format t "~S~%" x)) x ))
|
|
; "Map over list in parallel"
|
|
; (let* ((step (floor (* split (list-length seq))))
|
|
; (threads (val-if-or (ceiling (/ 1 split))
|
|
; #'(lambda (val)
|
|
; (< val step))
|
|
; 0)))
|
|
; (if (< threads 2)
|
|
; (funcall map func seq) ;; no splits
|
|
; (let ((threads '())
|
|
; (no-threads threads)
|
|
; (outputs (make-list threads))
|
|
; (left '()))
|
|
; (loop for i from 0 below no-threads
|
|
; for start from 0 below (list-length seq) by step
|
|
; do (progn
|
|
; (push (bt:make-thread
|
|
; #'(lambda ()
|
|
; ;(dprint (list i start (restrain-index (+ step start) (list-length seq) )))
|
|
; (rplaca (nthcdr i outputs)
|
|
; (funcall map func (slice seq start (+ (1- step) start))))))
|
|
; threads)))
|
|
; (setf left
|
|
; (when (> (mod (list-length seq) step) 0)
|
|
; (funcall map func (slice seq (* no-threads step) (+ (* no-threads step) (mod (list-length seq) step))))))
|
|
;
|
|
; (loop while (apply #'= (cons 0 (mapcar #'(lambda (x) (if (bt:thread-alive-p x) 1 0)) threads))) do
|
|
; (dprint
|
|
; (mapcar #'bt:thread-alive-p
|
|
; threads)))
|
|
; (apply #'nconc (append outputs left)))))))
|
|
;
|
|
;(defun map-parallel-test (&key (length 10001))
|
|
; (map-parallel
|
|
; #'(lambda (x)
|
|
; x)
|
|
; (make-list length :initial-element 1)
|
|
; :debug t))
|
|
|
|
; --- others
|
|
|
|
(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
|
|
|
|
|