steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

binary-search: faster and cleaner implementation using locals

db4
Slava Pestov 2010-04-17 00:58:12 -05:00
parent b7631c98cf
commit 8d3d425d44
1 changed files with 14 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
basis/binary-search/binary-search.factor
View File

@ -1,41 +1,29 @@
! Copyright (C) 2008, 2009 Slava Pestov. ! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private accessors math USING: accessors arrays combinators hints kernel locals math
math.order combinators hints arrays ; math.order sequences ;
IN: binary-search IN: binary-search
<PRIVATE <PRIVATE
: midpoint ( seq -- elt ) :: (search) ( seq from to quot: ( elt -- <=> ) -- i elt )
[ midpoint@ ] keep nth-unsafe ; inline from to + 2/ :> midpoint@
midpoint@ seq nth :> midpoint
: decide ( quot seq -- quot seq <=> ) to from - 1 <= [
[ midpoint swap call ] 2keep rot ; inline midpoint@ midpoint
: finish ( quot slice -- i elt )
[ [ from>> ] [ midpoint@ ] bi + ] [ seq>> ] bi
[ drop ] [ dup ] [ ] tri* nth ; inline
DEFER: (search)
: keep-searching ( seq quot -- slice )
[ dup midpoint@ ] dip call collapse-slice slice boa (search) ; inline
: (search) ( ... quot: ( ... elt -- ... <=> ) seq -- ... i elt )
dup length 1 <= [
finish
] [ ] [
decide { midpoint quot call {
{ +eq+ [ finish ] } { +eq+ [ midpoint@ midpoint ] }
{ +lt+ [ [ (head) ] keep-searching ] } { +lt+ [ seq from midpoint@ quot (search) ] }
{ +gt+ [ [ (tail) ] keep-searching ] } { +gt+ [ seq midpoint@ to quot (search) ] }
} case } case
] if ; inline recursive ] if ; inline recursive
PRIVATE> PRIVATE>
: search ( seq quot -- i elt ) : search ( seq quot: ( elt -- <=> ) -- i elt )
over empty? [ 2drop f f ] [ swap <flat-slice> (search) ] if ; over empty? [ 2drop f f ] [ [ 0 over length ] dip (search) ] if ;
inline inline
: natural-search ( obj seq -- i elt ) : natural-search ( obj seq -- i elt )