core: use copy in sorting

diff --git a/core/growable/growable.factor b/core/growable/growable.factor
index 05ed40c92f69d2424b379ac07ae2490393b6bd88..68c6678fae520a82fdb20406f44c53c4648f6d14 100644 (file)
--- a/core/growable/growable.factor
+++ b/core/growable/growable.factor
@@ -19,10 +19,6 @@ M: growable set-nth-unsafe underlying>> set-nth-unsafe ; inline
     [ length integer>fixnum-strict ] keep
     [ set-nth-unsafe ] [ [ 1 fixnum+fast ] dip length<< ] 2bi ; inline
 
-: push-all-unsafe ( from to src dst -- )
-    [ over - swap ] 2dip pickd [ length integer>fixnum-strict ] keep
-    [ [ fixnum+fast ] dip length<< ] 2keep <copier> (copy) drop ; inline
-
 PRIVATE>
 
 : capacity ( seq -- n ) underlying>> length ; inline

diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor
index ce5291fe9cbd5602e736ee9c447e65661aab8e60..f3d81822aec8f6556343ba449b572403e691bc5e 100644 (file)
--- a/core/sequences/sequences-docs.factor
+++ b/core/sequences/sequences-docs.factor
@@ -2139,7 +2139,6 @@ ARTICLE: "sequences-combinator-implementation" "Implementing sequence combinator
 { $subsections
     collector
     collector-as
-    collector-for-as
 }
 "Creating a new sequence conditionally:"
 { $subsections

diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 9610d4cd33c094810de0c2d6ad5487713111bcb7..ed39ba81a3a29ad336c575b25fb57fab9ac6b309 100644 (file)
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -15,11 +15,13 @@ GENERIC: new-resizable ( len seq -- newseq ) flushable
 GENERIC: like ( seq exemplar -- newseq ) flushable
 GENERIC: clone-like ( seq exemplar -- newseq ) flushable
 
+: lengthd ( seq obj -- n obj ) [ length ] dip ; inline
+
 : new-sequence-like ( len-exemplar type-exemplar -- newseq )
-    [ length ] dip new-sequence ; inline
+    lengthd new-sequence ; inline
 
 : new-resizable-like ( len-exemplar type-exemplar -- newseq )
-    [ length ] dip new-resizable ; inline
+    lengthd new-resizable ; inline
 
 : new-like ( len exemplar quot -- seq )
     over [ [ new-sequence ] dip call ] dip like ; inline
@@ -32,6 +34,16 @@ GENERIC: shorten ( n seq -- )
 M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ; inline
 M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; inline
 
+GENERIC#: seq-lengthen 1 ( seq n -- seq )
+GENERIC#: seq-shorten 1 ( seq n -- seq )
+
+: seq-set-length ( seq n -- seq ) [ swap set-length ] keepd ; inline
+: seq-nth ( seq n -- elt ) swap nth ; inline
+: seq-set-nth ( seq n elt -- seq ) swap rot [ set-nth ] keep ; inline
+
+M: sequence seq-lengthen 2dup lengthd < [ seq-set-length ] [ drop ] if ; inline
+M: sequence seq-shorten 2dup lengthd > [ seq-set-length ] [ drop ] if ; inline
+
 : 2length ( seq1 seq2 -- n1 n2 ) [ length ] bi@ ; inline
 : 3length ( seq1 seq2 seq3 -- n1 n2 n3 ) [ length ] tri@ ; inline
 
@@ -57,6 +69,8 @@ M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; inline
 
 : push ( elt seq -- ) [ length ] [ set-nth ] bi ;
 
+: seq-push ( seq elt -- seq ) [ dup length ] dip seq-set-nth ;
+
 ERROR: bounds-error index seq ;
 
 GENERIC#: bounds-check? 1 ( n seq -- ? )
@@ -64,9 +78,17 @@ GENERIC#: bounds-check? 1 ( n seq -- ? )
 M: integer bounds-check?
     dupd length < [ 0 >= ] [ drop f ] if ; inline
 
+GENERIC: seq-bounds-check? ( seq n -- ? )
+
+M: integer seq-bounds-check?
+    tuck lengthd > [ 0 >= ] [ drop f ] if ; inline
+
 : bounds-check ( n seq -- n seq )
     2dup bounds-check? [ bounds-error ] unless ; inline
 
+: seq-bounds-check ( seq n -- seq n )
+    2dup seq-bounds-check? [ swap bounds-error ] unless ; inline
+
 MIXIN: immutable-sequence
 
 ERROR: immutable element index sequence ;
@@ -97,9 +119,16 @@ M: sequence set-nth bounds-check set-nth-unsafe ; inline
 M: sequence nth-unsafe nth ; inline
 M: sequence set-nth-unsafe set-nth ; inline
 
+: seq-nth-unsafe ( seq n -- elt ) swap nth-unsafe ; inline
+
+: seq-set-nth-unsafe ( seq n elt -- seq ) swap pick set-nth-unsafe ; inline
+
 : change-nth-unsafe ( i seq quot -- )
     [ [ nth-unsafe ] dip call ] 2keepd set-nth-unsafe ; inline
 
+: change-seq-nth-unsafe ( seq i quot -- seq )
+    [ [ seq-nth-unsafe ] dip call ] 2keepd rot seq-set-nth-unsafe ; inline
+
 PRIVATE>
 
 ! The f object supports the sequence protocol trivially
@@ -316,11 +345,24 @@ C: <copier> copier
     [ [ src-i>> + ] [ src>> ] bi nth-unsafe ]
     [ [ dst-i>> + ] [ dst>> ] bi set-nth-unsafe ] 2bi ; inline
 
+: copy-seq-nth-unsafe ( dst dst-i src src-i -- )
+    seq-nth-unsafe seq-set-nth-unsafe drop ; inline
+
 : (copy) ( n copy -- dst )
     over 0 <= [ nip dst>> ] [
         [ 1 - ] dip [ copy-nth-unsafe ] [ (copy) ] 2bi
     ] if ; inline recursive
 
+: seq-copy-loop ( dst dst-i src src-i src-stop -- dst )
+    2dup >= [
+        4drop
+    ] [
+        [
+            [ copy-seq-nth-unsafe ] 4keep
+            [ 1 + ] 2dip 1 +
+        ] dip seq-copy-loop
+    ] if ; inline recursive
+
 : subseq>copy ( from to seq -- n copy )
     [ over - check-length swap ] dip
     3dup nip new-sequence 0 swap <copier> ; inline
@@ -328,13 +370,18 @@ C: <copier> copier
 : bounds-check-head ( n seq -- n seq )
     over 0 < [ bounds-error ] when ; inline
 
-: check-copy ( src n dst -- src n dst )
-    3dup bounds-check-head
-    [ swap length + ] dip lengthen ; inline
+: check-grow-copy ( dst n src -- dst src n )
+    over [ lengthd + lengthen ] 2keep ; inline
+
+: seq-grow-copy ( dst n -- dst dst-n )
+    [ over length + seq-lengthen ] keep 1 - ; inline
 
 : copy-unsafe ( src i dst -- )
     [ [ length check-length 0 ] keep ] 2dip <copier> (copy) drop ; inline
 
+: seq-copy-unsafe ( dst dst-i src -- dst )
+    0 over length check-length seq-copy-loop ; inline
+
 : subseq-unsafe-as ( from to seq exemplar -- subseq )
     [ subseq>copy (copy) ] dip like ; inline
 
@@ -361,7 +408,12 @@ PRIVATE>
 
 : but-last ( seq -- headseq ) 1 head* ;
 
-: copy ( src i dst -- ) check-copy copy-unsafe ; inline
+: copy ( src i dst -- )
+    3dup bounds-check-head
+    [ swap length + ] dip lengthen
+    copy-unsafe ; inline
+
+: seq-copy ( dst dst-n src -- dst ) check-grow-copy seq-copy-unsafe ; inline
 
 M: sequence clone-like
     dupd new-sequence-like [ 0 swap copy-unsafe ] keep ; inline
@@ -370,6 +422,8 @@ M: immutable-sequence clone-like like ; inline
 
 : push-all ( src dst -- ) [ length ] [ copy ] bi ; inline
 
+: seq-push-all ( dst src -- dst ) [ length seq-grow-copy ] keep seq-copy-unsafe ; inline
+
 <PRIVATE
 
 : (append) ( seq1 seq2 accum -- accum )
@@ -377,8 +431,17 @@ M: immutable-sequence clone-like like ; inline
     [ 0 swap copy-unsafe ]
     [ ] tri ; inline
 
+: (seq-append) ( accum seq1 seq2 -- accum )
+    [
+        [ 0 ] dip [ seq-copy-unsafe ] [ length ] bi
+    ] dip seq-copy-unsafe ; inline
+
 PRIVATE>
 
+: seq-append-as ( seq1 seq2 exemplar -- newseq )
+    [ 2dup 2length + ] dip
+    [ -rot (seq-append) ] new-like ; inline
+
 : append-as ( seq1 seq2 exemplar -- newseq )
     [ 2dup 2length + ] dip
     [ (append) ] new-like ; inline
@@ -639,15 +702,9 @@ PRIVATE>
 : partition ( ... seq quot: ( ... elt -- ... ? ) -- ... trueseq falseseq )
     over [ 2selector [ each ] 2dip ] dip [ like ] curry bi@ ; inline
 
-: collector-for-as ( seq quot exemplar -- seq quot' vec )
-    overd new-resizable-like [ [ push ] curry compose ] keep ; inline
-
 : collector-as ( quot exemplar -- quot' vec )
     dup new-resizable-like [ [ push ] curry compose ] keep ; inline
 
-: collector-for ( seq quot -- seq quot' vec )
-    V{ } collector-for-as ; inline
-
 : collector ( quot -- quot' vec )
     V{ } collector-as ; inline
 

diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor
index 446a2a0969223fe5a66e5146114a6289b4b7f5af..398fbd79cfadfaf940ada9f0b80f63b0288c0808 100644 (file)
--- a/core/sorting/sorting.factor
+++ b/core/sorting/sorting.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
-! See https://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs growable.private hashtables
-kernel kernel.private math math.order sequences
-sequences.private vectors ;
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators growable.private
+hashtables kernel kernel.private math math.order math.private
+sequences sequences.private vectors ;
 IN: sorting
 
 ! Optimized merge-sort:
@@ -33,12 +33,20 @@ TUPLE: merge-state
 : r-done? ( merge -- ? ) [ from2>> ] [ to2>> ] bi eq? ; inline
 
 : dump-l ( merge -- )
-    [ [ from1>> ] [ to1>> ] [ seq>> ] tri ] [ accum>> ] bi
-    push-all-unsafe ; inline
+    {
+        [ accum>> ]
+        [ [ to1>> ] [ from1>> fixnum-fast ] [ accum>> length integer>fixnum-strict ] tri [ fixnum+fast >>length ] 2keep ]
+        [ seq>> ]
+        [ from1>> roll dupd fixnum+fast ]
+    } cleave seq-copy-loop drop ; inline
 
 : dump-r ( merge -- )
-    [ [ from2>> ] [ to2>> ] [ seq>> ] tri ] [ accum>> ] bi
-    push-all-unsafe ; inline
+    {
+        [ accum>> ]
+        [ [ to2>> ] [ from2>> fixnum-fast ] [ accum>> length integer>fixnum-strict ] tri [ fixnum+fast >>length ] 2keep ]
+        [ seq>> ]
+        [ from2>> roll dupd fixnum+fast ]
+    } cleave seq-copy-loop drop ; inline
 
 : l-next ( merge -- )
     [ l-elt ] [ [ 1 + ] change-from1 accum>> ] bi push-unsafe ; inline