From: nomennescio Date: Sat, 4 May 2024 17:45:21 +0000 (+0100) Subject: Revert "sequences.product: faster product iteration." X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;ds=sidebyside Revert "sequences.product: faster product iteration." This reverts commit 136836f8b0bc7adb75e5512f4e58cb773478582d. --- diff --git a/basis/sequences/product/product-tests.factor b/basis/sequences/product/product-tests.factor index 543b69e233..7b3ca557ad 100644 --- a/basis/sequences/product/product-tests.factor +++ b/basis/sequences/product/product-tests.factor @@ -2,30 +2,20 @@ ! See https://factorcode.org/license.txt for BSD license. USING: arrays kernel make math sequences sequences.product tools.test ; -{ { { 0 "a" } { 0 "b" } { 1 "a" } { 1 "b" } { 2 "a" } { 2 "b" } } } +{ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } } [ { { 0 1 2 } { "a" "b" } } >array ] unit-test -{ { "a" "b" "aa" "bb" "aaa" "bbb" } } +{ { "a" "aa" "aaa" "b" "bb" "bbb" } } [ { { 1 2 3 } { "a" "b" } } [ first2 concat ] product-map ] unit-test { { - { 0 "a" t } - { 0 "a" f } - { 0 "b" t } - { 0 "b" f } - { 1 "a" t } - { 1 "a" f } - { 1 "b" t } - { 1 "b" f } - { 2 "a" t } - { 2 "a" f } - { 2 "b" t } - { 2 "b" f } + { 0 "a" t } { 1 "a" t } { 2 "a" t } { 0 "b" t } { 1 "b" t } { 2 "b" t } + { 0 "a" f } { 1 "a" f } { 2 "a" f } { 0 "b" f } { 1 "b" f } { 2 "b" f } } } [ { { 0 1 2 } { "a" "b" } { t f } } [ ] product-map ] unit-test -{ "a1a2b1b2c1c2" } [ +{ "a1b1c1a2b2c2" } [ [ { { "a" "b" "c" } { "1" "2" } } [ [ % ] each ] product-each diff --git a/basis/sequences/product/product.factor b/basis/sequences/product/product.factor index 0a4f703d68..a1ca1a5047 100644 --- a/basis/sequences/product/product.factor +++ b/basis/sequences/product/product.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Joe Groff. ! See https://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs combinators.short-circuit kernel -math sequences sequences.private ; +USING: accessors arrays assocs kernel math sequences +sequences.private typed ; IN: sequences.product TUPLE: product-sequence @@ -17,79 +17,74 @@ M: product-sequence length lengths>> product ; [ /mod ] map nip ; inline +TYPED: product-ns ( n lengths: array -- ns ) + [ /mod ] map nip ; -: product-nths ( ns seqs -- nths ) - [ nth-unsafe ] { } 2map-as ; inline +TYPED: product-nths ( ns: array seqs -- nths ) + [ nth-unsafe ] { } 2map-as ; -PRIVATE> +: product@ ( n product-sequence -- ns seqs ) + [ lengths>> product-ns ] [ nip sequences>> ] 2bi ; -M: product-sequence nth - [ lengths>> product-ns ] [ sequences>> product-nths ] bi ; +:: (carry-n) ( ns lengths i j -- ) + i 1 + j = [ + i ns nth-unsafe i lengths nth-unsafe = [ + 0 i ns set-nth-unsafe + ns lengths i 1 + + dup ns [ 1 + ] change-nth-unsafe + j (carry-n) + ] when + ] unless ; inline recursive -fixnum-strict (carry-n) ; inline -: product-length ( sequences -- length ) - [ length ] [ * ] map-reduce integer>fixnum-strict ; inline +: product-iter ( ns lengths -- ) + [ 0 over [ 1 + ] change-nth-unsafe ] dip carry-ns ; inline -:: (product-each) ( ... ns sequences k quot: ( ... seq -- ... ) -- ... ) - k sequences length 1 - = :> done? - k sequences nth-unsafe [ - k ns set-nth-unsafe - ns done? quot [ - sequences k 1 + quot (product-each) - ] if - ] each ; inline recursive +: start-product-iter ( sequences -- ns lengths ) + [ length 0 ] [ [ length ] map ] bi ; inline + +: end-product-iter? ( ns lengths -- ? ) + [ last-unsafe ] same? ; inline + +: product-length ( sequences -- length ) + [ length ] [ * ] map-reduce ; inline PRIVATE> +M: product-sequence nth + product@ product-nths ; + :: product-each ( ... sequences quot: ( ... seq -- ... ) -- ... ) - sequences [ empty? ] any? [ - sequences length f - sequences >array 0 quot (product-each) + sequences start-product-iter :> ( ns lengths ) + lengths [ 0 = ] any? [ + [ ns lengths end-product-iter? ] + [ ns sequences product-nths quot call ns lengths product-iter ] until ] unless ; inline :: product-map-as ( ... sequences quot: ( ... seq -- ... value ) exemplar -- ... sequence ) - sequences >array :> sequences - 0 sequences product-length exemplar + 0 :> i! + sequences product-length exemplar [| result | - sequences - [ clone swap quot dip [ result set-nth-unsafe ] [ 1 + ] bi ] - product-each + sequences [ quot call i result set-nth-unsafe i 1 + i! ] product-each result - ] new-like nip ; inline + ] new-like ; inline : product-map ( ... sequences quot: ( ... seq -- ... value ) -- ... sequence ) over product-map-as ; inline -: all-products ( sequences -- sequences ) - [ ] product-map ; - :: product-map>assoc ( ... sequences quot: ( ... seq -- ... key value ) exemplar -- ... assoc ) - 0 sequences product-length { } + 0 :> i! + sequences product-length { } [| result | - sequences - [ clone swap [ quot call 2array ] dip [ result set-nth-unsafe ] [ 1 + ] bi ] - product-each + sequences [ quot call 2array i result set-nth-unsafe i 1 + i! ] product-each result - ] new-like exemplar assoc-like nip ; inline - - done? - k sequences nth-unsafe [ - k ns set-nth-unsafe - ns done? quot [ - sequences k 1 + quot (product-find) - ] if - ] find drop ; inline recursive - -PRIVATE> + ] new-like exemplar assoc-like ; inline :: product-find ( ... sequences quot: ( ... seq -- ... ? ) -- ... sequence ) - sequences { [ empty? ] [ [ empty? ] any? ] } 1|| [ f ] [ - sequences length f - [ sequences >array 0 quot (product-find) ] keep and + sequences start-product-iter :> ( ns lengths ) + lengths [ 0 = ] any? [ f ] [ + f [ ns lengths end-product-iter? over or ] + [ drop ns sequences product-nths quot keep and ns lengths product-iter ] until ] if ; inline