basis/math/vectors/vectors.factor

   1 ! Copyright (C) 2005, 2010 Slava Pestov, Joe Groff.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays alien.c-types assocs kernel sequences math
   4 math.functions grouping math.order math.libm math.floats.private
   5 fry combinators byte-arrays accessors locals ;
   6 QUALIFIED-WITH: alien.c-types c
   7 IN: math.vectors
   8
   9 GENERIC: vneg ( v -- w )
  10 M: object vneg [ neg ] map ; inline
  11
  12 GENERIC#: v+n 1 ( v n -- w )
  13 M: object v+n [ + ] curry map ; inline
  14
  15 GENERIC: n+v ( n v -- w )
  16 M: object n+v [ + ] with map ; inline
  17
  18 GENERIC#: v-n 1 ( v n -- w )
  19 M: object v-n [ - ] curry map ; inline
  20
  21 GENERIC: n-v ( n v -- w )
  22 M: object n-v [ - ] with map ; inline
  23
  24 GENERIC#: v*n 1 ( v n -- w )
  25 M: object v*n [ * ] curry map ; inline
  26
  27 GENERIC: n*v ( n v -- w )
  28 M: object n*v [ * ] with map ; inline
  29
  30 GENERIC#: v/n 1 ( v n -- w )
  31 M: object v/n [ / ] curry map ; inline
  32
  33 GENERIC: n/v ( n v -- w )
  34 M: object n/v [ / ] with map ; inline
  35
  36 GENERIC: v+ ( u v -- w )
  37 M: object v+ [ + ] 2map ; inline
  38
  39 GENERIC: v- ( u v -- w )
  40 M: object v- [ - ] 2map ; inline
  41
  42 GENERIC: [v-] ( u v -- w )
  43 M: object [v-] [ [-] ] 2map ; inline
  44
  45 GENERIC: v* ( u v -- w )
  46 M: object v* [ * ] 2map ; inline
  47
  48 GENERIC: v*high ( u v -- w )
  49
  50 <PRIVATE
  51 : (h+) ( v -- w ) 2 <groups> [ first2 + ] map ;
  52 PRIVATE>
  53
  54 GENERIC: v*hs+ ( u v -- w )
  55 M: object v*hs+ [ * ] 2map (h+) ; inline
  56
  57 GENERIC: v/ ( u v -- w )
  58 M: object v/ [ / ] 2map ; inline
  59
  60 GENERIC: v^ ( u v -- w )
  61 M: object v^ [ ^ ] 2map ; inline
  62
  63 GENERIC: v^n ( v n -- w )
  64 M: object v^n [ ^ ] curry map ; inline
  65
  66 GENERIC: n^v ( n v -- w )
  67 M: object n^v [ ^ ] with map ; inline
  68
  69 GENERIC: vavg ( u v -- w )
  70 M: object vavg [ + 2 / ] 2map ; inline
  71
  72 GENERIC: vmax ( u v -- w )
  73 M: object vmax [ max ] 2map ; inline
  74
  75 GENERIC: vmin ( u v -- w )
  76 M: object vmin [ min ] 2map ; inline
  77
  78 GENERIC: v+- ( u v -- w )
  79 M: object v+-
  80     [ t ] 2dip
  81     [ [ not ] 2dip pick [ + ] [ - ] if ] 2map
  82     nip ; inline
  83
  84 GENERIC: vs+ ( u v -- w )
  85 M: object vs+ [ + ] 2map ; inline
  86
  87 GENERIC: vs- ( u v -- w )
  88 M: object vs- [ - ] 2map ; inline
  89
  90 GENERIC: vs* ( u v -- w )
  91 M: object vs* [ * ] 2map ; inline
  92
  93 GENERIC: vabs ( v -- w )
  94 M: object vabs [ abs ] map ; inline
  95
  96 GENERIC: vsqrt ( v -- w )
  97 M: object vsqrt [ >float fsqrt ] map ; inline
  98
  99 GENERIC: vsad ( u v -- n )
 100 M: object vsad [ - abs ] [ + ] 2map-reduce ; inline
 101
 102 <PRIVATE
 103
 104 : bitandn ( x y -- z ) [ bitnot ] dip bitand ; inline
 105
 106 PRIVATE>
 107
 108 GENERIC: vbitand ( u v -- w )
 109 M: object vbitand [ bitand ] 2map ; inline
 110 GENERIC: vbitandn ( u v -- w )
 111 M: object vbitandn [ bitandn ] 2map ; inline
 112 GENERIC: vbitor ( u v -- w )
 113 M: object vbitor [ bitor ] 2map ; inline
 114 GENERIC: vbitxor ( u v -- w )
 115 M: object vbitxor [ bitxor ] 2map ; inline
 116 GENERIC: vbitnot ( v -- w )
 117 M: object vbitnot [ bitnot ] map ; inline
 118
 119 GENERIC#: vbroadcast 1 ( u n -- v )
 120 M:: object vbroadcast ( u n -- v ) u length n u nth <repetition> u like ; inline
 121
 122 GENERIC#: vshuffle-elements 1 ( v perm -- w )
 123 M: object vshuffle-elements
 124     over length 0 pad-tail
 125     swap [ '[ _ nth ] ] keep map-as ; inline
 126
 127 GENERIC#: vshuffle2-elements 1 ( u v perm -- w )
 128 M: object vshuffle2-elements
 129     [ append ] dip vshuffle-elements ; inline
 130
 131 GENERIC#: vshuffle-bytes 1 ( v perm -- w )
 132
 133 GENERIC: vshuffle ( v perm -- w )
 134 M: array vshuffle ( v perm -- w )
 135     vshuffle-elements ; inline
 136
 137 GENERIC#: vlshift 1 ( v n -- w )
 138 M: object vlshift '[ _ shift ] map ; inline
 139 GENERIC#: vrshift 1 ( v n -- w )
 140 M: object vrshift neg '[ _ shift ] map ; inline
 141
 142 GENERIC#: hlshift 1 ( v n -- w )
 143 GENERIC#: hrshift 1 ( v n -- w )
 144
 145 GENERIC: (vmerge-head) ( u v -- h )
 146 M: object (vmerge-head) over length 2 /i '[ _ head-slice ] bi@ [ zip ] keep concat-as ; inline
 147 GENERIC: (vmerge-tail) ( u v -- t )
 148 M: object (vmerge-tail) over length 2 /i '[ _ tail-slice ] bi@ [ zip ] keep concat-as ; inline
 149
 150 : (vmerge) ( u v -- h t )
 151     [ (vmerge-head) ] [ (vmerge-tail) ] 2bi ; inline
 152
 153 GENERIC: vmerge ( u v -- w )
 154 M: object vmerge [ zip ] keep concat-as ; inline
 155
 156 GENERIC: vand ( u v -- w )
 157 M: object vand [ and ] 2map ; inline
 158
 159 GENERIC: vandn ( u v -- w )
 160 M: object vandn [ [ not ] dip and ] 2map ; inline
 161
 162 GENERIC: vor ( u v -- w )
 163 M: object vor [ or ] 2map ; inline
 164
 165 GENERIC: vxor ( u v -- w )
 166 M: object vxor [ xor ] 2map ; inline
 167
 168 GENERIC: vnot ( v -- w )
 169 M: object vnot [ not ] map ; inline
 170
 171 GENERIC: vall? ( v -- ? )
 172 M: object vall? [ ] all? ; inline
 173
 174 GENERIC: vcount ( v -- count )
 175 M: object vcount [ ] count ; inline
 176
 177 GENERIC: vany? ( v -- ? )
 178 M: object vany? [ ] any? ; inline
 179
 180 GENERIC: vnone? ( v -- ? )
 181 M: object vnone? [ not ] all? ; inline
 182
 183 GENERIC: v< ( u v -- w )
 184 M: object v< [ < ] 2map ; inline
 185
 186 GENERIC: v<= ( u v -- w )
 187 M: object v<= [ <= ] 2map ; inline
 188
 189 GENERIC: v>= ( u v -- w )
 190 M: object v>= [ >= ] 2map ; inline
 191
 192 GENERIC: v> ( u v -- w )
 193 M: object v> [ > ] 2map ; inline
 194
 195 GENERIC: vunordered? ( u v -- w )
 196 M: object vunordered? [ unordered? ] 2map ; inline
 197
 198 GENERIC: v= ( u v -- w )
 199 M: object v= [ = ] 2map ; inline
 200
 201 GENERIC: v? ( mask true false -- result )
 202 M: object v?
 203     [ vand ] [ vandn ] bi-curry* bi vor ; inline
 204
 205 : vif ( mask true-quot: ( -- vector ) false-quot: ( -- vector ) -- result )
 206     {
 207         { [ pick vall? ] [ drop nip call ] }
 208         { [ pick vnone? ] [ 2nip call ] }
 209         [ [ call ] dip call v? ]
 210     } cond ; inline
 211
 212 : v>integer ( v -- w ) [ >integer ] map ;
 213 : vfloor ( v -- w ) [ floor ] map ;
 214 : vceiling ( v -- w ) [ ceiling ] map ;
 215 : vtruncate ( v -- w ) [ truncate ] map ;
 216
 217 : vsupremum ( seq -- vmax ) [ ] [ vmax ] map-reduce ; inline
 218 : vinfimum ( seq -- vmin ) [ ] [ vmin ] map-reduce ; inline
 219
 220 GENERIC: v. ( u v -- x )
 221 M: object v. [ * ] [ + ] 2map-reduce ; inline
 222
 223 GENERIC: h. ( u v -- x )
 224 M: object h. [ conjugate * ] [ + ] 2map-reduce ; inline
 225
 226 GENERIC: norm-sq ( v -- x )
 227 M: object norm-sq [ absq ] [ + ] map-reduce ; inline
 228
 229 : l1-norm ( v -- x ) [ abs ] map-sum ; inline
 230
 231 : norm ( v -- x ) norm-sq sqrt ; inline
 232
 233 : p-norm-default ( v p -- x )
 234     [ [ [ abs ] dip ^ ] curry map-sum ] keep recip ^ ; inline
 235
 236 : p-norm ( v p -- x )
 237     {
 238         { [ dup 1 = ] [ drop l1-norm ] }
 239         { [ dup 2 = ] [ drop norm ] }
 240         { [ dup fp-infinity? ] [ drop supremum ] }
 241         [ p-norm-default ]
 242     } cond ;
 243
 244 : normalize ( v -- w ) dup norm v/n ; inline
 245
 246 GENERIC: distance ( u v -- x )
 247 M: object distance [ - absq ] [ + ] 2map-reduce sqrt ; inline
 248
 249 : set-axis ( u v axis -- w )
 250     [ [ zero? 2over ? ] dip swap nth ] map-index 2nip ;
 251
 252 <PRIVATE
 253
 254 : 2tetra@ ( p q r s t u v w quot -- )
 255     dup [ [ 2bi@ ] curry 4dip ] dip 2bi@ ; inline
 256
 257 PRIVATE>
 258
 259 : trilerp ( aaa baa aba bba aab bab abb bbb {t,u,v} -- a_tuv )
 260     [ first lerp ] [ second lerp ] [ third lerp ] tri-curry
 261     [ 2tetra@ ] [ 2bi@ ] [ call ] tri* ; inline
 262
 263 : bilerp ( aa ba ab bb {t,u} -- a_tu )
 264     [ first lerp ] [ second lerp ] bi-curry
 265     [ 2bi@ ] [ call ] bi* ; inline
 266
 267 : vlerp ( a b t -- a_t )
 268     [ over v- ] dip v* v+ ; inline
 269
 270 : vnlerp ( a b t -- a_t )
 271     [ over v- ] dip v*n v+ ; inline
 272
 273 : vbilerp ( aa ba ab bb {t,u} -- a_tu )
 274     [ first vnlerp ] [ second vnlerp ] bi-curry
 275     [ 2bi@ ] [ call ] bi* ; inline
 276
 277 : v~ ( a b epsilon -- ? )
 278     [ ~ ] curry 2all? ; inline
 279
 280 : vclamp ( v min max -- w )
 281     rot vmin vmax ; inline