basis/sequences/cords/cords.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs sequences sorting binary-search fry math
   4 math.order arrays classes combinators kernel functors locals
   5 math.functions math.vectors ;
   6 IN: sequences.cords
   7
   8 MIXIN: cord
   9
  10 TUPLE: generic-cord
  11     { head read-only } { tail read-only } ; final
  12 INSTANCE: generic-cord cord
  13
  14 M: cord length
  15     [ head>> length ] [ tail>> length ] bi + ; inline
  16
  17 M: cord virtual-exemplar head>> ; inline
  18
  19 M: cord virtual@
  20     2dup head>> length <
  21     [ head>> ] [ [ head>> length - ] [ tail>> ] bi ] if ; inline
  22
  23 INSTANCE: cord virtual-sequence
  24
  25 GENERIC: cord-append ( seq1 seq2 -- cord )
  26
  27 M: object cord-append
  28     generic-cord boa ; inline
  29
  30 <FUNCTOR: define-specialized-cord ( T C -- )
  31
  32 T-cord DEFINES-CLASS ${C}
  33
  34 WHERE
  35
  36 TUPLE: T-cord
  37     { head T read-only } { tail T read-only } ; final
  38 INSTANCE: T-cord cord
  39
  40 M: T cord-append
  41     2dup [ T instance? ] both?
  42     [ T-cord boa ] [ generic-cord boa ] if ; inline
  43
  44 ;FUNCTOR>
  45
  46 : cord-map ( cord quot -- cord' )
  47     [ [ head>> ] dip call ]
  48     [ [ tail>> ] dip call ] 2bi cord-append ; inline
  49
  50 :: cord-2map ( cord-a cord-b quot fallback -- cord' )
  51     cord-a cord-b 2dup [ cord? ] both? [
  52         [ [ head>> ] bi@ quot call ]
  53         [ [ tail>> ] bi@ quot call ] 2bi cord-append
  54     ] [ fallback call ] if ; inline
  55
  56 : cord-both ( cord quot -- h t )
  57     [ [ head>> ] [ tail>> ] bi ] dip bi@ ; inline
  58
  59 :: cord-2both ( cord-a cord-b quot combine fallback -- result )
  60     cord-a cord-b 2dup [ cord? ] both? [
  61         [ [ head>> ] bi@ quot call ]
  62         [ [ tail>> ] bi@ quot call ] 2bi combine call
  63     ] [ fallback call ] if ; inline
  64
  65 <PRIVATE
  66 : split-shuffle ( shuf -- sh uf )
  67     dup length 2 /i cut* ; foldable
  68 PRIVATE>
  69
  70 M: cord v+                [ v+                ] [ call-next-method ] cord-2map ; inline
  71 M: cord v-                [ v-                ] [ call-next-method ] cord-2map ; inline
  72 M: cord vneg              [ vneg              ] cord-map  ; inline
  73 M: cord v+-               [ v+-               ] [ call-next-method ] cord-2map ; inline
  74 M: cord vs+               [ vs+               ] [ call-next-method ] cord-2map ; inline
  75 M: cord vs-               [ vs-               ] [ call-next-method ] cord-2map ; inline
  76 M: cord vs*               [ vs*               ] [ call-next-method ] cord-2map ; inline
  77 M: cord v*                [ v*                ] [ call-next-method ] cord-2map ; inline
  78 M: cord v/                [ v/                ] [ call-next-method ] cord-2map ; inline
  79 M: cord vmin              [ vmin              ] [ call-next-method ] cord-2map ; inline
  80 M: cord vmax              [ vmax              ] [ call-next-method ] cord-2map ; inline
  81 M: cord vdot              [ vdot              ] [ + ] [ call-next-method ] cord-2both ; inline
  82 M: cord vsqrt             [ vsqrt             ] cord-map  ; inline
  83 M: cord sum               [ sum               ] cord-both + ; inline
  84 M: cord vabs              [ vabs              ] cord-map  ; inline
  85 M: cord vbitand           [ vbitand           ] [ call-next-method ] cord-2map ; inline
  86 M: cord vbitandn          [ vbitandn          ] [ call-next-method ] cord-2map ; inline
  87 M: cord vbitor            [ vbitor            ] [ call-next-method ] cord-2map ; inline
  88 M: cord vbitxor           [ vbitxor           ] [ call-next-method ] cord-2map ; inline
  89 M: cord vbitnot           [ vbitnot           ] cord-map  ; inline
  90 M: cord vand              [ vand              ] [ call-next-method ] cord-2map ; inline
  91 M: cord vandn             [ vandn             ] [ call-next-method ] cord-2map ; inline
  92 M: cord vor               [ vor               ] [ call-next-method ] cord-2map ; inline
  93 M: cord vxor              [ vxor              ] [ call-next-method ] cord-2map ; inline
  94 M: cord vnot              [ vnot              ] cord-map  ; inline
  95 M: cord vlshift           '[ _ vlshift        ] cord-map  ; inline
  96 M: cord vrshift           '[ _ vrshift        ] cord-map  ; inline
  97 M: cord (vmerge-head)     [ head>> ] bi@ (vmerge) cord-append ; inline
  98 M: cord (vmerge-tail)     [ tail>> ] bi@ (vmerge) cord-append ; inline
  99 M: cord v<=               [ v<=               ] [ call-next-method ] cord-2map ; inline
 100 M: cord v<                [ v<                ] [ call-next-method ] cord-2map ; inline
 101 M: cord v=                [ v=                ] [ call-next-method ] cord-2map ; inline
 102 M: cord v>                [ v>                ] [ call-next-method ] cord-2map ; inline
 103 M: cord v>=               [ v>=               ] [ call-next-method ] cord-2map ; inline
 104 M: cord vunordered?       [ vunordered?       ] [ call-next-method ] cord-2map ; inline
 105 M: cord vany?             [ vany?             ] cord-both or  ; inline
 106 M: cord vall?             [ vall?             ] cord-both and ; inline
 107 M: cord vnone?            [ vnone?            ] cord-both and ; inline
 108 M: cord vshuffle-elements
 109     [ [ head>> ] [ tail>> ] bi ] [ split-shuffle ] bi*
 110     [ vshuffle2-elements ] bi-curry@ 2bi cord-append ; inline
 111
 112 M: cord n+v [ n+v ] with cord-map ; inline
 113 M: cord n-v [ n-v ] with cord-map ; inline
 114 M: cord n*v [ n*v ] with cord-map ; inline
 115 M: cord n/v [ n/v ] with cord-map ; inline
 116 M: cord v+n '[ _ v+n ] cord-map ; inline
 117 M: cord v-n '[ _ v-n ] cord-map ; inline
 118 M: cord v*n '[ _ v*n ] cord-map ; inline
 119 M: cord v/n '[ _ v/n ] cord-map ; inline
 120
 121 M: cord norm-sq [ norm-sq ] cord-both + ; inline
 122 M: cord distance v- norm ; inline