basis/circular/circular.factor

   1 ! Copyright (C) 2005, 2006 Alex Chapman, Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license
   3 USING: kernel sequences math sequences.private strings
   4 accessors locals fry ;
   5 IN: circular
   6
   7 TUPLE: circular { seq read-only } { start integer } ;
   8
   9 : <circular> ( seq -- circular )
  10     0 circular boa ; inline
  11
  12 <PRIVATE
  13
  14 : circular-wrap ( n circular -- n circular )
  15     [ start>> + ] keep
  16     [ seq>> length rem ] keep ; inline
  17
  18 PRIVATE>
  19
  20 M: circular length seq>> length ; inline
  21
  22 M: circular virtual@ circular-wrap seq>> ; inline
  23
  24 M: circular virtual-exemplar seq>> ; inline
  25
  26 : change-circular-start ( n circular -- )
  27     ! change start to (start + n) mod length
  28     circular-wrap start<< ; inline
  29
  30 : rotate-circular ( circular -- )
  31     [ 1 ] dip change-circular-start ; inline
  32
  33 : circular-push ( elt circular -- )
  34     [ set-first ] [ rotate-circular ] bi ;
  35
  36 : <circular-string> ( n -- circular )
  37     0 <string> <circular> ; inline
  38
  39 INSTANCE: circular virtual-sequence
  40
  41 TUPLE: growing-circular < circular { length integer } ;
  42
  43 M: growing-circular length length>> ; inline
  44
  45 <PRIVATE
  46
  47 : full? ( circular -- ? )
  48     [ length ] [ seq>> length ] bi = ; inline
  49
  50 PRIVATE>
  51
  52 : growing-circular-push ( elt circular -- )
  53     dup full? [ circular-push ]
  54     [ [ 1 + ] change-length set-last ] if ;
  55
  56 : <growing-circular> ( capacity -- growing-circular )
  57     { } new-sequence 0 0 growing-circular boa ; inline
  58
  59 TUPLE: circular-iterator
  60     { circular read-only } { n integer } { last-start integer } ;
  61
  62 : <circular-iterator> ( circular -- obj )
  63     0 -1 circular-iterator boa ; inline
  64
  65 <PRIVATE
  66
  67 : (circular-while) ( ... iterator quot: ( ... obj -- ... ? ) -- ... )
  68     [ [ [ n>> ] [ circular>> ] bi nth ] dip call ] 2keep
  69     rot [ [ dup n>> >>last-start ] dip ] when
  70     over [ n>> ] [ [ last-start>> ] [ circular>> length ] bi + ] bi = [
  71         2drop
  72     ] [
  73         [ [ 1 + ] change-n ] dip (circular-while)
  74     ] if ; inline recursive
  75
  76 PRIVATE>
  77
  78 : circular-while ( ... circular quot: ( ... obj -- ... ? ) -- ... )
  79     [ clone ] dip [ <circular-iterator> ] dip (circular-while) ; inline
  80
  81 : circular-loop ( ... circular quot: ( ... obj -- ... ? ) -- ... )
  82     [ clone ] dip '[ [ first @ ] [ rotate-circular ] bi ] curry loop ; inline