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

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

;;; -- 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 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"))
  "Write this file to an ASDF system."
  (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) (package nil) ) ;;; TODO: Make this work /for structs/ at all
  "Export `utils' functions used in file into own file"
  (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)))))))
(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 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))
  (mapc #'export (symbol-match (strcat "^" (write-to-string struct) "-?") symbols)))

(defun -export*-struct (structs &optional (symbols nil))
  (mapc #'export (symbol-match 
		   (strcat
		     "^("
		     (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 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))))

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

;; ---

(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))

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