basis/binary-search/binary-search.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel sequences sequences.private accessors math
   4 math.order combinators hints arrays ;
   5 IN: binary-search
   6
   7 <PRIVATE
   8
   9 : midpoint ( seq -- elt )
  10     [ midpoint@ ] keep nth-unsafe ; inline
  11
  12 : decide ( quot seq -- quot seq <=> )
  13     [ midpoint swap call ] 2keep rot ; inline
  14
  15 : finish ( quot slice -- i elt )
  16     [ [ from>> ] [ midpoint@ ] bi + ] [ seq>> ] bi
  17     [ drop ] [ dup ] [ ] tri* nth ; inline
  18
  19 DEFER: (search)
  20
  21 : keep-searching ( seq quot -- slice )
  22     [ dup midpoint@ ] dip call collapse-slice slice boa (search) ; inline
  23
  24 : (search) ( ... quot: ( ... elt -- ... <=> ) seq -- ... i elt )
  25     dup length 1 <= [
  26         finish
  27     ] [
  28         decide {
  29             { +eq+ [ finish ] }
  30             { +lt+ [ [ (head) ] keep-searching ] }
  31             { +gt+ [ [ (tail) ] keep-searching ] }
  32         } case
  33     ] if ; inline recursive
  34
  35 PRIVATE>
  36
  37 : search ( seq quot -- i elt )
  38     over empty? [ 2drop f f ] [ swap <flat-slice> (search) ] if ;
  39     inline
  40
  41 : natural-search ( obj seq -- i elt )
  42     [ <=> ] with search ;
  43
  44 HINTS: natural-search array ;
  45
  46 : sorted-index ( obj seq -- i )
  47     natural-search drop ;
  48
  49 : sorted-member? ( obj seq -- ? )
  50     dupd natural-search nip = ;
  51
  52 : sorted-member-eq? ( obj seq -- ? )
  53     dupd natural-search nip eq? ;