basis/sequences/cords/cords.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs sequences sorting binary-search math
   4 math.order arrays combinators kernel ;
   5 IN: sequences.cords
   6
   7 <PRIVATE
   8
   9 TUPLE: simple-cord
  10     { first read-only } { second read-only } ;
  11
  12 M: simple-cord length
  13     [ first>> length ] [ second>> length ] bi + ; inline
  14
  15 M: simple-cord virtual-exemplar first>> ; inline
  16
  17 M: simple-cord virtual@
  18     2dup first>> length <
  19     [ first>> ] [ [ first>> length - ] [ second>> ] bi ] if ; inline
  20
  21 TUPLE: multi-cord
  22     { count read-only } { seqs read-only } ;
  23
  24 M: multi-cord length count>> ; inline
  25
  26 M: multi-cord virtual@
  27     dupd
  28     seqs>> [ first <=> ] with search nip
  29     [ first - ] [ second ] bi ; inline
  30
  31 M: multi-cord virtual-exemplar
  32     seqs>> [ f ] [ first second ] if-empty ; inline
  33
  34 : <cord> ( seqs -- cord )
  35     dup length 2 = [
  36         first2 simple-cord boa
  37     ] [
  38         [ 0 [ length + ] accumulate ] keep zip multi-cord boa
  39     ] if ; inline
  40
  41 PRIVATE>
  42
  43 UNION: cord simple-cord multi-cord ;
  44
  45 INSTANCE: cord virtual-sequence
  46
  47 INSTANCE: multi-cord virtual-sequence
  48
  49 : cord-append ( seq1 seq2 -- cord )
  50     {
  51         { [ over empty? ] [ nip ] }
  52         { [ dup empty? ] [ drop ] }
  53         { [ 2dup [ cord? ] both? ] [ [ seqs>> values ] bi@ append <cord> ] }
  54         { [ over cord? ] [ [ seqs>> values ] dip suffix <cord> ] }
  55         { [ dup cord? ] [ seqs>> values swap prefix <cord> ] }
  56         [ 2array <cord> ]
  57     } cond ; inline
  58
  59 : cord-concat ( seqs -- cord )
  60     {
  61         { [ dup empty? ] [ drop f ] }
  62         { [ dup length 1 = ] [ first ] }
  63         [
  64             [
  65                 {
  66                     { [ dup cord? ] [ seqs>> values ] }
  67                     { [ dup empty? ] [ drop { } ] }
  68                     [ 1array ]
  69                 } cond
  70             ] map concat <cord>
  71         ]
  72     } cond ; inline