[><]: Extend >< to map input sequence.

qi-doc/scribblings/forms.scrbl

@@ -650,7 +650,7 @@ A form of generalized @racket[sieve], passing all the inputs that satisfy each
 @defform[#:link-target? #f
          (amp flo)]
 )]{
-  The flow analogue to @racket[map], this maps each input individually under @racket[flo]. As flows may generate any number of output values, unlike @racket[map], the number of outputs need not equal the number of inputs here.
+  The flow analogue to @racket[map], this maps the input sequence according to the procedure arity (prefer the least arity other than @racket[0]) of @racket[flo]. As flows may generate any number of output values, unlike @racket[map], the number of outputs need not equal the number of inputs here.
 
   If used in identifier form simply as @racket[><], it treats the first input as @racket[flo].
 
@@ -659,6 +659,15 @@ A form of generalized @racket[sieve], passing all the inputs that satisfy each
     ((☯ (>< sqr)) 1 2 3)
     ((☯ ><) sqr 1 2 3)
     ((☯ (>< (-< _ _))) 1 2 3)
+    ((☯ (>< 1)))
+    ((☯ (>< (esc (λ () 1)))))
+    ((☯ (>< (esc (case-lambda [(_) (add1 _)] [_ #f])))))
+    ((☯ (>< (esc (case-lambda [(_) (add1 _)] [_ #f])))) 1 2 3)
+    (~> ('k1 "v1" 'k2 "v2") (>< cons) ▽ make-immutable-hash)
+    (~> (1 2 1)
+        (>< (-< _ _))
+        (-< 0 _ 0)
+        (>< (esc (procedure-reduce-arity + 2))))
   ]
 }
 
@@ -692,7 +701,7 @@ A form of generalized @racket[sieve], passing all the inputs that satisfy each
 
 @examples[
     #:eval diagram-eval
-	#:result-only
+    #:result-only
     (set-curve-pict-size 200 200)
     (current-label-gap (px 8))
 

qi-lib/flow/impl.rkt

@@ -119,10 +119,44 @@
     (f args)))
 
 (define (~map f vs)
-  (match vs
-    ['() null]
-    [(cons v vs) (append (values->list (f v))
-                         (~map f vs))]))
+  (define-values (arity 0?)
+    (match (procedure-arity f)
+      [0 (values 0 #t)]
+      [(? exact-positive-integer? n) (values n #f)]
+      [(arity-at-least 0) (values 1 #f)] ; (~> () (>< 1) ▽) should return '().
+      [(arity-at-least n) (values n #f)]
+      [(list* 0 1 _) (values 1 #f)]
+      [(list* 0 (or (arity-at-least n) n) _) (values n #t)]
+      [(list* n _) (values n #f)]))
+  (cond
+    [(and 0? (null? vs)) (values->list (f))]
+    [(zero? (remainder (length vs) arity))
+     (case arity
+       [(1)
+        (let loop ([vs vs])
+          (match vs
+            ['() '()]
+            [(list* v0 vs)
+             (append (values->list (f v0))
+                     (loop vs))]))]
+       [(2)
+        (let loop ([vs vs])
+          (match vs
+            ['() '()]
+            [(list* v0 v1 vs)
+             (append (values->list (f v0 v1))
+                     (loop vs))]))]
+       [else
+        (let loop ([vs vs])
+          (cond
+            [(null? vs) '()]
+            [else
+             (define-values (vs0 vs*) (split-at vs arity))
+             (append (values->list (apply f vs0))
+                     (loop vs*))]))])]
+    [else (raise-arguments-error
+           '~map (format "needs ~ax values" arity)
+           "given" vs)]))
 
 (define (map-values f . args)
   (apply values (~map f args)))

qi-test/tests/flow.rkt

@@ -1193,7 +1193,38 @@
      (check-equal? ((☯ (~> (amp sqr) ▽))
                     3 5)
                    (list 9 25)
-                   "named amplification form"))
+                   "named amplification form")
+     (test-suite
+      "mapping sequence"
+      (check-equal? ((☯ (~> (>< 1) ▽))) '())
+      (check-equal? ((☯ (~> (>< (esc (λ () 1))) ▽))) '(1))
+      (check-equal? ((☯ (~> (>< (esc (case-lambda [(_) (add1 _)] [_ #f]))) ▽))) '())
+      (check-equal? ((☯ (~> (>< (esc (case-lambda [(_) (add1 _)] [_ #f]))) ▽)) 1 2 3) '(2 3 4))
+      (check-equal? ((☯ (~> (>< (esc (λ () 1))) ▽))) '(1))
+      (check-equal? ((☯ (~> (>< cons) ▽ make-immutable-hash))
+                     'k1 "v1"
+                     'k2 "v2")
+                    (hash
+                     'k1 "v1"
+                     'k2 "v2"))
+      (check-equal? ((☯
+                      (~> (>< (-< _ _))
+                          (-< 0 _ 0)
+                          (>< (esc (procedure-reduce-arity + 2)))
+                          ▽))
+                     1 2 1)
+                    '(1 3 3 1))
+      (check-equal? ((☯ (~> (>< member) ▽))
+                     1 '(1 2 3)
+                     2 '(a b c))
+                    '((1 2 3) #f))
+      (check-equal? ((☯ (~> (>< /) ▽)) 1 2 3)
+                    '(1 1/2 1/3))
+      (check-equal? ((☯ (~> >< ▽))
+                     cons
+                     1 2
+                     3 4)
+                    '((1 . 2) (3 . 4)))))
     (test-suite
      "pass"
      (check-equal? ((☯ (~> pass ▽))