sequences.extras: adding all-subseqs, each-subseq, longest-subseq, and generalized minimum/maximum words.

extra/sequences/extras/extras-tests.factor

@@ -0,0 +1,23 @@
+USING: make sequences sequences.extras tools.test ;
+
+IN: sequences.extras.tests
+
+[ 1 ] [ 1 2 [ ] min-by ] unit-test
+[ 2 ] [ 1 2 [ ] max-by ] unit-test
+[ "12345" ] [ "123" "12345" [ length ] max-by ] unit-test
+[ "123" ] [ "123" "12345" [ length ] min-by ] unit-test
+
+[ 4 ] [ 5 iota [ ] maximum ] unit-test
+[ 0 ] [ 5 iota [ ] minimum ] unit-test
+[ { "foo" } ] [ { { "foo" } { "bar" } } [ first ] maximum ] unit-test
+[ { "bar" } ] [ { { "foo" } { "bar" } } [ first ] minimum ] unit-test
+
+[ { "a" "b" "c" "d" "ab" "bc" "cd" "abc" "bcd" "abcd" } ] [ "abcd" all-subseqs ] unit-test
+
+[ { "a" "ab" "abc" "abcd" "b" "bc" "bcd" "c" "cd" "d" } ]
+[ [ "abcd" [ , ] each-subseq ] { } make ] unit-test
+
+[ "" ] [ "abc" "def" longest-subseq ] unit-test
+[ "abcd" ] [ "abcd" "abcde" longest-subseq ] unit-test
+[ "foo" ] [ "foo" "foobar" longest-subseq ] unit-test
+[ "foo" ] [ "foobar" "foo" longest-subseq ] unit-test

extra/sequences/extras/extras.factor

@@ -1,5 +1,8 @@
-USING: arrays kernel locals math sequences ;
+USING: arrays grouping kernel locals math math.order math.ranges
+sequences ;
+
 IN: sequences.extras
+
 : reduce1 ( seq quot -- result ) [ unclip ] dip reduce ; inline
 
 :: reduce-r
@@ -18,4 +21,48 @@ IN: sequences.extras
 : find-all ( seq quot -- elts ) [ [ length iota ] keep ] dip
     [ dupd call( a -- ? ) [ 2array ] [ 2drop f ] if ] curry 2map [ ] filter ; inline
 
-: insert-sorted ( elt seq -- seq ) 2dup [ < ] with find drop over length or swap insert-nth ;
+: insert-sorted ( elt seq -- seq ) 2dup [ < ] with find drop over length or swap insert-nth ;
+
+: max-by ( obj1 obj2 quot: ( obj -- n ) -- obj1/obj2 )
+    [ bi@ [ max ] keep eq? not ] curry most ; inline
+
+: min-by ( obj1 obj2 quot: ( obj -- n ) -- obj1/obj2 )
+    [ bi@ [ min ] keep eq? not ] curry most ; inline
+
+: maximum ( seq quot: ( ... elt -- ... x ) -- elt )
+    [ keep 2array ] curry
+    [ [ first ] max-by ] map-reduce second ; inline
+
+: minimum ( seq quot: ( ... elt -- ... x ) -- elt )
+    [ keep 2array ] curry
+    [ [ first ] min-by ] map-reduce second ; inline
+
+: all-subseqs ( seq -- seqs )
+    dup length [1,b] [ <clumps> ] with map concat ;
+
+:: each-subseq ( ... seq quot: ( ... x -- ... ) -- ... )
+    seq length [0,b] [
+        :> from
+        from seq length (a,b] [
+            :> to
+            from to seq subseq quot call( x -- )
+        ] each
+    ] each ;
+
+:: longest-subseq ( seq1 seq2 -- subseq )
+    seq1 length :> len1
+    seq2 length :> len2
+    0 :> n!
+    0 :> end!
+    len1 1 + [ len2 1 + 0 <array> ] replicate :> table
+    len1 [1,b] [| x |
+        len2 [1,b] [| y |
+            x 1 - seq1 nth
+            y 1 - seq2 nth = [
+                y 1 - x 1 - table nth nth 1 + :> len
+                len y x table nth set-nth
+                len n > [ len n! x end! ] when
+            ] [ 0 y x table nth set-nth ] if
+        ] each
+    ] each end n - end seq1 subseq ;
+