unmaintained/isequences/ops/divide/divide.factor

   1 ! Copyright (C) 2007 Robbert van Dalen.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 IN: isequences.ops.divide
   5 USING: generic kernel math math.functions sequences isequences.interface isequences.base ;
   6
   7
   8 TUPLE: idiv sequence div offset size ;
   9
  10 : n-cut ( seq pos -- seq )
  11     2dup ihead -rot itail <isequence> ; inline
  12
  13 : n-div ( seq div -- seq )
  14     swap dup i-length 2/ dup roll mod - n-cut ; inline
  15
  16 : <i-div> ( sequence div offset size -- idiv )
  17     pick 1 =
  18     [ 3drop ] [ >r >r tuck n-div swap r> r> <idiv> ] if ; inline
  19
  20 : idiv-unpack ( idiv -- sequence div offset size )
  21     dup idiv-sequence swap dup idiv-div swap dup idiv-offset swap idiv-size ; inline
  22
  23 : (idiv-offset) ( pos idiv -- offset-pos )
  24     tuck dup idiv-offset swap idiv-div
  25     dup * -rot + * swap idiv-size 2dup
  26     mod neg rot + swap /i ; inline
  27
  28 : (idiv-index) ( pos idiv -- index )
  29     idiv-div * ; inline
  30
  31 : idiv-nth ( idiv pos -- v )
  32     swap tuck 2dup (idiv-index) -rot (idiv-offset)
  33     + swap idiv-sequence swap i-at ; inline
  34
  35 : idiv-ileft ( idiv -- idiv )
  36     dup idiv-sequence ileft swap dup idiv-div
  37     pick i-length swap tuck =
  38     [ drop nip 0 i-at <i> ]
  39     [ swap dup idiv-offset swap idiv-size <i-div> ]
  40     if ;
  41
  42 : (idiv-newoffset) ( idiv -- newoff )
  43     dup ileft i-length swap idiv-offset + ;
  44
  45 : idiv-iright ( idiv -- idiv )
  46     dup idiv-sequence iright swap dup idiv-div
  47     pick i-length swap tuck =
  48     [ drop nip dup ileft i-length i-at <i> ]
  49     [ swap dup (idiv-newoffset) swap idiv-size <i-div> ]
  50     if ; inline
  51
  52 M: idiv i-length dup idiv-sequence i-length swap idiv-div /i ;
  53 M: idiv i-at idiv-nth ;
  54 M: idiv ileft idiv-ileft ;
  55 M: idiv iright idiv-iright ;
  56 M: idiv ihead (ihead) ;
  57 M: idiv itail (itail) ;
  58 M: idiv $$
  59     idiv-unpack [ $$ ] 2apply quick-hash -rot [ $$ ]
  60     2apply [ quick-hash ] 2apply ;
  61
  62 : gcd_0 ( n1 n2 -- n )
  63     dup zero? [ 2drop 1 ] [ gcd ] if ; inline
  64
  65 : /_g++ ( s1 n -- idiv )
  66     i-length over i-length tuck gcd_0 0 rot <i-div> ; inline
  67
  68 : /_g+- ( s n -- s ) -- /_ ; inline
  69
  70 : /_g-+ ( s n -- s ) swap -- `` swap /_ -- `` ; inline
  71
  72 : /_g-- ( s n -- s ) [ -- ] 2apply /_ ; inline
  73
  74 : /_g ( s1 s2 -- s )
  75     2dup [ neg? ] 2apply [ [ /_g-- ] [ /_g+- ] if ] [ [ /_g-+ ] [ /_g++ ] if ] if ; inline
  76
  77 M: object /_ /_g ;
  78
  79
  80 : _/g++ ( n s -- s )
  81     dup i-length dup roll i-length gcd_0 tuck /i tuck roll _* rot /_ swap /_ ;
  82
  83 : _/g+- ( n s -- s ) -- `` _/ `` -- ; inline
  84
  85 : _/g-+ ( n s -- s ) swap -- swap _/ ; inline
  86
  87 : _/g-- ( n s -- s ) [ -- ] 2apply _/ ; inline
  88
  89 : _/g ( n s -- s )
  90     2dup [ neg? ] 2apply [ [ _/g-- ] [ _/g+- ] if ]
  91     [ [ _/g-+ ] [ _/g++ ] if ] if ; inline
  92
  93 M: object _/ _/g ;
  94