basis/circular/circular.factor

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