unmaintained/isequences/ops/match/match.factor

   1 ! Copyright (C) 2007 Robbert van Dalen.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 IN: isequences.ops.match
   5 USING: generic kernel math sequences isequences.interface isequences.base ;
   6
   7
   8 TUPLE: imatch sorted-s1 s2 ;
   9
  10 DEFER: ifind-c
  11
  12 : <i-match> ( s1 s2 -- imatch )
  13     dup i-length dup zero? [ 3drop 0 ]
  14     [ 1 = [ swap i-sort swap 0 i-at ifind-c <i> ] [ swap i-sort swap <imatch> ] if ] if ; inline
  15
  16 : imatch-unpack ( imatch -- sorted-s1 s2 )
  17     dup imatch-sorted-s1 swap imatch-s2 ; inline
  18
  19 DEFER: (ifind2-left-m)
  20
  21 : (ifind3-left-m) ( s1 v s e -- i )
  22     2dup >r >r + 2/ pick swap i-at left-side over i-cmp 0 <=
  23     [ r> r> swap over + 1+ 2/ swap (ifind2-left-m) ]
  24     [ r> r> over + 2/ (ifind2-left-m) ]
  25     if ; inline
  26
  27 : (ifind2-left-m) ( s1 v s e -- i )
  28     2dup = [ -roll 3drop ] [ (ifind3-left-m) ] if ; inline
  29
  30 : ifind-left-m ( s1 v -- i )
  31     over i-length 0 swap (ifind2-left-m) ; inline
  32
  33 DEFER: (ifind2-left)
  34
  35 : (ifind3-left) ( s1 v s e -- i )
  36     2dup >r >r + 2/ pick swap i-at left-side over i-cmp 0 <
  37     [ r> r> swap over + 1+ 2/ swap (ifind2-left) ]
  38     [ r> r> over + 2/ (ifind2-left) ]
  39     if ; inline
  40
  41 : (ifind2-left) ( s1 v s e -- i )
  42     2dup = [ -roll 3drop ] [ (ifind3-left) ] if ; inline
  43
  44 : ifind-left ( s1 v -- i )
  45     over i-length 0 swap (ifind2-left) ; inline
  46
  47 : icontains-left? ( s1 v -- ? )
  48     2dup ifind-left pick i-length dupd <
  49     [ rot swap i-at left-side i-cmp zero? ] [ 3drop f ] if ; inline
  50
  51 : (ifind-s2) ( s1 v -- sv )
  52     2dup ifind-left rot swap itail dup rot ifind-left-m ihead ## :: ; inline
  53
  54 : ifind-s ( s1 v -- sv )
  55     2dup icontains-left?
  56     [ (ifind-s2) ] [ 2drop 0 ] if ; inline
  57
  58 : iflatten ( s -- s )
  59     dup i-length dup zero?
  60     [ 2drop 0 ]
  61     [ 1 = [ 0 i-at left-side ] [ left-right [ iflatten ] 2apply ++ ] if ] if ; inline
  62
  63 : ifind-c ( s1 v -- s )
  64     ifind-s iflatten ; inline
  65
  66 : >>g++ ( s1 s2 -- imatch )
  67     <i-match> ; inline
  68
  69 : >>g-+ ( s1 s2 -- imatch )
  70     swap -- swap >>g++ ; inline
  71
  72 : >>g+- ( s1 s2 -- imatch )
  73     -- >>g++ -- ;
  74
  75 : >>g-- ( s1 s2 -- imatch )
  76     [ -- ] 2apply >>g++ -- ; inline
  77
  78 : >>g ( s1 s2 -- imatch )
  79     2dup [ neg? ] 2apply [ [ >>g-- ] [ >>g+- ] if ]
  80     [ [ >>g-+ ] [ >>g++ ] if ] if ; inline
  81
  82 M: object >> >>g ;
  83
  84 M: imatch i-length imatch-s2 i-length ;
  85 M: imatch i-at swap imatch-unpack rot i-at tuck left-side ifind-c swap right-side <i-dual-sided> ;
  86 M: imatch ileft imatch-unpack ileft <i-match> ;
  87 M: imatch iright imatch-unpack iright <i-match> ;
  88 M: imatch ihead (ihead) ;
  89 M: imatch itail (itail) ;
  90 M: imatch $$ imatch-unpack [ $$ ] 2apply quick-hash ;