feat: beginnings of transducers

2025-11-08 10:16:32 +00:00 · 2020-12-13 02:30:08 -08:00
parent befab03521
commit b6f51eceaf
3 changed files with 127 additions and 0 deletions
--- a/transducers.lisp
+++ b/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))))