From de2e6a11cc4774a03e8c8b1f1b86cae995d49af1 Mon Sep 17 00:00:00 2001
From: Ringo Wantanabe <flandre@chiru.no>
Date: Thu, 24 Jan 2019 19:28:08 +0000
Subject: [PATCH] added progressive evals

---
 make-asdf-system |   2 +-
 utils.lisp       | 125 +++++++++++++++++++++++++++++++++++++++++++++--
 2 files changed, 122 insertions(+), 5 deletions(-)

diff --git a/make-asdf-system b/make-asdf-system
index 9c16e62..0d990e3 100755
--- a/make-asdf-system
+++ b/make-asdf-system
@@ -1,4 +1,4 @@
 #!/bin/bash
 
-sbcl --eval "(progn (asdf:load-system :cl-ppcre) (load \"utils.lisp\") (print (utils->system \"utils.lisp\" \"utils/flan-utils\")) (quit))"
+sbcl --eval "(progn (asdf:load-system :cl-ppcre)  (load \"utils.lisp\") (print (utils->system \"utils.lisp\" \"utils/flan-utils\")) (quit))"
 echo 
diff --git a/utils.lisp b/utils.lisp
index 48b6de8..930731b 100644
--- a/utils.lisp
+++ b/utils.lisp
@@ -7,7 +7,7 @@
 (defparameter *-utils-lisp* t)
 (defparameter *-utils-depends* '(#:cl-ppcre))
 
-(defparameter *-utils-version* "0.1.4")
+(defparameter *-utils-version* "0.1.5")
 
 ;;; -- Handle internal exporting --
 
@@ -63,10 +63,10 @@
     (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)) this)
+	(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
+(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))))
@@ -99,7 +99,7 @@
 		    defs)))))))
 (export*?
 
-;;; --- actual (exported) code goes here ---
+;;; --- actual (exported) code goes here --
 
 (defmacro val-if-or (val test or)
   `(let ((vv ,val))
@@ -222,6 +222,123 @@
 (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))