fiddlerwoaroof/data-lens
1
0
Fork 0
mirror of https://github.com/fiddlerwoaroof/data-lens.git synced 2025-11-08 18:26:32 +00:00
Code Issues Releases Wiki Activity

feat(transducer): implement COMPRESSING-RUNS, add one-arity rf

Browse Source
This commit is contained in:
Edward
2020-12-31 17:40:58 -08:00
parent d232497011
commit 1259838639
1 changed files with 125 additions and 55 deletions
Download Patch File Download Diff File Expand all files Collapse all files

180
transducers.lisp
View File

@ -27,32 +27,64 @@
exit-early taking dropping transduce exit-early taking dropping transduce
hash-table-builder vector-builder list-builder)) hash-table-builder vector-builder list-builder))
(defmacro define-functional-transducer (name () &body body) (defmacro transducer-lambda (&body (((two-arg-acc two-arg-next) &body two-arg-body)
`(defun ,name (function &rest args) &optional (((one-arg-arg) &body one-arg-body)
(flet ((call-function (it) (apply function it args))) '((it) it))))
(lambda (rf) (alexandria:with-gensyms (arg1 arg2 next-sym-p)
(lambda (acc next) `(lambda (,arg1 &optional (,arg2 nil ,next-sym-p))
,@body))))) (if ,next-sym-p
(let ((,two-arg-acc ,arg1)
(,two-arg-next ,arg2))
,@two-arg-body)
(let ((,one-arg-arg ,arg1))
,@one-arg-body)))))
(define-functional-transducer mapping ()
(funcall rf acc (call-function next)))
(define-functional-transducer mv-mapping () (defun mapping (function &rest args)
(funcall rf acc (multiple-value-list (call-function next)))) (flet ((call-function (it)
(apply function it args)))
(lambda (rf)
(transducer-lambda
((acc next)
(funcall rf acc (call-function next)))
((it) (funcall rf it))))))
(define-functional-transducer mv-selecting () (defun mv-mapping (function &rest args)
(multiple-value-bind (value use-p) (call-function next) (flet ((call-function (it)
(if use-p (apply function it args)))
(funcall rf acc value) (lambda (rf)
acc))) (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) (defun hash-table-select (hash-table)
(mv-selecting #'gethash hash-table)) (mv-selecting #'gethash hash-table))
(define-functional-transducer filtering () (defun filtering (function &rest args)
(if (call-function next) (flet ((call-function (it)
(funcall rf acc next) (apply function it args)))
acc)) (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) (defun mv-filtering (function &rest args)
(filtering (lambda (it) (filtering (lambda (it)
@ -61,16 +93,45 @@
(defun deduping (&optional (test 'eql)) (defun deduping (&optional (test 'eql))
(lambda (rf) (lambda (rf)
(let (last) (let (last)
(lambda (acc next) (transducer-lambda
(prog1 (if (funcall test last next) ((acc next)
acc (prog1 (if (or (null last)
(funcall rf acc next)) (funcall test last next))
(setf 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 () (defun catting ()
(lambda (rf) (lambda (rf)
(lambda (acc next) (transducer-lambda
(reduce rf next :initial-value acc)))) ((acc next)
(reduce rf next :initial-value acc))
((it) (funcall rf it)))))
(defun mapcatting (fun)
(data-lens:• (mapping fun)
(catting)))
(defun splitting (&rest functions) (defun splitting (&rest functions)
(let ((splitter (apply #'data-lens:juxt functions))) (let ((splitter (apply #'data-lens:juxt functions)))
@ -82,27 +143,33 @@
(defun taking (n) (defun taking (n)
(lambda (rf) (lambda (rf)
(let ((taken 0)) (let ((taken 0))
(lambda (acc next) (transducer-lambda
(incf taken) ((acc next)
(if (< taken n) (incf taken)
(funcall rf acc next) (if (<= taken n)
(exit-early (funcall rf acc next))))))) (funcall rf acc next)
(exit-early acc)))
((it) (funcall rf it))))))
(defun dropping (n) (defun dropping (n)
(lambda (rf) (lambda (rf)
(let ((taken 0)) (let ((taken 0))
(lambda (acc next) (transducer-lambda
(if (< taken n) ((acc next)
(progn (incf taken) (if (< taken n)
acc) (progn (incf taken)
(funcall rf acc next)))))) acc)
(funcall rf acc next)))
((it) (funcall rf it))))))
(defun transduce (xf build seq) (defun transduce (xf build seq)
(unwrap build (let ((transducer (funcall xf (stepper build))))
(catch 'done (unwrap build
(reduce-generic seq (funcall transducer
(funcall xf (stepper build)) (catch 'done
(init build))))) (reduce-generic seq
transducer
(init build)))))))
(defun eduction (xf seq) (defun eduction (xf seq)
(lambda (build) (lambda (build)
(unwrap (unwrap
@ -115,17 +182,19 @@
(defmethod init ((it (eql 'hash-table-builder))) (defmethod init ((it (eql 'hash-table-builder)))
(make-hash-table)) (make-hash-table))
(defmethod stepper ((it (eql 'hash-table-builder))) (defmethod stepper ((it (eql 'hash-table-builder)))
(lambda (acc next) (transducer-lambda
(destructuring-bind (k v) next ((acc next)
(setf (gethash k acc) v)) (destructuring-bind (k v) next
acc)) (setf (gethash k acc) v))
acc)))
(defmethod init ((it (eql 'vector-builder))) (defmethod init ((it (eql 'vector-builder)))
(make-array 0 :fill-pointer t :adjustable t)) (make-array 0 :fill-pointer t :adjustable t))
(defmethod stepper ((it (eql 'vector-builder))) (defmethod stepper ((it (eql 'vector-builder)))
(lambda (acc next) (transducer-lambda
(vector-push-extend next acc) ((acc next)
acc)) (vector-push-extend next acc)
acc)))
(defmethod init ((it (eql 'list-builder))) (defmethod init ((it (eql 'list-builder)))
(declare (optimize (speed 3))) (declare (optimize (speed 3)))
@ -133,13 +202,14 @@
(coerce (vector it it) (coerce (vector it it)
'(simple-array list (2))))) '(simple-array list (2)))))
(defmethod stepper ((it (eql 'list-builder))) (defmethod stepper ((it (eql 'list-builder)))
(lambda (acc a) (transducer-lambda
(declare (optimize (speed 3)) ((acc a)
(type (simple-array list (2)) acc)) (declare (optimize (speed 3))
(let* ((to-build (elt acc 1))) (type (simple-array list (2)) acc))
(push a (cdr to-build)) (let* ((to-build (elt acc 1)))
(setf (elt acc 1) (cdr to-build))) (push a (cdr to-build))
acc)) (setf (elt acc 1) (cdr to-build)))
acc)))
(defmethod unwrap ((it (eql 'list-builder)) obj) (defmethod unwrap ((it (eql 'list-builder)) obj)
(cdr (elt obj 0))) (cdr (elt obj 0)))