factor/basis/math/ranges/ranges.factor

62 lines
1.5 KiB
Factor
Raw Normal View History

! Copyright (C) 2008, 2010 Slava Pestov.
2008-11-29 05:09:16 -05:00
! See http://factorcode.org/license.txt for BSD license.
USING: kernel layouts math math.order namespaces sequences
2009-01-29 00:33:26 -05:00
sequences.private accessors classes.tuple arrays ;
2007-09-20 18:09:08 -04:00
IN: math.ranges
2008-06-29 22:37:57 -04:00
TUPLE: range
2008-06-30 02:44:58 -04:00
{ from read-only }
{ length read-only }
{ step read-only } ;
2007-09-20 18:09:08 -04:00
<PRIVATE
2013-03-21 11:54:14 -04:00
: sign/mod ( x y -- z w )
[ [ /i ] 2keep pick * - ] keep 0 < [ neg ] when ; inline
PRIVATE>
2008-03-20 19:33:01 -04:00
: <range> ( a b step -- range )
[ over - ] dip
[ sign/mod 0 < [ 1 + ] unless 0 max ] keep
range boa ; inline
2007-09-20 18:09:08 -04:00
M: range length ( seq -- n ) length>> ; inline
2007-09-20 18:09:08 -04:00
2013-03-21 11:54:14 -04:00
M: range nth-unsafe ( n range -- obj )
[ step>> * ] keep from>> + ; inline
2007-09-20 18:09:08 -04:00
! We want M\ tuple hashcode, not M\ sequence hashcode here!
! sequences hashcode is O(n) in number of elements
2009-01-29 00:33:26 -05:00
M: range hashcode* tuple-hashcode ;
2007-09-20 18:09:08 -04:00
INSTANCE: range immutable-sequence
2013-05-06 19:01:29 -04:00
M: range sum [ length ] [ first ] [ last ] tri + * 2 / ;
<PRIVATE
: twiddle ( a b -- a b step ) 2dup > -1 1 ? ; inline
2007-09-20 18:09:08 -04:00
: (a, ( a b step -- a' b' step ) dup [ + ] curry 2dip ; inline
2007-09-20 18:09:08 -04:00
: ,b) ( a b step -- a' b' step ) dup [ - ] curry dip ; inline
2007-09-20 18:09:08 -04:00
PRIVATE>
2008-08-22 18:38:23 -04:00
: [a,b] ( a b -- range ) twiddle <range> ; inline
2007-09-20 18:09:08 -04:00
2008-08-22 18:38:23 -04:00
: (a,b] ( a b -- range ) twiddle (a, <range> ; inline
2007-09-20 18:09:08 -04:00
2008-08-22 18:38:23 -04:00
: [a,b) ( a b -- range ) twiddle ,b) <range> ; inline
2007-09-20 18:09:08 -04:00
2008-08-22 18:38:23 -04:00
: (a,b) ( a b -- range ) twiddle (a, ,b) <range> ; inline
2007-09-20 18:09:08 -04:00
2008-08-22 18:38:23 -04:00
: [0,b] ( b -- range ) 0 swap [a,b] ; inline
2007-09-20 18:09:08 -04:00
2008-08-22 18:38:23 -04:00
: [1,b] ( b -- range ) 1 swap [a,b] ; inline
2007-09-20 18:09:08 -04:00
2008-08-22 18:38:23 -04:00
: [0,b) ( b -- range ) 0 swap [a,b) ; inline
: [1,b) ( b -- range ) 1 swap [a,b) ; inline