@@ -12,3 +12,16 @@

   :components ((:file "package")

                (:file "optics")

                (:file "lens")))

+

+(asdf:defsystem #:data-lens/beta/transducer

+  :description #.(format nil "~a ~a ~a"

+                         "Utilities for building data transormations from"

+                         "composable functions, modeled on lenses and"

+                         "transducers")

+  :author "Edward Langley <el-cl@elangley.org>"

+  :license "MIT"

+  :depends-on (:data-lens

+               :alexandria)

+  :serial t

+  :components ((:file "package")

+               (:file "transducer")))

@@ -20,3 +20,9 @@

            #:maximizing #:zipping #:applying #:splice-elt #:transform-elt #:denest

            #:op #:defalias #:<> #:<>1 #:== #:•

            ))

+

+(defpackage :data-lens.transducers.beta

+  (:use :cl)

+  (:export #:mapping :filtering :deduping :catting :splitting

+           #:exit-early :taking :dropping :transduce

+           #:hash-table-builder :vector-builder :list-builder))

new file mode 100644

@@ -0,0 +1,108 @@

+(in-package :data-lens.transducers.beta)

+

+(defun mapping (function)

+  (lambda (rf)

+    (lambda (acc next)

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

+

+(defun filtering (predicate)

+  (lambda (rf)

+    (lambda (acc next)

+      (if (funcall predicate next)

+          (funcall rf acc next)

+          acc))))

+

+(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))))))

+

+(defun catting ()

+  (lambda (rf)

+    (lambda (acc next)

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

+

+(defun splitting (&rest functions)

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

+    (mapping splitter)))

+

+(defun exit-early (acc)

+  (throw 'done acc))

+

+(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)))))))

+

+(defun dropping (n)

+  (lambda (rf)

+    (let ((taken 0))

+      (lambda (acc next)

+        (if (< taken n)

+            (progn (incf taken)

+                   acc)

+            (funcall rf acc next))))))

+

+(defun transduce (xf build seq)

+  (funcall build

+           (catch 'done

+             (reduce (funcall xf build) seq :initial-value (funcall build)))))

+

+(defmacro comment (&body body)

+  (declare (ignore body))

+  nil)

+

+(defun hash-table-builder (&optional (acc nil acc-p) (next nil next-p))

+  (cond (next-p (destructuring-bind (k v) next

+                  (setf (gethash k acc) v)) acc)

+        (acc-p acc)

+        (t (make-hash-table))))

+

+(defun vector-builder (&optional (acc nil acc-p) (next nil next-p))

+  (cond (next-p (vector-push-extend next acc) acc)

+        (acc-p acc)

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

+

+(eval-when (:load-toplevel :compile-toplevel :execute)

+  (labels ((make-snoc ()

+             (vector nil nil))

+           (add-to-snoc (acc a)

+             (if (elt acc 1)

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

+                   (push a (cdr to-build))

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

+                 (let ((new (list a)))

+                   (setf (elt acc 0) new

+                         (elt acc 1) new)))

+             acc)

+           (desnoc (acc)

+             (elt acc 0)))

+    (defun list-builder (&optional (acc nil acc-p) (next nil next-p))

+      (cond (next-p (add-to-snoc acc next))

+            (acc-p (desnoc acc))

+            (t (make-snoc))))))

+

+(comment

+  (defun 2* (it)

+    (* 2 it))

+

+  (let ((result (transduce (alexandria:compose (catting)

+                                               (mapping #'parse-integer)

+                                               (filtering (complement #'evenp))

+                                               (mapping (data-lens:juxt #'identity #'identity))

+                                               (mapping (data-lens:transform-head #'2*))

+                                               (mapping (data-lens:transform-head #'1+))

+                                               (taking 2))

+                           'hash-table-builder

+                           '(("123" "234" "345" "454") ("568" "490") ("567" "213")))

+                ))

+    (values result

+            (alexandria:hash-table-alist result))))