cl-utils/utils.lisp

;;;; 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 #:bt-semaphore))

(defparameter *-utils-version* "0.1.6")

;;; -- 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 export* (&rest syms)
  (cons 'progn (mapcan #'(lambda (x) `((export ',x))) 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))))

(defmacro defexport (&rest val)
  `(export*! ,@val))
(export? defexport)

(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"))
  (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 :pretty nil)) this)
	(write sysdef :stream output-asd :case :downcase )))))

;(defun utils->create-for (utils for &key (name 'flan-utils) ) ;;; TODO: Make this work /for structs/ at all
;  (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)))))))

(defparameter *old-readtables* nil)

(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 (mapcar #'(lambda (x) 
						 (typecase x
						   (string x)
						   (character (string x))
						   (t (write-to-string x))))
					     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)) ;;XXX: Exporting make-* is a hack and you should fix it
  (mapc #'export (symbol-match (strcat "^(MAKE-)?" (write-to-string struct) "-?") symbols)))

(defun -export*-struct (structs &optional (symbols nil)) ;;XXX: Exporting make-* is a hack and you should fix it
  (mapc #'export (symbol-match 
		   (strcat
		     "^(MAKE-)?("
		     (strjoin "|" (mapcar #'write-to-string structs))
		     ")-?")
		   symbols)))

(defmacro export*-struct (&rest 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)
  (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)
  `(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)
  `(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))
  `(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)
  (cons 'progn (mapcan #'(lambda (x) `((import ',x))) args)))

(defmacro shadowing-import* (&rest args)
  (cons 'progn (mapcan #'(lambda (x) `((shadowing-import ',x))) args)))

(defmacro import*! (&rest args)
  `(mapc #'import (progel ,args)))

(defmacro shadowing-import*! (&rest args)
  `(mapc #'shadowing-import (progel ,args)))

(defmacro import*-from (package &rest args)
  (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))
  (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))

(defstruct async-info 
  thread
  handlers
  lock)

(defmacro push-handler (name lam)
  `(bt:with-lock-held
     ((async-info-lock current-async-info))
     (push (cons ,name ,lam)
	   (async-info-handlers current-async-info))))

(defmacro async (&rest form)
  `(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))
  (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)
  (if (async-info-p handle)
    (wait (async-info-thread handle))
    (bt:join-thread handle)))

(defun async-kill (handle)
  (if (async-info-p handle)
    (async-kill (async-info-thread handle))
    (bt:destroy-thread handle)))

(defun async-alive (handle)
  (if (async-info-p handle)
    (async-alive (async-info-thread handle))
    (bt:thread-alive-p handle)))

(defun val (v) v)

(defun groupn (n list)
  (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)))

(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)))
;
;(defmacro enable-reader (char func &optional (keep t))
;  `(eval-when (:compile-toplevel :load-toplevel :execute)
;     (when keep
;       (push *readtable* *old-readtables*)
;       (setq *readtable* (copy-readtable)))
;    (set-macro-character ,char ,func)))
;
;(defun disable-reader (&optional (char nil))
;  (if (null char)
;    '(eval-when (:compile-toplevel :load-toplevel :execute)
;       (setq *readtable* (pop *old-readtables*)))
;    `(set-macro-character ,char nil)))
;
(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))

(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