dup [ array? ] all? [ first ] when length ;
SYNTAX: HINTS:
- scan-object
+ scan-object dup wrapper? [ wrapped>> ] when
[ changed-definition ]
[ parse-definition { } like "specializer" set-word-prop ] bi ;
[ empty-interval ] [ 2 2 (a,b) ] unit-test
+[ empty-interval ] [ 2 2.0 (a,b) ] unit-test
+
[ empty-interval ] [ 2 2 [a,b) ] unit-test
[ empty-interval ] [ 2 2 (a,b] ] unit-test
[ f ] [ 0 10 [a,b] 0 [a,a] interval< ] unit-test
+[ f ] [ 0 10 [a,b] 0.0 [a,a] interval< ] unit-test
+
+[ f ] [ 0.0 10 [a,b] 0 [a,a] interval< ] unit-test
+
[ f ] [ 0 10 [a,b] 10 [a,a] interval> ] unit-test
[ incomparable ] [ 0 [a,a] 0 10 [a,b] interval< ] unit-test
-! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
+! Copyright (C) 2007, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
! Based on Slate's src/unfinished/interval.slate by Brian Rice.
USING: accessors kernel sequences arrays math math.order
: <interval> ( from to -- interval )
2dup [ first ] bi@ {
{ [ 2dup > ] [ 2drop 2drop empty-interval ] }
- { [ 2dup = ] [
+ { [ 2dup number= ] [
2drop 2dup [ second ] both?
[ interval boa ] [ 2drop empty-interval ] if
] }
[ 2dup [ first ] bi@ ] dip call [
2drop t
] [
- 2dup [ first ] bi@ = [
+ 2dup [ first ] bi@ number= [
[ second ] bi@ not or
] [
2drop f
] if
] if ; inline
+: endpoint= ( p1 p2 -- ? )
+ [ [ first ] bi@ number= ] [ [ second ] bi@ eq? ] 2bi and ;
+
: endpoint< ( p1 p2 -- ? ) [ < ] compare-endpoints ;
-: endpoint<= ( p1 p2 -- ? ) [ endpoint< ] 2keep = or ;
+: endpoint<= ( p1 p2 -- ? ) [ endpoint< ] [ endpoint= ] 2bi or ;
: endpoint> ( p1 p2 -- ? ) [ > ] compare-endpoints ;
-: endpoint>= ( p1 p2 -- ? ) [ endpoint> ] 2keep = or ;
+: endpoint>= ( p1 p2 -- ? ) [ endpoint> ] [ endpoint= ] 2bi or ;
: endpoint-min ( p1 p2 -- p3 ) [ endpoint< ] most ;
] [
interval>points
2dup [ second ] both?
- [ [ first ] bi@ = ]
+ [ [ first ] bi@ number= ]
[ 2drop f ] if
] if ;
: left-endpoint-< ( i1 i2 -- ? )
[ swap interval-subset? ]
[ nip interval-singleton? ]
- [ [ from>> ] bi@ = ]
+ [ [ from>> ] bi@ endpoint= ]
2tri and and ;
: right-endpoint-< ( i1 i2 -- ? )
[ interval-subset? ]
[ drop interval-singleton? ]
- [ [ to>> ] bi@ = ]
+ [ [ to>> ] bi@ endpoint= ]
2tri and and ;
: (interval<) ( i1 i2 -- i1 i2 ? )
} cond 2nip ;
: left-endpoint-<= ( i1 i2 -- ? )
- [ from>> ] dip to>> = ;
+ [ from>> ] [ to>> ] bi* endpoint= ;
: right-endpoint-<= ( i1 i2 -- ? )
- [ to>> ] dip from>> = ;
+ [ to>> ] [ from>> ] bi* endpoint= ;
: interval<= ( i1 i2 -- ? )
{
--- /dev/null
+IN: math.vectors.specialization.tests
+USING: compiler.tree.debugger math.vectors tools.test kernel
+kernel.private math specialized-arrays.double
+specialized-arrays.float ;
+
+[ V{ t } ] [
+ [ { double-array double-array } declare distance 0.0 < not ] final-literals
+] unit-test
+
+[ V{ float } ] [
+ [ { float-array float } declare v*n norm ] final-classes
+] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: words kernel make sequences effects kernel.private accessors
+combinators math math.intervals math.vectors namespaces assocs fry
+splitting classes.algebra generalizations
+compiler.tree.propagation.info ;
+IN: math.vectors.specialization
+
+SYMBOLS: -> +vector+ +scalar+ +nonnegative+ ;
+
+: signature-for-schema ( array-type elt-type schema -- signature )
+ [
+ {
+ { +vector+ [ drop ] }
+ { +scalar+ [ nip ] }
+ { +nonnegative+ [ nip ] }
+ } case
+ ] with with map ;
+
+: (specialize-vector-word) ( word array-type elt-type schema -- word' )
+ signature-for-schema
+ [ [ name>> ] [ [ name>> ] map "," join ] bi* "=>" glue f <word> ]
+ [ [ , \ declare , def>> % ] [ ] make ]
+ [ drop stack-effect ]
+ 2tri
+ [ define-declared ] [ 2drop ] 3bi ;
+
+: output-infos ( array-type elt-type schema -- value-infos )
+ [
+ {
+ { +vector+ [ drop <class-info> ] }
+ { +scalar+ [ nip <class-info> ] }
+ { +nonnegative+ [ nip real class-and [0,inf] <class/interval-info> ] }
+ } case
+ ] with with map ;
+
+: record-output-signature ( word array-type elt-type schema -- word )
+ output-infos
+ [ drop ]
+ [ drop ]
+ [ [ stack-effect in>> length '[ _ ndrop ] ] dip append ] 2tri
+ "outputs" set-word-prop ;
+
+CONSTANT: vector-words
+H{
+ { [v-] { +vector+ +vector+ -> +vector+ } }
+ { distance { +vector+ +vector+ -> +nonnegative+ } }
+ { n*v { +scalar+ +vector+ -> +vector+ } }
+ { n+v { +scalar+ +vector+ -> +vector+ } }
+ { n-v { +scalar+ +vector+ -> +vector+ } }
+ { n/v { +scalar+ +vector+ -> +vector+ } }
+ { norm { +vector+ -> +nonnegative+ } }
+ { norm-sq { +vector+ -> +nonnegative+ } }
+ { normalize { +vector+ -> +vector+ } }
+ { v* { +vector+ +vector+ -> +vector+ } }
+ { v*n { +vector+ +scalar+ -> +vector+ } }
+ { v+ { +vector+ +vector+ -> +vector+ } }
+ { v+n { +vector+ +scalar+ -> +vector+ } }
+ { v- { +vector+ +vector+ -> +vector+ } }
+ { v-n { +vector+ +scalar+ -> +vector+ } }
+ { v. { +vector+ +vector+ -> +scalar+ } }
+ { v/ { +vector+ +vector+ -> +vector+ } }
+ { v/n { +vector+ +scalar+ -> +vector+ } }
+ { vceiling { +vector+ -> +vector+ } }
+ { vfloor { +vector+ -> +vector+ } }
+ { vmax { +vector+ +vector+ -> +vector+ } }
+ { vmin { +vector+ +vector+ -> +vector+ } }
+ { vneg { +vector+ -> +vector+ } }
+ { vtruncate { +vector+ -> +vector+ } }
+}
+
+SYMBOL: specializations
+
+specializations [ vector-words keys [ V{ } clone ] H{ } map>assoc ] initialize
+
+: add-specialization ( new-word signature word -- )
+ specializations get at set-at ;
+
+: word-schema ( word -- schema ) vector-words at ;
+
+: inputs ( schema -- seq ) { -> } split first ;
+
+: outputs ( schema -- seq ) { -> } split second ;
+
+: specialize-vector-word ( word array-type elt-type -- word' )
+ pick word-schema
+ [ inputs (specialize-vector-word) ]
+ [ outputs record-output-signature ] 3bi ;
+
+: input-signature ( word -- signature ) def>> first ;
+
+: specialize-vector-words ( array-type elt-type -- )
+ [ vector-words keys ] 2dip
+ '[
+ [ _ _ specialize-vector-word ] keep
+ [ dup input-signature ] dip
+ add-specialization
+ ] each ;
+
+: find-specialization ( classes word -- word/f )
+ specializations get at
+ [ first [ class<= ] 2all? ] with find
+ swap [ second ] when ;
+
+: vector-word-custom-inlining ( #call -- word/f )
+ [ in-d>> [ value-info class>> ] map ] [ word>> ] bi
+ find-specialization ;
+
+vector-words keys [
+ [ vector-word-custom-inlining ]
+ "custom-inlining" set-word-prop
+] each
\ No newline at end of file
: set-axis ( u v axis -- w )
[ [ zero? 2over ? ] dip swap nth ] map-index 2nip ;
+<PRIVATE
+
: 2tetra@ ( p q r s t u v w quot -- )
dup [ [ 2bi@ ] curry 4dip ] dip 2bi@ ; inline
+PRIVATE>
+
: trilerp ( aaa baa aba bba aab bab abb bbb {t,u,v} -- a_tuv )
[ first lerp ] [ second lerp ] [ third lerp ] tri-curry
[ 2tetra@ ] [ 2bi@ ] [ call ] tri* ;
HINTS: (double-array) { 2 } { 3 } ;
-HINTS: vneg { array } { double-array } ;
-HINTS: v*n { array object } { double-array float } ;
-HINTS: n*v { array object } { float double-array } ;
-HINTS: v/n { array object } { double-array float } ;
-HINTS: n/v { object array } { float double-array } ;
-HINTS: v+ { array array } { double-array double-array } ;
-HINTS: v- { array array } { double-array double-array } ;
-HINTS: v* { array array } { double-array double-array } ;
-HINTS: v/ { array array } { double-array double-array } ;
-HINTS: vmax { array array } { double-array double-array } ;
-HINTS: vmin { array array } { double-array double-array } ;
-HINTS: v. { array array } { double-array double-array } ;
-HINTS: norm-sq { array } { double-array } ;
-HINTS: norm { array } { double-array } ;
-HINTS: normalize { array } { double-array } ;
-HINTS: distance { array array } { double-array double-array } ;
-
! Type functions
USING: words classes.algebra compiler.tree.propagation.info
math.intervals ;
-{ v+ v- v* v/ vmax vmin } [
- [
- [ class>> double-array class<= ] both?
- double-array object ? <class-info>
- ] "outputs" set-word-prop
-] each
-
-{ n*v n/v } [
- [
- nip class>> double-array class<= double-array object ? <class-info>
- ] "outputs" set-word-prop
-] each
-
-{ v*n v/n } [
- [
- drop class>> double-array class<= double-array object ? <class-info>
- ] "outputs" set-word-prop
-] each
-
-{ vneg normalize } [
- [
- class>> double-array class<= double-array object ? <class-info>
- ] "outputs" set-word-prop
-] each
-
\ norm-sq [
class>> double-array class<= [ float 0. 1/0. [a,b] <class/interval-info> ] [ object-info ] if
] "outputs" set-word-prop
-\ v. [
- [ class>> double-array class<= ] both?
- float object ? <class-info>
-] "outputs" set-word-prop
-
\ distance [
[ class>> double-array class<= ] both?
[ float 0. 1/0. [a,b] <class/interval-info> ] [ object-info ] if
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: functors sequences sequences.private prettyprint.custom
-kernel words classes math parser alien.c-types byte-arrays
-accessors summary ;
+kernel words classes math math.vectors.specialization parser
+alien.c-types byte-arrays accessors summary ;
IN: specialized-arrays.functor
ERROR: bad-byte-array-length byte-array type ;
INSTANCE: A sequence
+A T c-type class>> specialize-vector-words
+
;FUNCTOR
M: sphere intersect-scene ( hit ray sphere -- hit )
[ [ sphere-n normalize ] keep <hit> nip ] if-ray-sphere ;
+HINTS: M\ sphere intersect-scene { hit ray sphere } ;
+
TUPLE: group < sphere { objs array read-only } ;
: <group> ( objs bound -- group )
M: group intersect-scene ( hit ray group -- hit )
[ drop objs>> [ intersect-scene ] with each ] if-ray-sphere ;
+HINTS: M\ group intersect-scene { hit ray group } ;
+
CONSTANT: initial-hit T{ hit f double-array{ 0.0 0.0 0.0 } 1/0. }
: initial-intersect ( ray scene -- hit )