Paste: binary chop
| Author: | Arrogant |
|---|
| Mode: | factor |
|---|
| Date: | Sat, 21 Aug 2010 19:38:53 |
|---|
Plain Text |
USING: kernel sequences math math.functions math.order accessors combinators ;
IN: binary-chop
: bisect-slice ( seq -- slice slice )
dup length 2 /
[ ceiling head-slice ] [ ceiling tail-slice ] 2bi
;
DEFER: chop
: check-right ( seq int -- int )
swap [ drop -1 ] [
swap [ dup first ] dip [ <=> ] keep swap
{
{ +gt+ [ drop drop -1 ] }
{ +lt+ [ [ rest-slice ] dip chop ] }
[ drop drop from>> ]
} case
] if-empty
;
: check-left ( seq int -- int )
swap [ drop -1 ] [
swap [ dup last ] dip [ <=> ] keep swap
{
{ +gt+ [ [ but-last-slice ] dip chop ] }
{ +lt+ [ drop drop -1 ] }
[ drop drop to>> 1 - ]
} case
] if-empty
;
: chop ( seq int -- int )
[ bisect-slice ] dip
[ check-right ] keep
swap dup -1 = [ drop check-left ] [ [ drop drop ] dip ] if
;
USING: binary-chop tools.test ;
IN: binary-chop.tests
[ -1 ] [ { } 3 chop ] unit-test
[ -1 ] [ { 1 } 3 chop ] unit-test
[ 0 ] [ { 1 } 1 chop ] unit-test
[ 0 ] [ { 1 3 5 } 1 chop ] unit-test
[ 1 ] [ { 1 3 5 } 3 chop ] unit-test
[ 2 ] [ { 1 3 5 } 5 chop ] unit-test
[ -1 ] [ { 1 3 5 } 0 chop ] unit-test
[ -1 ] [ { 1 3 5 } 2 chop ] unit-test
[ -1 ] [ { 1 3 5 } 4 chop ] unit-test
[ -1 ] [ { 1 3 5 } 6 chop ] unit-test
[ 0 ] [ { 1 3 5 7 } 1 chop ] unit-test
[ 1 ] [ { 1 3 5 7 } 3 chop ] unit-test
[ 2 ] [ { 1 3 5 7 } 5 chop ] unit-test
[ 3 ] [ { 1 3 5 7 } 7 chop ] unit-test
[ -1 ] [ { 1 3 5 7 } 0 chop ] unit-test
[ -1 ] [ { 1 3 5 7 } 2 chop ] unit-test
[ -1 ] [ { 1 3 5 7 } 4 chop ] unit-test
[ -1 ] [ { 1 3 5 7 } 6 chop ] unit-test
[ -1 ] [ { 1 3 5 7 } 8 chop ] unit-test
| Author: | blei |
|---|
| Mode: | factor |
|---|
| Date: | Sat, 21 Aug 2010 20:07:06 |
|---|
Plain Text |
: bisect-slice ( a -- b c ) dup length 2 /i cut-slice ;
DEFER: chop
: check-right ( seq int -- int )
swap [ drop -1 ] [
swap [ dup first ] dip [ <=> ] keep swap
{
{ +gt+ [ drop drop -1 ] }
{ +lt+ [ [ rest-slice ] dip chop ] }
[ drop drop from>> ]
} case
] if-empty
;
: chop ( seq int -- int )
[ bisect-slice ] dip [ check-right ] keep
swap dup -1 = not [ 2nip ] [ drop swap [ drop -1 ] [ swap chop ] if-empty ] if ;
New Annotation