simplifying quicksort code
Slava Pestov
parent
4a6900af6a
commit
beca0f9615
|
|
@ -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 <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 ;
|
||||
|
||||
: 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 ;
|
||||
: <end< dup sorter-end 1 - swap set-sorter-end ;
|
||||
|
||||
: current ( iterator -- elt ) >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 <end< sort-down ] when
|
||||
] when ; inline
|
||||
|
||||
: exchange ( iterator iterator -- )
|
||||
#! Exchange elements pointed at by two iterators.
|
||||
over current over current
|
||||
>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 <end< sort-step
|
||||
] when
|
||||
] when ; inline
|
||||
|
||||
: iterators ( iterator iterator -- n n )
|
||||
>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 <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
|
||||
: (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
|
||||
|
||||
: 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
|
||||
] [
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue