From beca0f961557aa55f82c2b580e82d121c543ea98 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 22 Aug 2005 05:17:08 +0000 Subject: [PATCH] simplifying quicksort code --- library/collections/sequence-sort.factor | 124 ++++++------------ library/collections/sequences-epilogue.factor | 4 + library/test/sequences.factor | 51 ++++++- 3 files changed, 91 insertions(+), 88 deletions(-) diff --git a/library/collections/sequence-sort.factor b/library/collections/sequence-sort.factor index f1987df448..a5829f6b89 100644 --- 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 ; +: midpoint ( seq -- elt ) dup length 2 /i swap nth ; inline -: >iterator< dup iterator-n swap iterator-seq ; +TUPLE: sorter seq start end mid ; -: forward ( iterator -- ) dup iterator-n 1 + swap set-iterator-n ; +C: sorter ( seq start end -- sorter ) + [ >r 1 + rot 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 ; -: backward ( iterator -- ) dup iterator-n 1 - swap set-iterator-n ; +: 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 ; +: iterator< nth ; +: sort-up ( quot sorter -- quot sorter ) + dup s*/e < [ + [ dup sorter-start compare 0 < ] 2keep rot + [ dup >start> sort-up ] when + ] when ; inline -: set-current ( elt iterator -- ) >iterator< set-nth ; +: sort-down ( quot sorter -- quot sorter ) + dup s/e* <= [ + [ dup sorter-end compare 0 > ] 2keep rot + [ dup r swap set-current r> swap set-current ; +: sort-step ( quot sorter -- quot sorter ) + dup s*/e* <= [ + sort-up sort-down dup s*/e* <= [ + dup sorter-exchange dup >start> dup r iterator-n r> iterator-n ; +DEFER: (nsort) -: 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 swap dup length 1 - swap - ; 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 +: (nsort) ( quot seq start end -- ) + 2dup < [ + sort-step + [ dup sorter-seq swap s/e* (nsort) ] 2keep + [ dup sorter-seq swap s*/e (nsort) ] 2keep ] [ 2drop - ] ifte ; inline - -: left ( partition -- partition ) - dup s/e* iterators < [ s/e* ] [ drop f ] ifte ; - inline - -: right ( partition -- partition ) - dup s*/e iterators < [ s*/e ] [ drop f ] ifte ; - inline - -: (nsort) ( quot partition -- ) - dup keep-sorting? [ - [ sort-step ] 2keep - [ left dup [ (nsort) ] [ 2drop ] ifte ] 2keep - right dup [ (nsort) ] [ 2drop ] ifte - ] [ - 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 65c16585cd..9c6fda8ab8 100644 --- a/library/collections/sequences-epilogue.factor +++ b/library/collections/sequences-epilogue.factor @@ -221,6 +221,10 @@ M: object reverse ( seq -- seq ) [ ] 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 70f7b361c5..b37ecfb3a3 100644 --- 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 >vector ] unit-test [ 3 ] [ 1 4 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 - ; + +[ { 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 - 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