diff --git a/data-lens.asd b/data-lens.asd index e863b77..787f2f4 100644 --- a/data-lens.asd +++ b/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 " + :license "MIT" + :depends-on (:data-lens + :alexandria) + :serial t + :components ((:file "package") + (:file "transducer"))) diff --git a/package.lisp b/package.lisp index 10dbde9..8139f90 100644 --- a/package.lisp +++ b/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)) diff --git a/transducers.lisp b/transducers.lisp new file mode 100644 index 0000000..7ecb065 --- /dev/null +++ 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))))