diff options
| -rw-r--r-- | gtwiwtg.lisp | 496 |
1 files changed, 232 insertions, 264 deletions
diff --git a/gtwiwtg.lisp b/gtwiwtg.lisp index 3d03317..c0f5da5 100644 --- a/gtwiwtg.lisp +++ b/gtwiwtg.lisp @@ -1,44 +1,119 @@ (defpackage #:gtwiwtg (:use #:cl)) (in-package :gtwiwtg) -(defclass generator! () - ((dirty-p - :accessor dirty-p - :initform nil) - (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")))) +;;; Generator Protocol ;;; (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 dirty-p) gen - (setf dirty-p t) - (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))) +(defgeneric stop (gen) + (:documentation "stops the generator")) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun make-keyword (symb) + (read-from-string (format nil ":~a" symb)))) + +;;; Utility Class Builder ;;; + +(defmacro a-class (name supers &rest slots) + `(defclass ,name ,supers + ,(mapcar (lambda (def) + (if (consp def) + `(,(car def) + :initarg ,(make-keyword (car def)) + :initform ,(second def)) + `(,def :initarg ,(make-keyword def) + :initform nil))) + slots))) +;;; Base Generator Class ;;; + +(defclass generator! () + ((dirty-p + :accessor dirty-p + :initform nil + :documentation "Indicates whether or not this any of this + generator has been consumed, or should behave as if it has been.") + (stopped-p + :accessor stopped-p + :initform nil + :documentation "Indicates whether or not this generator has been + explicitly stopped."))) + +(defmethod stop ((g generator!)) + (setf (stopped-p g) t)) (defun make-dirty (g) (setf (dirty-p g) t)) +;;; Generator Classes ;;; + +(a-class range-backed-generator! (generator!) + (at 0) to (by 1) inclusive (comparator #'<)) + +(defmethod has-next-p ((g range-backed-generator!)) + (with-slots (to current comparator by at stopped-p) g + (unless stopped-p + (or (not to) + (funcall comparator + (+ by at) + to))))) + +(defmethod next ((g range-backed-generator!)) + (with-slots (at by) g + (incf at by) + at)) + +(a-class sequence-backed-generator! (generator!) + sequence index) + +(defmethod has-next-p ((g sequence-backed-generator!)) + (with-slots (stopped-p index sequence) g + (unless stopped-p + (< index (1- (length sequence)))))) + +(defmethod next ((g sequence-backed-generator!)) + (with-slots (index sequence) g + (incf index) + (elt sequence index))) + +(a-class thunk-backed-generator! (generator!) + next-p-fn + next-fn + stop-fn) + +(defmethod has-next-p ((g thunk-backed-generator!)) + (with-slots (stopped-p next-p-fn) g + (unless stopped-p (funcall next-p-fn)))) + +(defmethod next ((g thunk-backed-generator!)) + (funcall (slot-value g 'next-fn))) + +(defmethod stop :after ((g thunk-backed-generator!)) + (with-slots (stop-fn) g + (when stop-fn + (funcall stop-fn)))) + +(a-class stream-backed-generator! (generator!) + stream reader) + +(defmethod has-next-p ((g stream-backed-generator!)) + (with-slots (stopped-p stream) g + (unless stopped-p + (open-stream-p stream)))) + +(defmethod next ((g stream-backed-generator!)) + (with-slots (reader stream) g + (let ((read-value (funcall reader stream))) + (unless read-value + (close stream)) + read-value))) + +(defmethod stop :after ((g stream-backed-generator!)) + (close (slot-value g 'stream))) + ;;; CONSTRUCTORS (defun range (&key (from 0) to (by 1) inclusive) @@ -72,70 +147,42 @@ If TO is NIL, then the generator produces an infinite sequence. (let ((comparator (if (plusp by) (if inclusive #'<= #'<) (if inclusive #'>= #'>)))) - (make-instance 'generator! - :state (list (- from by) to) - :next-p-fn (lambda (state) (or (not to) - (funcall comparator - (+ by (first state)) - (second state)))) - :next-fn (lambda (state) - (incf (car state) by) - (values (car state) state))))) + (make-instance 'range-backed-generator! + :comparator comparator + :inclusive inclusive + :at (- from by) + :to to + :by by))) (defun times (n) "Shorthand for (RANGE :TO N)" (range :to n)) -(defun seq (sequence) + +(defun seq (sequence &key (start 0)) "Turns a sequecne (a list, vector, string, etc) into a generator. The resulting generator will generate exactly the memebers of the 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)))))) - -(defun repeater (&rest args) - "Produces a generator that produces an infinite series consisting in -the values passed as ARGS looped forever." - (make-instance 'generator! - :state (copy-list args) - :next-p-fn (constantly t) - :next-fn (lambda (state) - (if (cdr state) - (values (car state) (cdr state)) - (values (car args) (copy-list (cdr args))))))) - - -(defun noise (&optional (arg 1.0)) - "Creates a generator that produces an infinite series of random - numbers that are the result of calling (RANDOM ARG)." - (make-instance 'generator! - :state nil - :next-p-fn (constantly t) - :next-fn (lambda (state) - (declare (ignore state)) - (values (random arg) nil)))) - - + (make-instance 'sequence-backed-generator! + :sequence sequence + :index (1- start))) -(defun from-thunk-until (thunk &optional (until (constantly nil))) +(defun from-thunk-until (thunk &optional (until (constantly nil)) clean-up) "Creates a generator that produces a series of value by successively calling (FUNCALL THUNK). The iterator stops whenever (FUNCALL UNTIL) is non null. +If a CLEAN-UP thunk is supplied, it will be run after consumption of +the new generator has finished. I.e. when passing this form to a +consumer such as FOR, FOLD, COLLECT, etc. + By default, UNTIL is the function (CONSTANTLY NIL). I.e. it will generate forever." - (make-instance 'generator! - :state nil - :next-p-fn (lambda (ignore) (declare (ignore ignore)) (not (funcall until))) - :next-fn (lambda (ignore) - (declare (ignore ignore)) - (values (funcall thunk) nil)))) + (make-instance 'thunk-backed-generator! + :stop-fn clean-up + :next-p-fn (complement until) + :next-fn thunk)) (defun from-thunk (thunk) @@ -166,10 +213,10 @@ should be K, the number of arguments acepted by REC. Example -> (let ((fibs (from-recurrence (lambda (n-1 n-2) (+ n-1 n-2)) 1 0))) +> (let ((fibs (from-recurrence #'+ 1 0))) (take 10 fibs)) -(1 1 2 3 5 8 13 21 34 55) +(1 2 3 5 8 13 21 34 55 89) " (let* ((history (cons n-1 n-m)) @@ -179,6 +226,24 @@ Example nth)))) (from-thunk thunk))) + +(defun repeater (&rest args) + "Produces a generator that produces an infinite series consisting in +the values passed as ARGS looped forever." + (let ((state (copy-list args))) + (from-thunk + (lambda () + (unless (car state) + (setf state (copy-list args))) + (pop state))))) + + +(defun noise (&optional (arg 1.0)) + "Creates a generator that produces an infinite series of random + numbers that are the result of calling (RANDOM ARG)." + (from-thunk (lambda () (random arg)))) + + (defun from-input-stream (stream stream-reader) "Create a generator from a STREAM. @@ -186,109 +251,57 @@ You must supply as STREAM-READER function that accepts the stream as its only argument and returns NIL if the stream has run out of input, Non-NIL otherwise. -This function will close the stream when it reaches the end. - A quirk is that the last value returned from this generator is NIL. -Avoid using with TAKE or PICK-OUT as the file stream will not be closed. - -If you need to use TAKE or PICK-OUT or other consumers that will not -consume the whole generator, you should evaluate the whole generator -within an UNWIND-PROTECTing form like WITH-OPEN-FILE. - -e.g. +Consumers of the new generator will ensure that the stream is properly +closed.. -This is fine: - -(with-open-file (input \"hey.txt\") - (take 2 (from-input-stream - input - (lambda (s) (read-char s nil nil))))) -(#\\h #\\e) - -But this isn't: +Here is an example: -(take 2 (from-input-stream + (take 2 (from-input-stream (open \"hey.txt\") (lambda (s) (read-char s nil nil)))) -(#\\h #\\e) + (#\\h #\\e) + " - (make-instance 'generator! - :state stream - :next-p-fn #'open-stream-p - :next-fn (lambda (stream) - (let ((val (funcall stream-reader stream))) - (if val - (values val stream) - (progn - (close stream) - (values nil stream))))))) + (make-instance 'stream-backed-generator! + :stream stream + :reader stream-reader)) (defun file-lines (file) "Creates a generator that produces the lines of a file. The stream to the file is closed when the generator finishes. -FILE is either a path to a file, or is an open character input stream -to a file. +FILE is either a path to a file. Returns NIL on the last iteration. -Avoid using with TAKE or PICK-OUT as the file stream will not be closed. - -If you need to use TAKE or PICK-OUT or other consumers that will not -consume the whole generator, you should evaluate the whole generator -within an UNWIND-PROTECTing form such as WITH-OPEN-FILE. - -See the documentation for FROM-INPUT-STREAM for an example of the -distinction. " - (from-input-stream (if (streamp file) file (open file)) + (from-input-stream (open file) (lambda (stream) (read-line stream nil nil)))) (defun file-chars (file) "Creates a generator that produces the characters of a file. The stream to the file is closed when the generator finishes. -FILE is either a path to a file, or is an open character input stream -to a file. +FILE is either a path to a file. Returns NIL on the last iteration. - -Avoid using with TAKE or PICK-OUT as the file stream will not be closed. - -If you need to use TAKE or PICK-OUT or other consumers that will not -consume the whole generator, you should evaluate the whole generator -within an UNWIND-PROTECTing form such as WITH-OPEN-FILE. - -See the documentation for FROM-INPUT-STREAM for an example of the -distinction. - " - (from-input-stream (if (streamp file) file (open file)) + (from-input-stream (open file) (lambda (stream) (read-char stream nil nil)))) (defun file-bytes (file) "Creates a generator that produces the bytes of a file. The stream to the file is closed when the generator finishes. -FILE is either a path to a file, or is an open byte input stream to a -file. +FILE is either a path to a file. Returns NIL on the last iteration. - -Avoid using with TAKE or PICK-OUT as the file stream will not be closed. - -If you need to use TAKE or PICK-OUT or other consumers that will not -consume the whole generator, you should evaluate the whole generator -within an UNWIND-PROTECTing form such as WITH-OPEN-FILE. - -See the documentation for FROM-INPUT-STREAM for an example of the -distinction. " - (from-input-stream (if (streamp file) file - (open file :element-type '(unsigned-byte 8))) + (from-input-stream (open file :element-type '(unsigned-byte 8)) (lambda (stream) (read-byte stream nil nil)))) ;;; Some utilities @@ -314,7 +327,6 @@ distinction. (defun all-different (things) (= (length things) (length (remove-duplicates things)))) - (defun all-clean (gens) (every (complement #'dirty-p) gens)) @@ -323,35 +335,6 @@ distinction. ;;; MODIFIERS and COMBINATORS -(defmethod yield-to! (gen1 gen2) - "GEN1 passes generation control to GEN2. This control will be return -to GEN1 after GEN2 is done. This function modifies GEN1. - -Hence, YIELD-TO! can be used within an iteration to conditionally dive -off into some new iteration, knowing that business as usuall will -resume when the \"sub iteration\" finishes. - -It is kind of dark magic, and so I don't recommend using it except in -the rareest of circumstances." - (assert (not (eq gen1 gen2))) - (make-dirty gen2) - (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) "Maps a function over a number of generators, returning a generator that produces values that result from calling MAP-FN on those @@ -365,34 +348,17 @@ generators. Error Conditions: - If any of the generators compare EQL an error will be signalled - If any of the generators have been used elsewhere, an error will be signalled. - -Caveat: - - This function modifies and returns its first generator argument. " - (assert (all-good (list* gen gens))) - (dolist (g gens) (make-dirty g)) ;; to ensure gens wont be re-used after use here. - - (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) + (let ((all-gens (list* gen gens))) + (assert (all-good all-gens)) + (dolist (g all-gens) (make-dirty g)) + (from-thunk-until + (lambda () + (apply map-fn (mapcar #'next all-gens))) + (lambda () + (some (complement #'has-next-p) all-gens)) + (lambda () + (dolist (g all-gens) (stop g)))))) (defun filter! (pred gen) "Produces a generator that filters out members of GEN that are NIL @@ -400,37 +366,23 @@ when applied to PRED. Error Condition: - If GEN has been used elsewhere, an error will be signalled. - -Caveat: - - This function modifies and returns its generator argument. - " (assert (not (dirty-p gen))) - (let* ((orig-fn (next-fn gen)) - (orig-p-fn (next-p-fn gen)) - (last-good nil) - (last-known-state (gen-state gen)) - (new-next-p-fn (lambda (state) - (or last-good - (loop :while (funcall orig-p-fn state) - :do (multiple-value-bind (val new-state) (funcall orig-fn state) - (if (funcall pred val) - (progn (setf last-good (list val)) - (setf last-known-state (list new-state)) - (return t)) - (setf state new-state))) - :finally (return nil)))))) - - (setf (next-p-fn gen) new-next-p-fn) - - (setf (next-fn gen) (lambda (state) - (declare (ignore state)) - (let ((tmp-state (car last-known-state)) - (tmp-val (car last-good))) - (setf last-good nil) - (setf last-known-state nil) - (values tmp-val tmp-state)))) - gen)) + (make-dirty gen) + (let (on-deck) + (from-thunk-until + (lambda () on-deck) + (lambda () + (loop + :while (has-next-p gen) + :for candidate = (next gen) + :when (funcall pred candidate) + :do (progn + (setf on-deck candidate) + (return nil)) + :finally (return t))) + (lambda () + (stop gen))))) (defun inflate! (fn gen) @@ -454,28 +406,29 @@ Here is an example: Error Conditions: - If GEN has been used elsewhere, an error will be signalled. - -Caveat: - - INFLATE! Modifies and returns its generator argument. " (assert (not (dirty-p 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) + (make-dirty gen) + + (let ((sub-gen (funcall fn (next gen)))) + (from-thunk-until + (lambda () (next sub-gen)) + + (lambda () + (loop + :until (has-next-p sub-gen) + :while (has-next-p gen) + :do + (stop sub-gen) + (setf sub-gen (funcall fn (next gen)))) + + ;; the 'until' thunk must return t when we should stop generating + ;; hence: + (not (or (has-next-p sub-gen) + (has-next-p gen)))) + (lambda () + (stop gen) + (when sub-gen (stop sub-gen)))))) (defun concat! (gen &rest gens) @@ -493,7 +446,7 @@ Caveat: - CONCAT! Modifies and returns its first argument. " (assert (all-good (list* gen gens))) - (dolist (g gens) (make-dirty g)) ;; to help ensure that gens can be combined elsewhere + (dolist (g (list* gen gens)) (make-dirty g)) (inflate! #'identity (seq (list* gen gens)))) (defun zip! (gen &rest gens) @@ -540,8 +493,12 @@ Error Conditions: (nconc (when (cdr vals) (list (seq (cdr vals)))) all-gens))) (car vals))) + (lambda () - (null all-gens))))) + (null all-gens)) + + (lambda () + (dolist (g all-gens) (stop g)))))) (defun skip! (n gen) @@ -563,7 +520,7 @@ returns NIL." gen) -(defun nfurcate! (count gen) +(defun nfurcate! (count source-generator) "EXERIMENTAL. MAY BE REMOVED Return a list of COUNT copies of GEN. @@ -576,26 +533,36 @@ Caveat: on infinite generators. " - (make-dirty gen) - (let ((qs (loop :for _ :below count :collect (make-queue)))) - (loop :for build-q :in qs + (make-dirty source-generator) + (let ((qs (loop :for _ :below count :collect (make-queue))) + (stop-cells (loop :for _ :below count :collect (list nil)))) + (loop + :for build-q :in qs + :for stop-cell :in stop-cells :collect - (let ((local-q build-q)) + (let ((local-q build-q) + (local-stop stop-cell)) + (from-thunk-until (lambda () (cond ((not (queue-empty-p local-q)) (dequeue local-q)) - ((has-next-p gen) - (let ((next-v (next gen))) + ((has-next-p source-generator) + (let ((next-v (next source-generator))) (loop :for q :in qs :do (enqueue next-v q)) (dequeue local-q))) (t (error "Attempted to get next from a spent generator.")))) (lambda () - (and (not (has-next-p gen)) - (queue-empty-p local-q)))))))) + (and (not (has-next-p source-generator)) + (queue-empty-p local-q))) + + (lambda () + (setf (car local-stop) t) + (when (every #'car stop-cells) + (stop source-generator)))))))) (defun partition! (pred gen) "EXPERIMENTAL. MAY BE REMOVED. @@ -634,8 +601,8 @@ procuded by GEN. Example: -(for (x y) (zip! (repeater 'a 'b 'c) (times 5)) - (format t \"~a -- ~a~%\" x y)) + (for (x y) (zip! (repeater 'a 'b 'c) (times 5)) + (format t \"~a -- ~a~%\" x y)) A -- 0 B -- 1 @@ -652,7 +619,8 @@ A -- 4 (loop :while (has-next-p ,gen-var) :do - ,expr-body)))) + ,expr-body) + (stop ,gen-var)))) (defmacro fold ((acc init-val) (var-exp gen) expr) "The accumulating generator consumer. |