| 
									
										
										
										
											2010-04-17 01:58:12 -04:00
										 |  |  | ! Copyright (C) 2008, 2010 Slava Pestov. | 
					
						
							| 
									
										
										
										
											2008-07-15 18:16:08 -04:00
										 |  |  | ! See http://factorcode.org/license.txt for BSD license. | 
					
						
							| 
									
										
										
										
											2010-04-17 01:58:12 -04:00
										 |  |  | USING: accessors arrays combinators hints kernel locals math | 
					
						
							| 
									
										
										
										
											2010-04-18 15:24:17 -04:00
										 |  |  | math.order sequences sequences.private ;
 | 
					
						
							| 
									
										
										
										
											2008-07-15 18:16:08 -04:00
										 |  |  | IN: binary-search | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | <PRIVATE
 | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2010-04-17 01:58:12 -04:00
										 |  |  | :: (search) ( seq from to quot: ( elt -- <=> ) -- i elt )
 | 
					
						
							|  |  |  |     from to + 2/ :> midpoint@
 | 
					
						
							| 
									
										
										
										
											2010-04-18 15:24:17 -04:00
										 |  |  |     midpoint@ seq nth-unsafe :> midpoint | 
					
						
							| 
									
										
										
										
											2008-07-15 18:16:08 -04:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2010-04-17 01:58:12 -04:00
										 |  |  |     to from - 1 <= [ | 
					
						
							|  |  |  |         midpoint@ midpoint | 
					
						
							| 
									
										
										
										
											2008-07-15 18:16:08 -04:00
										 |  |  |     ] [ | 
					
						
							| 
									
										
										
										
											2010-04-17 01:58:12 -04:00
										 |  |  |         midpoint quot call { | 
					
						
							|  |  |  |             { +eq+ [ midpoint@ midpoint ] } | 
					
						
							|  |  |  |             { +lt+ [ seq from midpoint@ quot (search) ] } | 
					
						
							|  |  |  |             { +gt+ [ seq midpoint@ to quot (search) ] } | 
					
						
							| 
									
										
										
										
											2008-07-15 18:16:08 -04:00
										 |  |  |         } case
 | 
					
						
							| 
									
										
										
										
											2008-07-18 20:22:59 -04:00
										 |  |  |     ] if ; inline recursive
 | 
					
						
							| 
									
										
										
										
											2008-07-15 18:16:08 -04:00
										 |  |  | 
 | 
					
						
							|  |  |  | PRIVATE>
 | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2010-04-17 01:58:12 -04:00
										 |  |  | : search ( seq quot: ( elt -- <=> ) -- i elt )
 | 
					
						
							|  |  |  |     over empty? [ 2drop f f ] [ [ 0 over length ] dip (search) ] if ;
 | 
					
						
							| 
									
										
										
										
											2008-07-15 18:16:08 -04:00
										 |  |  |     inline
 | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | : natural-search ( obj seq -- i elt )
 | 
					
						
							|  |  |  |     [ <=> ] with search ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2008-08-24 04:59:37 -04:00
										 |  |  | HINTS: natural-search array ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2008-07-15 18:16:08 -04:00
										 |  |  | : sorted-index ( obj seq -- i )
 | 
					
						
							|  |  |  |     natural-search drop ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | : sorted-member? ( obj seq -- ? )
 | 
					
						
							|  |  |  |     dupd natural-search nip = ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2009-10-28 16:02:00 -04:00
										 |  |  | : sorted-member-eq? ( obj seq -- ? )
 | 
					
						
							| 
									
										
										
										
											2008-07-15 18:16:08 -04:00
										 |  |  |     dupd natural-search nip eq? ;
 |