cl-utils/flan-utils.lisp

;;;; 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