Added layer-aggregator-constructor function to the algorithms meta le…

…vel.
sirherrbatka · Jun 3, 2022 · c95ea03 · c95ea03
1 parent 958d14c
commit c95ea03
Show file tree

Hide file tree

Showing 4 changed files with 35 additions and 20 deletions.
diff --git a/src/algorithms/distinct.lisp b/src/algorithms/distinct.lisp
@@ -135,27 +135,39 @@
         :original-range range))
 
 
+(defmethod cl-ds.alg.meta:layer-aggregator-constructor ((function distinct-function)
+                                                        outer-fn
+                                                        arguments)
+  (let ((distinct-key (ensure-function (getf arguments :key #'identity)))
+        (original (getf arguments :seen)))
+    (cl-ds.utils:cases ((:variant (eq distinct-key #'identity)))
+      (cl-ds.alg.meta:let-aggregator ((inner (cl-ds.alg.meta:call-constructor outer-fn))
+                                      (seen (if original
+                                                (cl-ds:replica original)
+                                                (cl-ds.dicts.hamt:make-mutable-hamt-dictionary
+                                                 (getf arguments :hash-function #'sxhash)
+                                                 (getf arguments :test #'eql)))))
+
+          ((element)
+            (let ((selected (funcall distinct-key element)))
+              (cl-ds:mod-bind (dict found) (cl-ds:add! seen selected t)
+                (unless found
+                  (cl-ds.alg.meta:pass-to-aggregation inner element)))))
+
+          ((cl-ds.alg.meta:extract-result inner))))))
+
+
 (defmethod cl-ds.alg.meta:aggregator-constructor ((range distinct-proxy)
                                                   outer-constructor
                                                   (function aggregation-function)
                                                   (arguments list))
   (declare (optimize (speed 3) (safety 0) (debug 0) (space 0) (compilation-speed 0)))
   (bind (((:slots %key %seen) range)
-         (distinct-key (ensure-function %key))
-         (outer-fn (call-next-method))
-         (seen %seen))
+         (outer-fn (call-next-method)))
     (cl-ds.alg.meta:aggregator-constructor
      (read-original-range range)
-     (cl-ds.utils:cases ((:variant (eq distinct-key #'identity)))
-       (cl-ds.alg.meta:let-aggregator ((inner (cl-ds.alg.meta:call-constructor outer-fn))
-                                       (seen (cl-ds:replica seen nil)))
-
-           ((element)
-             (let ((selected (funcall distinct-key element)))
-               (cl-ds:mod-bind (dict found) (cl-ds:add! seen selected t)
-                 (unless found
-                   (cl-ds.alg.meta:pass-to-aggregation inner element)))))
-
-           ((cl-ds.alg.meta:extract-result inner))))
+     (cl-ds.alg.meta:layer-aggregator-constructor #'distinct
+                                                  outer-fn
+                                                  (list :seen %seen :key %key))
      function
      arguments)))
diff --git a/src/algorithms/meta/generics.lisp b/src/algorithms/meta/generics.lisp
@@ -66,6 +66,8 @@ Range function invokaction protocol.
             (function aggregation-function) (arguments list))
     outer-constructor))
 
+(defgeneric layer-aggregator-constructor (function outer-constructor arguments))
+
 (defmacro call-constructor (constructor)
   `(the aggregator (funcall (the function ,constructor))))
 

diff --git a/src/algorithms/package.lisp b/src/algorithms/package.lisp
@@ -16,6 +16,7 @@
    #:apply-aggregation-function-with-aggregator
    #:apply-layer
    #:apply-range-function
+   #:layer-aggregator-constructor
    #:construct-aggregator
    #:define-aggregation-function
    #:extract-result

diff --git a/src/file-system/unix.lisp b/src/file-system/unix.lisp
@@ -16,15 +16,15 @@
   t)
 
 
-(defmethod open-stream-designator ((designator command))
-  (~> designator read-command-string
-      (uiop:launch-program :output :stream :force-shell nil)
-      uiop/launch-program:process-info-output))
-
-
 (defun command (format-control-string &rest format-arguments)
   (declare (dynamic-extent format-arguments))
   (check-type format-control-string string)
   (make 'command
         :command-string (apply #'format nil
                                format-control-string format-arguments)))
+
+
+(defmethod open-stream-designator ((designator command))
+  (~> designator read-command-string
+      (uiop:launch-program :output :stream :force-shell nil)
+      uiop/launch-program:process-info-output))