Binary Search is a searching algorithm used in a sorted array by repeatedly dividing the search interval in half. The idea of binary search is to use the information that the array is sorted and reduce the time complexity to O(log N).

Create an array 02 03 04 10 40, and find the offset from 0 of the array or return -1 when the value is not found.

Uxntal

@on-reset ( -> )
	( l ) #0000 
	( r ) ;arr/end ;arr SUB2 #0001 SUB2 
	( array* target ) ;arr #04 binsearch
	( print result ) #010e DEO
	BRK

@arr 02 03 04 10 40 &end

@binsearch ( l* r* arr* x -- addr* )
	,&x STR
	STH2
	&>w ( l* r* | arr* -- addr* )
		( m* ) OVR2 SUB2k #01 SFT ADD2
		( m* arr+m* ) DUP2 STH2kr ADD2
		( m* arr[m] x ) LDA [ LIT &x $1 ]
		( arr[m] == x ) NEQk ?{ POP2 POP2r NIP2 NIP2 JMP2r }
		( arr[m] < x ) GTH ?{ INC2 ROT2 POP2 SWP2 !& }
		( else ) #0001 SUB2 NIP2 
		& GTH2k #00 EQU ?&>w
	POP2 POP2 POP2r #ffff JMP2r

Factor

USING: combinators kernel math math.order sequences ;
IN: catlang-discord.challenges.binary-search

DEFER: (binary-search)

: search-hi ( obj seq hi lo -- i/f )
    over + 2/ 1 + (binary-search) ;

: search-lo ( obj seq hi lo -- i/f )
    tuck + 2/ 1 - swap (binary-search) ;

: test-midpoint ( obj seq hi lo -- obj seq hi lo ord )
    2dup + 2/ '[ 2dup _ swap nth <=> ] 2dip rot ;

: search-step ( obj seq hi lo -- i/f )
    test-midpoint {
        { +lt+ [ search-lo ] }
        { +eq+ [ + 2/ 2nip ] }
        { +gt+ [ search-hi ] }
    } case ;

: (binary-search) ( obj seq hi lo -- i/-1 )
    2dup < [ 4drop -1 ] [ search-step ] if ;

: binary-search ( seq obj -- i/f )
    swap dup length 1 - 0 (binary-search) ;

Forth

(Tested on Gforth 0.7.9)

\ Elements are cell sized
\ Arrays are represented by start address and number of cells

: uphalf ( addr len -- addr len ) \ Upper half of array
    dup >r   2/ cells +   r@ r> 2/ - ;

\ Assumes array has all satisfying elements before all non-satisfying elements
\ (X satisfies iff { X val test } is non-zero)
\ Returns first non-satisfying element, or { addr len cells + }
: bisect ( addr len val test -- addr )
    2>r
    begin
        dup 1 u> while      \ Done if no more than 1 left
        2dup 2/ cells + @   \ Get middle element
        2r@ execute if uphalf else 2/ then
    repeat
    cells + 2rdrop ;

: lower   ['] < bisect ;    \ First matching element
: upper   ['] <= bisect ;   \ One after last matching
\ If not found, both lower and upper are position to insert

This can be adapted to return array position if found and -1 if not found:

: binsearch ( addr len val -- pos )
    >r 2dup r@ lower >r
    ( start len ) ( R: val addr )
    2dup cells + r@ =
    if  \ If lower = end of array, val is larger than array's largest
        2drop 2rdrop -1         \ Not found
    else
        drop r> dup @ r> =      \ Check element at lower
        if swap - 1 cells /     \ If equal, get position
        else 2drop -1           \ Otherwise not found
        then
    then ;


create test   $02 , $03 , $04 , $10 , $40 ,
here test - 1 cells /   constant testlen

test testlen
2dup $03 binsearch .   \ 1
2dup $10 binsearch .   \ 3
2dup $05 binsearch .   \ -1
2dup $50 binsearch .   \ -1
2drop