Paste: Bresenham

! Copyright (C) 2022 Capital Ex.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generalizations kernel math ranges sequences ;
IN: bresenham-cat

: >x0,x1 ( p0 p1 -- x0 x1 ) 
    [ first ] bi@ ; inline

: >y0,y1 ( p0 p1 -- y0 y1 ) 
    [ second ] bi@ ; inline

: neg-nth ( seq n -- )
    swap 2dup '[ _ _ nth neg _ _ set-nth ] call ;

: >dx/dy ( p1 p2 -- dx dy )
    [ >x0,x1 swap - ] [ >y0,y1 swap - ] 2bi ;

: (compute-ds) ( d range dx dy -- ds )
    [ '[ 2 _ _ - * + ] ] [ drop '[ 2 _ * + ] ] 2bi
    '[ drop dup 0 > _ _ if dup ] map nip 0 prefix ;

: (next-x/y) ( x/y i d -- x' )
    0 > [ + ] [ drop ] if ;

: ?invert-iter ( {dx,dy,i} -- {dx,dy,i} )
    dup first 0 < [ dup [ 0 neg-nth ] [ 2 neg-nth ] bi ] [  ] if ;

: get-x0-i ( x0 x x x x x x i -- x0 i ) nip 5nip ;

: get-y0-i ( x y0 x x x x x i -- y0 i ) 5nip nipd ;

: get-dlist ( x x x x range dx dy x -- ds )
    drop [ 4drop ] 3dip rot 2over
        '[ _ 2 * _ - _ _ _ (compute-ds) ] call ;

: get-2map-pred-lo ( x x x x range x x x -- range quot )
    3drop 4nip [ [ [ (next-x/y) ] 3keep drop swap ] [ swap 2array ] bi* ] ;

: get-2map-pred-hi ( x x x x range x x x -- range quot )
    3drop 4nip [ [ [ (next-x/y) ] 3keep drop swap ] [ 2array ] bi* ] ;

: get-points ( x0/y0 i dlist range quot -- x )
    [ call( x x x x -- x x x ) ] curry 2map 2nip ;

: unpack-args ( p0 p1 _ {d0,d1,i} -- x0 y0 x1 x0 _ d0 d1 i )
    [ first2 ] 3dip [ first2 ] 2dip first3 ;

: (bresenham-lo) ( p0 p1 -- points )
    2dup >dx/dy swap 1 3array ?invert-iter
    [ [ >x0,x1 [a..b] ] 2keep rot ] dip unpack-args { 
        [ get-y0-i ] [ get-dlist ] [ get-2map-pred-lo ] 
    } 8 ncleave get-points ;

: (bresenham-hi) ( p0 p1 -- points )
    2dup >dx/dy 1 3array ?invert-iter
    [ [ >y0,y1 [a..b] ] 2keep rot ] dip unpack-args { 
        [ get-x0-i ] [ get-dlist ] [ get-2map-pred-hi ] 
    } 8 ncleave get-points ;

: bresenham-cat ( u v -- points )
    2dup [ >y0,y1 - abs ] [ >x0,x1 - abs ] 2bi <
    [ 2dup >x0,x1 > [ swap (bresenham-lo) ] [ (bresenham-lo) ] if ]
    [ 2dup >y0,y1 > [ swap (bresenham-hi) ] [ (bresenham-hi) ] if ] if ;