simplifying quicksort code

diff --git a/library/collections/sequence-sort.factor b/library/collections/sequence-sort.factor
index f1987df448fe5c97763e24f25a012ed615e4dc9e..a5829f6b89fa92c312b51293a4c273e7836f1ba8 100644 (file)
--- a/library/collections/sequence-sort.factor
+++ b/library/collections/sequence-sort.factor
@@ -1,105 +1,59 @@
 IN: sorting-internals
 USING: kernel math sequences ;
 
-TUPLE: iterator n seq ;
-
-: >iterator< dup iterator-n swap iterator-seq ;
-
-: forward ( iterator -- ) dup iterator-n 1 + swap set-iterator-n ;
-
-: backward ( iterator -- ) dup iterator-n 1 - swap set-iterator-n ;
-
-: current ( iterator -- elt ) >iterator< nth ;
-
-: set-current ( elt iterator -- ) >iterator< set-nth ;
-
-: exchange ( iterator iterator -- )
-    #! Exchange elements pointed at by two iterators.
-    over current over current
-    >r swap set-current r> swap set-current ;
-
-: iterators ( iterator iterator -- n n )
-    >r iterator-n r> iterator-n ;
-
-: midpoint ( iterator iterator -- elt )
-    #! Both iterators must point at the same collection.
-    [ iterators + 2 /i ] keep iterator-seq nth ;
-
-TUPLE: partition start start* end end* mid ;
-
-C: partition ( start end -- partition )
-    >r 2dup 2dup r>
-    [ >r midpoint r> set-partition-mid ] keep
-    [ set-partition-end ] keep
-    [ set-partition-start ] keep
-    [ >r clone r> set-partition-end* ] keep
-    [ >r clone r> set-partition-start* ] keep ; inline
-
-: s/e dup partition-start swap partition-end ; inline
-: s*/e dup partition-start* swap partition-end ; inline
-: s/e* dup partition-start swap partition-end* ; inline
-: s*/e* dup partition-start* swap partition-end* ; inline
-
-: seq-partition ( seq -- partition )
-    0 over <iterator> swap dup length 1 - swap <iterator>
-    <partition> ; inline
-
-: compare-step ( quot partition iter -- n )
-    current swap partition-mid rot call ; inline
-
-: partition< ( quot partition -- ? )
-    dup s*/e iterators <
-    [ dup partition-start* compare-step 0 < ]
-    [ 2drop f ] ifte ; inline
-
-: partition> ( quot partition -- ? )
-    dup s/e* iterators <=
-    [ dup partition-end* compare-step 0 > ]
-    [ 2drop f ] ifte ; inline
-
-: sort-up ( quot partition -- )
-    [ partition< ] 2keep rot
-    [ dup partition-start* forward sort-up ] [ 2drop ] ifte ;
-    inline
-
-: sort-down ( quot partition -- )
-    [ partition> ] 2keep rot
-    [ dup partition-end* backward sort-down ] [ 2drop ] ifte ;
-    inline
-
-: keep-sorting? ( partition -- ? ) s*/e* iterators <= ; inline
-
-: sort-step ( quot partition -- )
-    dup keep-sorting? [
-        2dup sort-up 2dup sort-down dup keep-sorting?
-        [ dup s*/e* 2dup exchange backward forward sort-step ]
-        [ 2drop ] ifte
-    ] [
-        2drop
-    ] ifte ; inline
-
-: left ( partition -- partition )
-    dup s/e* iterators < [ s/e* <partition> ] [ drop f ] ifte ;
-    inline
-
-: right ( partition -- partition )
-    dup s*/e iterators < [ s*/e <partition> ] [ drop f ] ifte ;
-    inline
-
-: (nsort) ( quot partition -- )
-    dup keep-sorting? [
-        [ sort-step ] 2keep
-        [ left dup [ (nsort) ] [ 2drop ] ifte ] 2keep
-        right dup [ (nsort) ] [ 2drop ] ifte
+: midpoint ( seq -- elt ) dup length 2 /i swap nth ; inline
+
+TUPLE: sorter seq start end mid ;
+
+C: sorter ( seq start end -- sorter )
+    [ >r 1 + rot <slice> r> set-sorter-seq ] keep
+    dup sorter-seq midpoint over set-sorter-mid
+    dup sorter-seq length 1 - over set-sorter-end
+    0 over set-sorter-start ;
+
+: s*/e* dup sorter-start swap sorter-end ;
+: s*/e dup sorter-start swap sorter-seq length 1 - ;
+: s/e* 0 swap sorter-end ;
+: sorter-exchange dup s*/e* rot sorter-seq exchange ;
+: compare over sorter-seq nth swap sorter-mid rot call ; inline
+: >start> dup sorter-start 1 + swap set-sorter-start ;
+: <end< dup sorter-end 1 - swap set-sorter-end ;
+
+: sort-up ( quot sorter -- quot sorter )
+    dup s*/e < [
+        [ dup sorter-start compare 0 < ] 2keep rot
+        [ dup >start> sort-up ] when 
+    ] when ; inline
+
+: sort-down ( quot sorter -- quot sorter )
+    dup s/e* <= [
+        [ dup sorter-end compare 0 > ] 2keep rot
+        [ dup <end< sort-down ] when
+    ] when ; inline
+
+: sort-step ( quot sorter -- quot sorter )
+    dup s*/e* <= [
+        sort-up sort-down dup s*/e* <= [
+            dup sorter-exchange dup >start> dup <end< sort-step
+        ] when
+    ] when ; inline
+
+DEFER: (nsort)
+
+: (nsort) ( quot seq start end -- )
+    2dup < [
+        <sorter> sort-step
+        [ dup sorter-seq swap s/e* (nsort) ] 2keep
+        [ dup sorter-seq swap s*/e (nsort) ] 2keep
     ] [
         2drop
-    ] ifte ; inline
+    ] ifte 2drop ; inline
 
 IN: sequences
 
 : nsort ( seq quot -- | quot: elt elt -- -1/0/1 )
-    over empty?
-    [ 2drop ] [ swap seq-partition (nsort) ] ifte ; inline
+    swap dup empty?
+    [ 2drop ] [ 0 over length 1 - (nsort) ] ifte ; inline
 
 : sort ( seq quot -- seq | quot: elt elt -- -1/0/1 )
     swap [ swap nsort ] immutable ; inline

diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor
index 65c16585cdba4b300caff5dfcef3602c63fcbdac..9c6fda8ab886d74b75bca84dfead4dd1466254db 100644 (file)
--- a/library/collections/sequences-epilogue.factor
+++ b/library/collections/sequences-epilogue.factor
@@ -221,6 +221,10 @@ M: object reverse ( seq -- seq ) [ <reversed> ] keep like ;
     #! Longest sequence length in a sequence of sequences.
     0 [ length max ] reduce ; flushable
 
+: exchange ( n n seq -- )
+    [ tuck nth >r nth r> ] 3keep tuck
+    >r >r set-nth r> r> set-nth ;
+
 IN: kernel
 
 : depth ( -- n )

diff --git a/library/test/sequences.factor b/library/test/sequences.factor
index 70f7b361c5665373ebe42d08155831fdf13fb84c..b37ecfb3a3ca7802d8dc1a4665faf8fdba91c3b9 100644 (file)
--- a/library/test/sequences.factor
+++ b/library/test/sequences.factor
@@ -1,5 +1,6 @@
 IN: temporary
-USING: kernel lists math sequences strings test vectors ;
+USING: kernel lists math sequences sorting-internals strings
+test vectors ;
 
 [ { 1 2 3 4 } ] [ 1 5 <range> >vector ] unit-test
 [ 3 ] [ 1 4 <range> length ] unit-test
@@ -113,6 +114,50 @@ unit-test
 [ t ] [ { 1 2 3 } [ 1 2 3 ] sequence= ] unit-test
 [ f ] [ [ ] [ 1 2 3 ] sequence= ] unit-test
 
+[ { 1 3 2 4 } ] [ { 1 2 3 4 } clone 1 2 pick exchange ] unit-test
+
+[ 3 ] [ { 1 2 3 4 } midpoint ] unit-test
+
+: seq-sorter 0 over length 1 - <sorter> ;
+
+[ { 4 2 3 1 } ]
+[ { 1 2 3 4 } clone dup seq-sorter sorter-exchange ] unit-test
+
+[ -1 ] [ [ - ] { 1 2 3 4 } seq-sorter 1 compare ] unit-test
+
+[ 1 ] [ [ - ] { -5 4 -3 5 } seq-sorter sort-up sorter-start nip ] unit-test
+
+[ 3 ] [ [ - ] { -5 4 -3 -6 5 } seq-sorter sort-down sorter-end nip ] unit-test
+
+[ { 1 2 3 4 5 6 7 8 9 } ] [
+    [ - ] { 9 8 7 6 5 4 3 2 1 } clone seq-sorter sort-step
+    sorter-seq >vector nip
+] unit-test
+
+[ { 1 2 3 4 5 6 7 8 9 } ] [
+    [ - ] { 1 2 3 4 5 6 7 8 9 } clone seq-sorter sort-step
+    sorter-seq >vector nip
+] unit-test
+
 [ [ ] ] [ [ ] [ - ] sort ] unit-test
-[ [ "2 + 2" ] ] [ [ "2 + 2" ] [ lexi ] sort ] unit-test
-[ [ 1 2 3 4 5 6 7 ] ] [ [ 6 4 5 7 2 1 3 ] [ - ] sort ] unit-test
+
+: pairs ( seq quot -- )
+    swap dup length 1 - [
+        [ 2dup 1 + swap nth >r swap nth r> rot call ] 3keep
+    ] repeat 2drop ;
+
+: map-pairs ( seq quot -- seq | quot: elt -- elt )
+    over [
+        length 1 - <vector> rot
+        [ 2swap [ slip push ] 2keep ] pairs nip
+    ] keep like ; inline
+    
+: sorted? ( seq quot -- ? )
+    map-pairs [ 0 <= ] all? ;
+
+[ t ] [
+    10 [
+        drop
+        1000 [ drop 0 1000 random-int ] map [ - ] sort [ - ] sorted?
+    ] all?
+] unit-test