feat: beginnings of transducers

data-lens.asd

@@ -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")))

package.lisp

@@ -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))

transducers.lisp

@@ -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))))