diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index 69d8929c65..6cb16e5efc 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -1,49 +1,49 @@ -! Copyright (C) 2005, 2009 Slava Pestov. +! Copyright (C) 2005, 2010 Slava Pestov, Joe Groff. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays alien.c-types assocs kernel sequences math math.functions -grouping hints math.order math.libm math.floats.private fry combinators -byte-arrays accessors locals ; +USING: arrays alien.c-types assocs kernel sequences math +math.functions grouping math.order math.libm math.floats.private +fry combinators byte-arrays accessors locals ; QUALIFIED-WITH: alien.c-types c IN: math.vectors GENERIC: vneg ( u -- v ) -M: object vneg [ neg ] map ; +M: object vneg [ neg ] map ; inline GENERIC# v+n 1 ( u n -- w ) -M: object v+n [ + ] curry map ; +M: object v+n [ + ] curry map ; inline GENERIC: n+v ( n v -- w ) -M: object n+v [ + ] with map ; +M: object n+v [ + ] with map ; inline GENERIC# v-n 1 ( u n -- w ) -M: object v-n [ - ] curry map ; +M: object v-n [ - ] curry map ; inline GENERIC: n-v ( n v -- w ) -M: object n-v [ - ] with map ; +M: object n-v [ - ] with map ; inline GENERIC# v*n 1 ( u n -- w ) -M: object v*n [ * ] curry map ; +M: object v*n [ * ] curry map ; inline GENERIC: n*v ( n v -- w ) -M: object n*v [ * ] with map ; +M: object n*v [ * ] with map ; inline GENERIC# v/n 1 ( u n -- w ) -M: object v/n [ / ] curry map ; +M: object v/n [ / ] curry map ; inline GENERIC: n/v ( n v -- w ) -M: object n/v [ / ] with map ; +M: object n/v [ / ] with map ; inline GENERIC: v+ ( u v -- w ) -M: object v+ [ + ] 2map ; +M: object v+ [ + ] 2map ; inline GENERIC: v- ( u v -- w ) -M: object v- [ - ] 2map ; +M: object v- [ - ] 2map ; inline GENERIC: [v-] ( u v -- w ) -M: object [v-] [ [-] ] 2map ; +M: object [v-] [ [-] ] 2map ; inline GENERIC: v* ( u v -- w ) -M: object v* [ * ] 2map ; +M: object v* [ * ] 2map ; inline GENERIC: v*high ( u v -- w ) @@ -53,43 +53,43 @@ GENERIC: v*high ( u v -- w ) PRIVATE> GENERIC: v*hs+ ( u v -- w ) -M: object v*hs+ [ * ] 2map (h+) ; +M: object v*hs+ [ * ] 2map (h+) ; inline GENERIC: v/ ( u v -- w ) -M: object v/ [ / ] 2map ; +M: object v/ [ / ] 2map ; inline GENERIC: vavg ( u v -- w ) -M: object vavg [ + 2 / ] 2map ; +M: object vavg [ + 2 / ] 2map ; inline GENERIC: vmax ( u v -- w ) -M: object vmax [ max ] 2map ; +M: object vmax [ max ] 2map ; inline GENERIC: vmin ( u v -- w ) -M: object vmin [ min ] 2map ; +M: object vmin [ min ] 2map ; inline GENERIC: v+- ( u v -- w ) M: object v+- [ t ] 2dip [ [ not ] 2dip pick [ + ] [ - ] if ] 2map - nip ; + nip ; inline GENERIC: vs+ ( u v -- w ) -M: object vs+ [ + ] 2map ; +M: object vs+ [ + ] 2map ; inline GENERIC: vs- ( u v -- w ) -M: object vs- [ - ] 2map ; +M: object vs- [ - ] 2map ; inline GENERIC: vs* ( u v -- w ) -M: object vs* [ * ] 2map ; +M: object vs* [ * ] 2map ; inline GENERIC: vabs ( u -- v ) -M: object vabs [ abs ] map ; +M: object vabs [ abs ] map ; inline GENERIC: vsqrt ( u -- v ) -M: object vsqrt [ >float fsqrt ] map ; +M: object vsqrt [ >float fsqrt ] map ; inline GENERIC: vsad ( u v -- n ) -M: object vsad [ - abs ] [ + ] 2map-reduce ; +M: object vsad [ - abs ] [ + ] 2map-reduce ; inline GENERIC: vbitand ( u v -- w ) -M: object vbitand [ bitand ] 2map ; +M: object vbitand [ bitand ] 2map ; inline GENERIC: vbitandn ( u v -- w ) -M: object vbitandn [ bitandn ] 2map ; +M: object vbitandn [ bitandn ] 2map ; inline GENERIC: vbitor ( u v -- w ) -M: object vbitor [ bitor ] 2map ; +M: object vbitor [ bitor ] 2map ; inline GENERIC: vbitxor ( u v -- w ) -M: object vbitxor [ bitxor ] 2map ; +M: object vbitxor [ bitxor ] 2map ; inline GENERIC: vbitnot ( u -- w ) -M: object vbitnot [ bitnot ] map ; +M: object vbitnot [ bitnot ] map ; inline GENERIC# vbroadcast 1 ( u n -- v ) -M:: object vbroadcast ( u n -- v ) u length n u nth u like ; +M:: object vbroadcast ( u n -- v ) u length n u nth u like ; inline GENERIC# vshuffle-elements 1 ( u perm -- v ) M: object vshuffle-elements over length 0 pad-tail - swap [ '[ _ nth ] ] keep map-as ; + swap [ '[ _ nth ] ] keep map-as ; inline GENERIC# vshuffle-bytes 1 ( u perm -- v ) @@ -123,66 +123,66 @@ M: array vshuffle ( u perm -- v ) vshuffle-elements ; inline GENERIC# vlshift 1 ( u n -- w ) -M: object vlshift '[ _ shift ] map ; +M: object vlshift '[ _ shift ] map ; inline GENERIC# vrshift 1 ( u n -- w ) -M: object vrshift neg '[ _ shift ] map ; +M: object vrshift neg '[ _ shift ] map ; inline GENERIC# hlshift 1 ( u n -- w ) GENERIC# hrshift 1 ( u n -- w ) GENERIC: (vmerge-head) ( u v -- h ) -M: object (vmerge-head) over length 2 /i '[ _ head-slice ] bi@ [ zip ] keep concat-as ; +M: object (vmerge-head) over length 2 /i '[ _ head-slice ] bi@ [ zip ] keep concat-as ; inline GENERIC: (vmerge-tail) ( u v -- t ) -M: object (vmerge-tail) over length 2 /i '[ _ tail-slice ] bi@ [ zip ] keep concat-as ; +M: object (vmerge-tail) over length 2 /i '[ _ tail-slice ] bi@ [ zip ] keep concat-as ; inline GENERIC: (vmerge) ( u v -- h t ) M: object (vmerge) [ (vmerge-head) ] [ (vmerge-tail) ] 2bi ; inline GENERIC: vmerge ( u v -- w ) -M: object vmerge [ zip ] keep concat-as ; +M: object vmerge [ zip ] keep concat-as ; inline GENERIC: vand ( u v -- w ) -M: object vand [ and ] 2map ; +M: object vand [ and ] 2map ; inline GENERIC: vandn ( u v -- w ) -M: object vandn [ [ not ] dip and ] 2map ; +M: object vandn [ [ not ] dip and ] 2map ; inline GENERIC: vor ( u v -- w ) -M: object vor [ or ] 2map ; +M: object vor [ or ] 2map ; inline GENERIC: vxor ( u v -- w ) -M: object vxor [ xor ] 2map ; +M: object vxor [ xor ] 2map ; inline GENERIC: vnot ( u -- w ) -M: object vnot [ not ] map ; +M: object vnot [ not ] map ; inline GENERIC: vall? ( v -- ? ) -M: object vall? [ ] all? ; +M: object vall? [ ] all? ; inline GENERIC: vany? ( v -- ? ) -M: object vany? [ ] any? ; +M: object vany? [ ] any? ; inline GENERIC: vnone? ( v -- ? ) -M: object vnone? [ not ] all? ; +M: object vnone? [ not ] all? ; inline GENERIC: v< ( u v -- w ) -M: object v< [ < ] 2map ; +M: object v< [ < ] 2map ; inline GENERIC: v<= ( u v -- w ) -M: object v<= [ <= ] 2map ; +M: object v<= [ <= ] 2map ; inline GENERIC: v>= ( u v -- w ) -M: object v>= [ >= ] 2map ; +M: object v>= [ >= ] 2map ; inline GENERIC: v> ( u v -- w ) -M: object v> [ > ] 2map ; +M: object v> [ > ] 2map ; inline GENERIC: vunordered? ( u v -- w ) -M: object vunordered? [ unordered? ] 2map ; +M: object vunordered? [ unordered? ] 2map ; inline GENERIC: v= ( u v -- w ) -M: object v= [ = ] 2map ; +M: object v= [ = ] 2map ; inline GENERIC: v? ( mask true false -- result ) M: object v? @@ -203,17 +203,17 @@ M: object v? : vinfimum ( seq -- vmin ) [ ] [ vmin ] map-reduce ; inline GENERIC: v. ( u v -- x ) -M: object v. [ conjugate * ] [ + ] 2map-reduce ; +M: object v. [ conjugate * ] [ + ] 2map-reduce ; inline GENERIC: norm-sq ( v -- x ) -M: object norm-sq [ absq ] [ + ] map-reduce ; +M: object norm-sq [ absq ] [ + ] map-reduce ; inline : norm ( v -- x ) norm-sq sqrt ; inline : normalize ( u -- v ) dup norm v/n ; inline GENERIC: distance ( u v -- x ) -M: object distance [ - absq ] [ + ] 2map-reduce sqrt ; +M: object distance [ - absq ] [ + ] 2map-reduce sqrt ; inline : set-axis ( u v axis -- w ) [ [ zero? 2over ? ] dip swap nth ] map-index 2nip ; @@ -245,28 +245,3 @@ PRIVATE> : v~ ( a b epsilon -- ? ) [ ~ ] curry 2all? ; inline - -HINTS: M\ object vneg { array } ; -HINTS: M\ object norm-sq { array } ; -HINTS: norm { array } ; -HINTS: M\ object distance { array array } ; - -HINTS: M\ object n*v { object array } ; -HINTS: M\ object v*n { array object } ; -HINTS: M\ object n/v { object array } ; -HINTS: M\ object v/n { array object } ; - -HINTS: M\ object v+ { array array } ; -HINTS: M\ object v- { array array } ; -HINTS: M\ object v* { array array } ; -HINTS: M\ object v/ { array array } ; -HINTS: M\ object vmax { array array } ; -HINTS: M\ object vmin { array array } ; -HINTS: M\ object v. { array array } ; - -HINTS: vlerp { array array array } ; -HINTS: vnlerp { array array object } ; - -HINTS: bilerp { object object object object array } ; -HINTS: trilerp { object object object object object object object object array } ; - diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor index ba7c2723e9..eda793ff22 100644 --- a/basis/specialized-arrays/specialized-arrays.factor +++ b/basis/specialized-arrays/specialized-arrays.factor @@ -101,11 +101,11 @@ SYNTAX: A@ scan-object scan-object suffix! ; INSTANCE: A specialized-array -M: A vs+ [ + \ T c-type-clamp ] 2map ; -M: A vs- [ - \ T c-type-clamp ] 2map ; -M: A vs* [ * \ T c-type-clamp ] 2map ; +M: A vs+ [ + \ T c-type-clamp ] 2map ; inline +M: A vs- [ - \ T c-type-clamp ] 2map ; inline +M: A vs* [ * \ T c-type-clamp ] 2map ; inline -M: A v*high [ * \ T heap-size neg shift ] 2map ; +M: A v*high [ * \ T heap-size neg shift ] 2map ; inline ;FUNCTOR diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 7d1e45aca0..b8a8d5f89d 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -221,8 +221,8 @@ TUPLE: slice-error from to seq reason ; 3tri ; inline : ( from to seq -- slice ) - dup slice? [ collapse-slice ] when check-slice + dup slice? [ collapse-slice ] when slice boa ; inline M: slice virtual-exemplar seq>> ; inline @@ -836,6 +836,12 @@ PRIVATE> [ 3dup ] dip [ + swap nth-unsafe ] keep rot nth-unsafe = ] all? nip ; inline +: prepare-2map-reduce ( seq1 seq2 map-quot -- initial length seq1 seq2 ) + [ drop min-length dup 1 < [ "Empty sequence" throw ] when 1 - ] + [ drop [ [ 1 + ] 2dip 2nth-unsafe ] 2curry ] + [ [ [ first-unsafe ] bi@ ] dip call ] + 3tri -rot ; inline + PRIVATE> : start* ( subseq seq n -- i ) @@ -868,8 +874,8 @@ PRIVATE> compose reduce ; inline : 2map-reduce ( seq1 seq2 map-quot reduce-quot -- result ) - [ [ 2unclip-slice ] dip [ call ] keep ] dip - compose 2reduce ; inline + [ [ prepare-2map-reduce ] keep ] dip + compose compose each-integer ; inline