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.

783 lines
26 KiB

;;;; utils.lisp -- some random utils I collect. might be useful, probably won't be.
(defpackage :flan-utils
(:use :cl)
(:nicknames :fu))
(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)) ; TODO: Make this filter out non-defun/defparameter/defmacro statements from `val` before passing to `export*!`
(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 --
(defun copy-stream (from to &key (buffer-size 4096))
"Block copy byte streams"
(let ((buffer (make-array buffer-size :element-type '(unsigned-byte 8))))
(loop for bytes-read = (read-sequence buffer from)
while (plusp bytes-read)
do (write-sequence buffer to :end bytes-read))))
(defun real-copy-file (from to)
"Copy a file"
(with-open-file (from from :direction :input :element-type '(unsigned-byte 8))
(with-open-file (to to :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
(copy-stream from to))))
(defun real-move-file (from to)
"Actually move a file"
(real-copy-file from to)
(delete-file from))
(defmacro errors (stmt)
`(let ((ret (handler-case (cons ,stmt nil)
(t (c) (cons nil c)))))
(values (car ret) (cdr ret))))
(defmacro try-catch (try &body catch)
(let ((errnm (gensym)))
`(let ((,errnm (handler-case (cons ,try nil)
(t (e)
(let ((e e))
(cons (progn ,@catch) e))))))
(if (cdr ,errnm)
(values (car ,errnm) (cdr ,errnm))
(values (car ,errnm) nil)))))
(defmacro try (&body body)
`(try-catch
(progn
,@body)
nil))
(defmacro try-catch-finally (try catch &body finally)
(let ((ret (gensym))
(err (gensym)))
`(multiple-value-bind (,ret ,err) (try-catch ,try ,catch)
(values (progn ,@finally) ,ret ,err))))
(defmacro try-finally (try &body finally)
`(try-catch-finally
,try
nil
,@finally))
(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)))
; Functional
(defun nop ()
"Do nothing"
nil)
(defun yep ()
"Do nothing"
t)
; Combinators
(defun deatomise (list)
"If `list' is a list, pass it through; if it is a non-nil atom, wrap it in a single-element list"
(if (and list (atom list))
(cons list nil)
list))
(defun deatomise! (list) "Ensure `list' is a list" (cons list nil))
(defun combine (fa fb &key (pass #'deatomise!))
"Returns an applicative lambda that runs (`fb' (`fa' args...)...)
NOTE: This function *applies* the result of `fa' to `fb', therefore, if the result of `fa' is a list, the elements of said list are applied as the sequential arguments for `fb', if the result is a single element, it is passed as argument 1 only (this includes ``nil''). If you want to pass the result of `fa' to `fb' verbatim through the first argument only, use ``combine1''().
WARNING: By default, if `fa' returns ``nil'', the ``nil'' is passed as argument 1 to `fb'. Therefore, no function `fa' will ever produce 0 arguments for `fb'; if you wish to override this behaviour and allow a nil return to mean 0 arguments, set `pass' to ``deatomise''() (to still ensure the return of `fa' is contained list; you can use ``combine!''() for behaviour instead too), or the ``identity''() function, if you know `fa' returns a list."
(lambda (&rest args) (apply fb (funcall pass (apply fa args)))))
(defun combine! (fa fb)
"Returns an applicative lambda that runs (`fb' [(`fa' args...)...])
NOTE: This is the same as calling `combine' with `pass' as ``deatomise''()."
(combine fa fb :pass #'deatomise))
(defun combine1 (fa fb)
"Returns a lambda that runs (`fb' (`fa' args...))
NOTE: The difference between this an ``combine''() is that `combine' *applies* the result of `fa' to `fb', whereas `combine1'() simply calls `fb' with the result of `fa'."
(lambda (&rest args) (funcall fb (apply fa args))))
(defun inverse (func)
"Returns a lambda that resolves ¬(`func' args...)"
(lambda (&rest n) (not (apply func n))))
(defun inverse* (&rest functions)
"Returns a list of `inverse'()d functions from `functions'"
(mapcar #'inverse functions))
;; Mapping
(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 map-lines (func stream &key
(ignore nil)
(applicator #'list)
(mapper #'mapcar)
(transform #'identity)
(read-line (lambda (stream) (read-line stream nil)))
(continue #'identity))
"Maps over the lines in stream `stream', applying `applicator' to the result of `mapper' being called with `func' when called with the lines in-order.
To transform the line before processing, you can set the `transform' argument: This will be passed the raw input line, and the line used for the rest of the mapping is the result of that function. (If `transform' returns ``nil'', the line is treated as blank, otherwise, it must return a string.)
To ommit a certain kind of line from being sent to the mapping function, you can set `ignore' to:
- `:blank' Ignore blank lines
- `:whitespace-only' Ignore lines that contain just whitespaces
- Any functor that will take the line as an argument. If the call returns a non-truthy value, the line is ignored.
To use a custom line reader function, set `read-line' to a function that takes a stream and returns a string (or ``nil'', on EOF).
To stop on a specific line, `continue' can be set to a function that receives the line string; and if `nil' is returned from that function, the iteration stops.
The default behaviour (with `mapper' being `mapcar' and `applicator' being `list') works just like `mapcar'(). To emulate the behaviour of functions like `mapcan'(), set `applicator' to `nconc'(); then set `mapper' to `maplist'() for `mapcon'() behaviour."
;(with-open-file (stream location :direction :input)
(let ((filter-single-line (cond
;; Specific `ignore' values
((eql ignore :blank) (lambda (line) (> (length line) 0)))
((eql ignore :whitespace-only) (lambda (line) (not (cl-ppcre:scan "^\\s*$" line))))
;; Otherwise, the ignore function (or pass all, if nil)
(t (or ignore (lambda (--n) (declare (ignore --n)) t))))))
(apply applicator ; apply `applicator' to the result of each iteration in `mapper'.
(funcall mapper func ; call the mapping function with `func' and the list of transformed and filtered lines
(mapcan (lambda (n) (when n (list n))) ; outputs a list of the lines
(loop for line = (funcall read-line stream)
while (and line (funcall continue line))
collect (let ((line (funcall transform line)))
(when (funcall filter-single-line line) line))))))))
(defmacro map-file-lines (func location &rest kvs &key &allow-other-keys)
"See `map-lines'(): Maps `func' over a file `location' instead of a stream."
(let ((stream (gensym)))
`(with-open-file (,stream ,location :direction :input)
,(cons 'map-lines (append `(,func ,stream) kvs)))))
(defun mapcan-lines (func stream &rest kvs &key &allow-other-keys)
"See `map-lines'(): Uses `nconc'() as the applicator and `mapcar'() as the mapper, which produces an output you'd expect from `mapcan'() The other key arguments can be specified according to the signature of `map-lines'()."
(apply #'map-lines (append (list func stream :applicator #'nconc :mapper #'mapcar) kvs)))
(defmacro mapcan-file-lines (func location &rest kvs &key &allow-other-keys)
"See `mapcan-lines'(): Maps `func' over a file `location' instead of a stream."
(let ((stream (gensym)))
`(with-open-file (,stream ,location :direction :input)
,(cons 'mapcan-lines (append `(,func ,stream) kvs)))))
(defun mapcon-lines (func stream &rest kvs &key &allow-other-keys)
"See `map-lines'(): Uses `nconc'() as the applicator and `maplist'() as the mapper, which produces an output you'd expect from `mapcon'(). The other key arguments can be specified according to the signature of `map-lines'()."
(apply #'map-lines (append (list func stream :applicator #'nconc :mapper #'maplist) kvs)))
(defmacro mapcon-file-lines (func location &rest kvs &key &allow-other-keys)
"See `mapcon-lines'(): Maps `func' over a file `location' instead of a stream."
(let ((stream (gensym)))
`(with-open-file (,stream ,location :direction :input)
,(cons 'mapcon-lines (append `(,func ,stream) kvs)))))
(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 strcat-fast (&rest strings)
"Concat all strings, they need to be strings. Use `strcat' instead unless you can guarantee you won't violate that."
`(concatenate 'string
,@strings))
(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"
(let ((liname (gensym)))
`(let ((,liname ,li))
(if (atom ,liname) ,or
(pop ,liname)))))
(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 ()
"Gets 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-list (seq start &optional (end -1))
"Like JS slice() for list"
(let ((start (index start (length seq)))
(end (index end (length seq))))
(rplacd (nthcdr end seq) nil)
(nthcdr start seq)))
(defun slice (seq start &optional (end -1))
"Like JS slice()?"
(let ((start (index start (length seq)))
(end (index end (1+ (length seq)))))
(subseq seq start end)))
(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 progex (funcs expr)
"run funcs on expr, return specified"
(let ((name (gensym)))
`(let ((,name ,expr))
(mapcar #'(lambda (x) (funcall x ,name)) ,funcs)
,name)))
(defmacro progen (&rest things)
"mapn eval things"
`(mapn #'eval '(,@things)))
(defmacro proge1 (&rest things)
"map1 eval things"
`(map1 #'eval '(,@things)))
(defmacro progenth (n &rest things)
"mapnth eval n things"
`(mapnth #'eval ,n '(,@things)))
(defmacro progev (&rest things)
"mapv eval things"
`(mapv #'eval '(,@things)))
(defmacro progel (&rest things)
"mapcar eval things"
`(mapcar #'eval '(,@things)))
(defmacro progenc (&rest things)
"mapcan eval things"
`(mapcan #'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) (unset t) (keep-char t))
"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)))
(and unset (set-macro-character char nil))
(if keep-char
(values (read-from-string (strcat (string char) (write-to-string (read stream t nil t)))) nil)
(values (read stream t nil t) nil)))))
(defun not-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 #\¬ 'not-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 switch (value &body conds)
"Cond `eql' for value to each first element of `conds', with the result as the 2nd element. If `conds' is an atom, it is treated as the default condition"
(let* ((value-name (gensym))
(exprs (mapcar #'(lambda (pair)
(if (atom pair)
`(t ,pair)
`((eql ,value-name ,(car pair)) ,(cadr pair)))) conds)))
`(let ((,value-name ,value))
,(cons 'cond exprs))))
(defun split-string (string &optional sep)
"Split a string by this seperator (or whitespace, if not provided)"
(let* ((sep (or (switch sep
(#\Newline "[\\n\\f\\r]")
(#\Space " ")
(#\Backspace "\\b")
(#\Tab "\\t")
(#\Linefeed "\\n")
(#\Page "\\f") ; ???
(#\Return "\\r")
;(#\Rubout wtf even is this???
(nil "\\s")
nil)
(cl-ppcre:quote-meta-chars sep)))
(lst (cl-ppcre:split sep string)))
(values (where #'(lambda (str) (> (length str) 0)) lst)
sep)))
(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))
(defun status-bar-string (percs &optional (sz (length percs)) (max nil) (default #\-))
"Create a bar string of multiple characters at a ratio. The most simple variant of this uses 2 chars at a ratio to create a text-based progress bar. (see `progress-bar-string')
`percs': a list of (fract . char)
`sz': the length of the bar (default: length of `percs')
`max': the max for `fract' (default: sum of all `fract's in `percs')
`default': the char to print if we run above `max' while still under `sz' (default #\-) (note: `default' will never appear in the output string unless `max' is user-provided; otherwise `percs' will be stretched to always completely fill `sz')"
(let ((max (or max (apply #'+ (mapcar #'car percs)))))
(flet ((write-single (stream fract char cur)
(let ((sml (* (/ fract max) sz)))
(length (loop for i from cur to (- sz 1)
for j from 0 to (- sz 1)
while (< j sml)
collect i ; XXX: This is very inefficient, come on...
do
(write-char char stream))))))
(with-output-to-string (stream)
(let ((i 0))
(loop while (< i sz) do
(let ((this (pop percs)))
(incf i (if this
(destructuring-bind (fract . char) this
(funcall #'write-single stream fract char i))
(prog1 1 (write-char default stream)))))))))))
;(print (status-bar-string '((2 . #\: ) (8 . #\|) (3 . #\_) (1 . #\!)) 60))
(defun progress-bar-string (perc len &optional (char #\#) (default #\-))
"Create a progress bar string of `len' size containing `perc'% `char', with the rest `default'"
(status-bar-string `((,perc . ,char)) len 100 default))
;(print (progress-bar-string 10 60))
) ;; -- end export