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