factor/basis/circular/circular.factor

58 lines
1.4 KiB
Factor
Raw Normal View History

2007-09-20 18:09:08 -04:00
! Copyright (C) 2005, 2006 Alex Chapman, Daniel Ehrenberg
! See http;//factorcode.org/license.txt for BSD license
2008-04-13 01:52:49 -04:00
USING: kernel sequences math sequences.private strings
accessors ;
2007-09-20 18:09:08 -04:00
IN: circular
! a circular sequence wraps another sequence, but begins at an
! arbitrary element in the underlying sequence.
TUPLE: circular seq start ;
: <circular> ( seq -- circular )
0 circular boa ;
2007-09-20 18:09:08 -04:00
2008-09-15 00:27:37 -04:00
<PRIVATE
2007-09-20 18:09:08 -04:00
: circular-wrap ( n circular -- n circular )
2008-04-13 01:52:49 -04:00
[ start>> + ] keep
[ seq>> length rem ] keep ; inline
2008-09-15 00:27:37 -04:00
PRIVATE>
2007-09-20 18:09:08 -04:00
2008-04-13 01:52:49 -04:00
M: circular length seq>> length ;
2007-09-20 18:09:08 -04:00
2008-04-13 01:52:49 -04:00
M: circular virtual@ circular-wrap seq>> ;
2007-09-20 18:09:08 -04:00
2008-04-13 01:52:49 -04:00
M: circular virtual-seq seq>> ;
2007-09-20 18:09:08 -04:00
: change-circular-start ( n circular -- )
#! change start to (start + n) mod length
2008-04-13 01:52:49 -04:00
circular-wrap (>>start) ;
2007-09-20 18:09:08 -04:00
2009-05-13 20:31:58 -04:00
: rotate-circular ( circular -- )
2009-06-09 19:28:53 -04:00
[ 1 ] dip change-circular-start ;
2009-05-13 20:31:58 -04:00
2007-09-20 18:09:08 -04:00
: push-circular ( elt circular -- )
2009-06-09 19:28:53 -04:00
[ set-first ] [ rotate-circular ] bi ;
2007-09-20 18:09:08 -04:00
: <circular-string> ( n -- circular )
0 <string> <circular> ;
INSTANCE: circular virtual-sequence
2008-05-25 16:19:26 -04:00
TUPLE: growing-circular < circular length ;
M: growing-circular length length>> ;
2008-09-15 00:27:37 -04:00
<PRIVATE
2008-05-25 16:19:26 -04:00
: full? ( circular -- ? )
[ length ] [ seq>> length ] bi = ;
2008-09-15 00:27:37 -04:00
PRIVATE>
2008-05-25 16:19:26 -04:00
: push-growing-circular ( elt circular -- )
dup full? [ push-circular ]
[ [ 1+ ] change-length set-last ] if ;
2008-05-25 16:19:26 -04:00
: <growing-circular> ( capacity -- growing-circular )
{ } new-sequence 0 0 growing-circular boa ;