95 lines
2.6 KiB
Factor
95 lines
2.6 KiB
Factor
! Copyright (C) 2007 Robbert van Dalen.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
|
|
IN: isequences.ops.divide
|
|
USING: generic kernel math math.functions sequences isequences.interface isequences.base ;
|
|
|
|
|
|
TUPLE: idiv sequence div offset size ;
|
|
|
|
: n-cut ( seq pos -- seq )
|
|
2dup ihead -rot itail <isequence> ; inline
|
|
|
|
: n-div ( seq div -- seq )
|
|
swap dup i-length 2/ dup roll mod - n-cut ; inline
|
|
|
|
: <i-div> ( sequence div offset size -- idiv )
|
|
pick 1 =
|
|
[ 3drop ] [ >r >r tuck n-div swap r> r> <idiv> ] if ; inline
|
|
|
|
: idiv-unpack ( idiv -- sequence div offset size )
|
|
dup idiv-sequence swap dup idiv-div swap dup idiv-offset swap idiv-size ; inline
|
|
|
|
: (idiv-offset) ( pos idiv -- offset-pos )
|
|
tuck dup idiv-offset swap idiv-div
|
|
dup * -rot + * swap idiv-size 2dup
|
|
mod neg rot + swap /i ; inline
|
|
|
|
: (idiv-index) ( pos idiv -- index )
|
|
idiv-div * ; inline
|
|
|
|
: idiv-nth ( idiv pos -- v )
|
|
swap tuck 2dup (idiv-index) -rot (idiv-offset)
|
|
+ swap idiv-sequence swap i-at ; inline
|
|
|
|
: idiv-ileft ( idiv -- idiv )
|
|
dup idiv-sequence ileft swap dup idiv-div
|
|
pick i-length swap tuck =
|
|
[ drop nip 0 i-at <i> ]
|
|
[ swap dup idiv-offset swap idiv-size <i-div> ]
|
|
if ;
|
|
|
|
: (idiv-newoffset) ( idiv -- newoff )
|
|
dup ileft i-length swap idiv-offset + ;
|
|
|
|
: idiv-iright ( idiv -- idiv )
|
|
dup idiv-sequence iright swap dup idiv-div
|
|
pick i-length swap tuck =
|
|
[ drop nip dup ileft i-length i-at <i> ]
|
|
[ swap dup (idiv-newoffset) swap idiv-size <i-div> ]
|
|
if ; inline
|
|
|
|
M: idiv i-length dup idiv-sequence i-length swap idiv-div /i ;
|
|
M: idiv i-at idiv-nth ;
|
|
M: idiv ileft idiv-ileft ;
|
|
M: idiv iright idiv-iright ;
|
|
M: idiv ihead (ihead) ;
|
|
M: idiv itail (itail) ;
|
|
M: idiv $$
|
|
idiv-unpack [ $$ ] 2apply quick-hash -rot [ $$ ]
|
|
2apply [ quick-hash ] 2apply ;
|
|
|
|
: gcd_0 ( n1 n2 -- n )
|
|
dup zero? [ 2drop 1 ] [ gcd ] if ; inline
|
|
|
|
: /_g++ ( s1 n -- idiv )
|
|
i-length over i-length tuck gcd_0 0 rot <i-div> ; inline
|
|
|
|
: /_g+- ( s n -- s ) -- /_ ; inline
|
|
|
|
: /_g-+ ( s n -- s ) swap -- `` swap /_ -- `` ; inline
|
|
|
|
: /_g-- ( s n -- s ) [ -- ] 2apply /_ ; inline
|
|
|
|
: /_g ( s1 s2 -- s )
|
|
2dup [ neg? ] 2apply [ [ /_g-- ] [ /_g+- ] if ] [ [ /_g-+ ] [ /_g++ ] if ] if ; inline
|
|
|
|
M: object /_ /_g ;
|
|
|
|
|
|
: _/g++ ( n s -- s )
|
|
dup i-length dup roll i-length gcd_0 tuck /i tuck roll _* rot /_ swap /_ ;
|
|
|
|
: _/g+- ( n s -- s ) -- `` _/ `` -- ; inline
|
|
|
|
: _/g-+ ( n s -- s ) swap -- swap _/ ; inline
|
|
|
|
: _/g-- ( n s -- s ) [ -- ] 2apply _/ ; inline
|
|
|
|
: _/g ( n s -- s )
|
|
2dup [ neg? ] 2apply [ [ _/g-- ] [ _/g+- ] if ]
|
|
[ [ _/g-+ ] [ _/g++ ] if ] if ; inline
|
|
|
|
M: object _/ _/g ;
|
|
|