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