diff options
| -rw-r--r-- | gtwiwtg.asd | 10 | ||||
| -rw-r--r-- | gtwiwtg.lisp | 195 | ||||
| -rw-r--r-- | package.lisp | 4 |
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)) |