72 lines
1.9 KiB
Factor
72 lines
1.9 KiB
Factor
! Copyright (C) 2007 Robbert van Dalen.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
|
|
IN: isequences.ops.maximum
|
|
USING: generic kernel math sequences isequences.interface isequences.base ;
|
|
|
|
|
|
|
|
TUPLE: imax left right ;
|
|
|
|
: imax-unpack ( imax -- left right )
|
|
dup imax-left swap imax-right ; inline
|
|
|
|
: nmax ( s n -- s )
|
|
i-length over i-length - dup 0 <= [ drop ] [ ++ ] if ; inline
|
|
|
|
: <i-max> ( s1 s2 -- imax )
|
|
dup i-length pick swap nmax -rot swap nmax <imax> ; inline
|
|
|
|
: min## ( s1 s2 -- minimum )
|
|
[ i-length ] 2apply min ; inline
|
|
|
|
: ||g++ ( s1 s2 -- imax )
|
|
2dup [ i-length ] 2apply zero? [ 2drop ] [ zero? [ nip ] [ <i-max> ] if ] if ; inline
|
|
|
|
: ||g-+ ( s1 s2 -- imax )
|
|
swap -- `` swap 2dup min## -rot || swap ihead ; inline
|
|
|
|
: ||g+- ( s1 s2 -- imax )
|
|
-- `` 2dup min## -rot || swap ihead ; inline
|
|
|
|
: ||g-- ( s1 s2 -- imax )
|
|
[ -- `` ] 2apply 2dup min## -rot || swap ihead `` -- ; inline
|
|
|
|
: mcut-point ( imax -- i )
|
|
imax-unpack [ ileft i-length ] 2apply 2dup < [ drop ] [ nip ] if ; inline
|
|
|
|
: imax-ileft ( imax -- imax )
|
|
dup i-length 1 =
|
|
[ drop 0 ]
|
|
[ dup mcut-point swap imax-unpack pick ihead -rot swap ihead swap || ]
|
|
if ; inline
|
|
|
|
: imax-iright ( imax -- imax )
|
|
dup i-length 1 =
|
|
[ drop 0 ]
|
|
[ dup mcut-point swap imax-unpack pick itail -rot swap itail swap || ]
|
|
if ; inline
|
|
|
|
|
|
: ||g ( s1 s2 -- s )
|
|
2dup [ neg? ] 2apply [ [ ||g-- ] [ ||g+- ] if ]
|
|
[ [ ||g-+ ] [ ||g++ ] if ] if ; inline
|
|
|
|
M: object || ||g ;
|
|
|
|
! double dispatch integer/||
|
|
GENERIC: integer/|| ( s1 s2 -- v )
|
|
M: object integer/|| swap ||g ;
|
|
M: integer || swap integer/|| ;
|
|
! integer optimization
|
|
M: integer integer/|| max ;
|
|
|
|
M: imax i-at swap imax-unpack pick i-at -rot swap i-at swap ++ ;
|
|
M: imax i-length imax-left i-length ;
|
|
M: imax ileft imax-ileft ;
|
|
M: imax iright imax-iright ;
|
|
M: imax ihead (ihead) ;
|
|
M: imax itail (itail) ;
|
|
M: imax $$ imax-unpack [ $$ -2 shift ] 2apply quick-hash ;
|
|
|