cl-utils/flan-utils.lisp

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