aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
-rw-r--r--gtwiwtg.asd10
-rw-r--r--gtwiwtg.lisp195
-rw-r--r--package.lisp4
3 files changed, 209 insertions, 0 deletions
diff --git a/gtwiwtg.asd b/gtwiwtg.asd
new file mode 100644
index 0000000..1000609
--- /dev/null
+++ b/gtwiwtg.asd
@@ -0,0 +1,10 @@
+;;;; gtwiwtg.asd
+
+(asdf:defsystem #:gtwiwtg
+ :description "Describe gtwiwtg here"
+ :author "Your Name <your.name@example.com>"
+ :license "Specify license here"
+ :version "0.0.1"
+ :serial t
+ :components ((:file "package")
+ (:file "gtwiwtg")))
diff --git a/gtwiwtg.lisp b/gtwiwtg.lisp
new file mode 100644
index 0000000..acf8fe1
--- /dev/null
+++ b/gtwiwtg.lisp
@@ -0,0 +1,195 @@
+(defpackage #:gtwiwtg (:use #:cl))
+(in-package :gtwiwtg)
+
+(defclass generator! ()
+ ((state
+ :accessor gen-state
+ :initarg :state
+ :initform (error "no state"))
+ (next-p-fn
+ :accessor next-p-fn
+ :initarg :next-p-fn
+ :initform (error "no next-p"))
+ (next-fn
+ :accessor next-fn
+ :initarg :next-fn
+ :initform (error "no next-fn"))))
+
+(defgeneric next (gen)
+ (:documentation "gets next if available. Throws an error otherwise."))
+
+(defmethod next ((gen generator!))
+ (assert (has-next-p gen))
+ (with-slots (state next-fn) gen
+ (multiple-value-bind (val new-state) (funcall next-fn state)
+ (setf state new-state)
+ val)))
+
+(defgeneric has-next-p (gen)
+ (:documentation "returns true if next can be called on this generator!"))
+
+(defmethod has-next-p ((gen generator!))
+ (with-slots (next-p-fn state) gen
+ (funcall next-p-fn state)))
+
+(defun times (n)
+ (range :to n))
+
+(defun range (&key (from 0) to (by 1))
+ (make-instance 'generator!
+ :state (list (- from by) to)
+ :next-p-fn (lambda (state) (or (not to)
+ (apply #'< state)))
+ :next-fn (lambda (state)
+ (incf (car state) by)
+ (values (car state) state))))
+
+(defun seq (sequence)
+ (make-instance 'generator!
+ :state 0
+ :next-p-fn (lambda (state)
+ (< state (length sequence)))
+ :next-fn (lambda (state)
+ (let ((val (elt sequence state)))
+ (values val (1+ state))))))
+
+
+(defmethod yield-to! (gen1 gen2)
+ "Gen1 passes generation control to gen2. This control will be return
+ to gen1 after gen2 is done. Returns a new generator!. "
+ (let ((orig-pred (next-p-fn gen1))
+ (orig-fn (next-fn gen1)))
+ (with-slots ((s1 state) (p1 next-p-fn) (f1 next-fn)) gen1
+ (with-slots ((s2 state) (p2 next-p-fn) (f2 next-fn)) gen2
+ (setf s1 (list s1 s2))
+ (setf p1 (lambda (state)
+ (or (funcall p2 (second state))
+ (funcall orig-pred (first state)))))
+ (setf f1 (lambda (state)
+ (if (funcall p2 (second state))
+ (multiple-value-bind (val new-s2) (funcall f2 (second state))
+ (values val (list (first state) new-s2)))
+ (multiple-value-bind (val new-s1) (funcall orig-fn (car state))
+ (values val (list new-s1 (second state)))))))))))
+
+
+
+(defun map! (map-fn gen &rest gens)
+ (let ((orig-fns (mapcar #'next-fn (cons gen gens)))
+ (orig-preds (mapcar #'next-p-fn (cons gen gens))))
+ (setf (gen-state gen) (mapcar #'gen-state (cons gen gens))
+ (next-p-fn gen) (lambda (states)
+ (loop
+ :for state :in states
+ :for pred :in orig-preds
+ :unless (funcall pred state) :do (return nil)
+ :finally (return t)))
+ (next-fn gen) (lambda (states)
+ (let ((args)
+ (new-states))
+ (loop
+ :for state :in states
+ :for fn :in orig-fns
+ :do (multiple-value-bind (val new-state) (funcall fn state)
+ (push val args)
+ (push new-state new-states)))
+ (values (apply map-fn (reverse args))
+ (reverse new-states))))))
+ gen)
+
+(defun filter! (pred gen)
+ (let ((orig-fn (next-fn gen))
+ (orig-p-fn (next-p-fn gen)))
+ (setf (next-fn gen) (labels ((recurse (state)
+ (multiple-value-bind (val next-state) (funcall orig-fn state)
+ (if (funcall pred val)
+ (values val next-state)
+ (if ()) (recurse next-state)))))))))
+
+(defun chain! (gen-of-gen)
+ (let ((orig-fn (next-fn gen-of-gen))
+ (orig-p (next-p-fn gen-of-gen))
+ (orig-state (gen-state gen-of-gen)))
+ (multiple-value-bind (subgen state) (funcall orig-fn orig-state)
+ (setf orig-state state)
+ (setf (gen-state gen-of-gen) subgen)
+ (setf (next-p-fn gen-of-gen)
+ (lambda (sub) (or (has-next-p sub)
+ (funcall orig-p orig-state))))
+ (setf (next-fn gen-of-gen)
+ (lambda (sub)
+ (if (has-next-p sub)
+ (values (next sub) sub)
+ (multiple-value-bind (next-sub state) (funcall orig-fn orig-state)
+ (setf orig-state state)
+ (values (next next-sub) next-sub))))))
+ gen-of-gen))
+
+
+(defun bind! (fn gen)
+ (let ((orig-fn (next-fn gen))
+ (orig-p (next-p-fn gen))
+ (orig-state (gen-state gen)))
+ (multiple-value-bind (val state) (funcall orig-fn orig-state)
+ (setf orig-state state
+ (gen-state gen) (funcall fn val)
+ (next-p-fn gen) (lambda (sub)
+ (or (has-next-p sub)
+ (funcall orig-p orig-state)))
+ (next-fn gen) (lambda (sub)
+ (if (has-next-p sub)
+ (values (next sub) sub)
+ (multiple-value-bind (val state) (funcall orig-fn orig-state)
+ (setf orig-state state)
+ (let ((new-sub (funcall fn val)))
+ (values (next new-sub) new-sub))))))))
+ gen)
+
+
+
+(defun thread-through (elem vec)
+ "Returns a generator! of vectors. Each vector is 1+ longer than
+VEC. Each vector looks just like VEC except ELEM is inserted in one
+position. Returns (1+ (length VEC)) such vectors.
+
+NB: The memory is shared between generated vectors. If you must keep
+that memory around, copy the vector somehow. "
+ (let ((target (concatenate 'vector vec (list elem)))) ;; reusable buffer
+ (flet ((fill-and-insert (idx) ;; inserts elem into target at idx,
+ ;; fills rest with vec
+ (loop :for i :below (length target)
+ :when (= i idx) :do (setf (aref target idx) elem)
+ :when (< i idx) :do (setf (aref target i)
+ (aref vec i))
+ :when (> i idx) :do (setf (aref target i)
+ (aref vec (1- i))))))
+ (map! (lambda (idx)
+ (fill-and-insert idx)
+ target)
+ (range :from 0 :to (length vec))))))
+
+
+(defun perms (vec)
+ "Low memory generator! for all permutations of VEC. Generates the
+permutations one at a time."
+ (if (= 1 (length vec)) (seq (list vec))
+ (let ((elem (elt vec 0))
+ (subperms (perms (make-array (1- (length vec))
+ :displaced-to vec
+ :displaced-index-offset 1
+ :element-type (array-element-type vec)))))
+ (bind! (lambda (subperm) (thread-through elem subperm)) subperms))))
+
+
+
+(defmacro iter ((var-exp gen) &body body)
+ (let* ((gen-var (gensym "generator!"))
+ (expr-body (if (consp var-exp)
+ `(destructuring-bind ,var-exp (next ,gen-var) ,@body)
+ `(let ((,var-exp (next ,gen-var))) ,@body))))
+ `(let ((,gen-var ,gen))
+ (loop
+ :while (has-next-p ,gen-var)
+ :do
+ ,expr-body))))
+
diff --git a/package.lisp b/package.lisp
new file mode 100644
index 0000000..c07459e
--- /dev/null
+++ b/package.lisp
@@ -0,0 +1,4 @@
+;;;; package.lisp
+
+(defpackage #:gtwiwtg
+ (:use #:cl))