@@ -27,32 +27,64 @@

                  exit-early taking dropping transduce

                  hash-table-builder vector-builder list-builder))

-(defmacro define-functional-transducer (name () &body body)

-  `(defun ,name (function &rest args)

-     (flet ((call-function (it) (apply function it args)))

-       (lambda (rf)

-         (lambda (acc next)

-           ,@body)))))

-

-(define-functional-transducer mapping ()

-  (funcall rf acc (call-function next)))

-

-(define-functional-transducer mv-mapping ()

-  (funcall rf acc (multiple-value-list (call-function next))))

-

-(define-functional-transducer mv-selecting ()

-  (multiple-value-bind (value use-p) (call-function next)

-    (if use-p

-        (funcall rf acc value)

-        acc)))

+(defmacro transducer-lambda (&body (((two-arg-acc two-arg-next) &body two-arg-body)

+                                    &optional (((one-arg-arg) &body one-arg-body)

+                                               '((it) it))))

+  (alexandria:with-gensyms (arg1 arg2 next-sym-p)

+    `(lambda (,arg1 &optional (,arg2 nil ,next-sym-p))

+       (if ,next-sym-p

+           (let ((,two-arg-acc ,arg1)

+                 (,two-arg-next ,arg2))

+             ,@two-arg-body)

+           (let ((,one-arg-arg ,arg1))

+             ,@one-arg-body)))))

+

+

+(defun mapping (function &rest args)

+  (flet ((call-function (it)

+           (apply function it args)))

+    (lambda (rf)

+      (transducer-lambda

+        ((acc next)

+         (funcall rf acc (call-function next)))

+        ((it) (funcall rf it))))))

+

+(defun mv-mapping (function &rest args)

+  (flet ((call-function (it)

+           (apply function it args)))

+    (lambda (rf)

+      (transducer-lambda

+        ((acc next)

+         (funcall rf acc

+                  (multiple-value-list (call-function next))))

+        ((it) (funcall rf it))))))

+

+(defun mv-selecting (function &rest args)

+  (flet ((call-function (it)

+           (apply function it args)))

+    (lambda (rf)

+      (transducer-lambda

+        ((acc next)

+         (multiple-value-bind (value use-p)

+             (call-function next)

+           (if use-p

+               (funcall rf acc value)

+               acc)))

+        ((it) (funcall rf it))))))

 (defun hash-table-select (hash-table)

   (mv-selecting #'gethash hash-table))

-(define-functional-transducer filtering ()

-  (if (call-function next)

-      (funcall rf acc next)

-      acc))

+(defun filtering (function &rest args)

+  (flet ((call-function (it)

+           (apply function it args)))

+    (lambda (rf)

+      (transducer-lambda

+        ((acc next)

+         (if (call-function next)

+             (funcall rf acc next)

+             acc))

+        ((it) (funcall rf it))))))

 (defun mv-filtering (function &rest args)

   (filtering (lambda (it)

@@ -61,16 +93,45 @@

 (defun deduping (&optional (test 'eql))

   (lambda (rf)

     (let (last)

-      (lambda (acc next)

-        (prog1 (if (funcall test last next)

-                   acc

-                   (funcall rf acc next))

-          (setf last next))))))

+      (transducer-lambda

+        ((acc next)

+         (prog1 (if (or (null last)

+                        (funcall test last next))

+                    acc

+                    (funcall rf acc next))

+           (setf last next)))

+        ((it) (funcall rf it))))))

+

+(defun seq (a b) a b)

+(defun compressing-runs (&optional (test 'eql) (combiner 'seq))

+  (lambda (rf)

+    (let (last leftovers)

+      (transducer-lambda

+        ((acc next)

+         (if (or (null last)

+                 (funcall test last next))

+             (progn (setf last (funcall combiner last next)

+                          leftovers t)

+                    acc)

+             (progn (prog1 (funcall rf acc last)

+                      (setf last next)))))

+        ((it)

+         (funcall rf

+                  (if leftovers

+                      (funcall rf it last)

+                      it)))))))

+

 (defun catting ()

   (lambda (rf)

-    (lambda (acc next)

-      (reduce rf next :initial-value acc))))

+    (transducer-lambda

+      ((acc next)

+       (reduce rf next :initial-value acc))

+      ((it) (funcall rf it)))))

+

+(defun mapcatting (fun)

+  (data-lens:• (mapping fun)

+               (catting)))

 (defun splitting (&rest functions)

   (let ((splitter (apply #'data-lens:juxt functions)))

@@ -82,27 +143,33 @@

 (defun taking (n)

   (lambda (rf)

     (let ((taken 0))

-      (lambda (acc next)

-        (incf taken)

-        (if (< taken n)

-            (funcall rf acc next)

-            (exit-early (funcall rf acc next)))))))

+      (transducer-lambda

+        ((acc next)

+         (incf taken)

+         (if (<= taken n)

+             (funcall rf acc next)

+             (exit-early acc)))

+        ((it) (funcall rf it))))))

 (defun dropping (n)

   (lambda (rf)

     (let ((taken 0))

-      (lambda (acc next)

-        (if (< taken n)

-            (progn (incf taken)

-                   acc)

-            (funcall rf acc next))))))

+      (transducer-lambda

+        ((acc next)

+         (if (< taken n)

+             (progn (incf taken)

+                    acc)

+             (funcall rf acc next)))

+        ((it) (funcall rf it))))))

 (defun transduce (xf build seq)

-  (unwrap build

-          (catch 'done

-            (reduce-generic seq

-                            (funcall xf (stepper build))

-                            (init build)))))

+  (let ((transducer (funcall xf (stepper build))))

+    (unwrap build

+            (funcall transducer

+                     (catch 'done

+                       (reduce-generic seq

+                                       transducer

+                                       (init build)))))))

 (defun eduction (xf seq)

   (lambda (build)

     (unwrap

@@ -115,17 +182,19 @@

 (defmethod init ((it (eql 'hash-table-builder)))

   (make-hash-table))

 (defmethod stepper ((it (eql 'hash-table-builder)))

-  (lambda (acc next)

-    (destructuring-bind (k v) next

-      (setf (gethash k acc) v))

-    acc))

+  (transducer-lambda

+    ((acc next)

+     (destructuring-bind (k v) next

+       (setf (gethash k acc) v))

+     acc)))

 (defmethod init ((it (eql 'vector-builder)))

   (make-array 0 :fill-pointer t :adjustable t))

 (defmethod stepper ((it (eql 'vector-builder)))

-  (lambda (acc next)

-    (vector-push-extend next acc)

-    acc))

+  (transducer-lambda

+    ((acc next)

+     (vector-push-extend next acc)

+     acc)))

 (defmethod init ((it (eql 'list-builder)))

   (declare (optimize (speed 3)))

@@ -133,13 +202,14 @@

     (coerce (vector it it)

             '(simple-array list (2)))))

 (defmethod stepper ((it (eql 'list-builder)))

-  (lambda (acc a)

-    (declare (optimize (speed 3))

-             (type (simple-array list (2)) acc))

-    (let* ((to-build (elt acc 1)))

-      (push a (cdr to-build))

-      (setf (elt acc 1) (cdr to-build)))

-    acc))

+  (transducer-lambda

+    ((acc a)

+     (declare (optimize (speed 3))

+              (type (simple-array list (2)) acc))

+     (let* ((to-build (elt acc 1)))

+       (push a (cdr to-build))

+       (setf (elt acc 1) (cdr to-build)))

+     acc)))

 (defmethod unwrap ((it (eql 'list-builder)) obj)

   (cdr (elt obj 0)))