1 ! Copyright (C) 2010 Slava Pestov.
2 USING: gml.types gml.printer gml.runtime math math.constants
3 math.functions math.matrices math.order math.ranges math.trig
4 math.vectors continuations combinators arrays kernel vectors
5 accessors prettyprint fry sequences assocs locals hashtables
6 grouping sorting classes.struct math.vectors.simd
7 math.vectors.simd.cords random random.mersenne-twister
11 ! :: gml-scalar-op ( a b scalar-quot mixed-quot vector-quot -- c )
13 ! { [ b float? ] [ a b scalar-quot call ] }
14 ! { [ b integer? ] [ a b scalar-quot call ] }
15 ! { [ b vec2d? ] [ a scalar>vec2d b mixed-quot call ] }
16 ! { [ b vec3d? ] [ a scalar>vec3d b mixed-quot call ] }
19 ! :: gml-math-op ( a b scalar-quot mixed-quot vector-quot -- c )
21 ! { [ a float? ] [ a b scalar-quot mixed-quot vector-quot gml-scalar-op ] }
22 ! { [ a integer? ] [ a b scalar-quot mixed-quot vector-quot gml-scalar-op ] }
25 ! { [ b vec2d? ] [ a b vector-quot call ] }
26 ! { [ b float? ] [ a b scalar>vec2d mixed-quot call ] }
27 ! { [ b integer? ] [ a b scalar>vec2d mixed-quot call ] }
32 ! { [ b vec3d? ] [ a b vector-quot call ] }
33 ! { [ b float? ] [ a b scalar>vec3d mixed-quot call ] }
34 ! { [ b integer? ] [ a b scalar>vec3d mixed-quot call ] }
39 ! Don't use locals here until a limitation in the propagation pass
40 ! is fixed (constraints on slots). Maybe optimizing GML math ops
41 ! like this isn't worth it anyway, since GML is interpreted
42 FROM: generalizations => npick ;
44 : gml-scalar-op ( a b scalar-quot mixed-quot vector-quot -- c )
46 { [ 4 npick float? ] [ 2drop call ] }
47 { [ 4 npick integer? ] [ 2drop call ] }
48 { [ 4 npick vec2d? ] [ drop nip [ scalar>vec2d ] 2dip call ] }
49 { [ 4 npick vec3d? ] [ drop nip [ scalar>vec3d ] 2dip call ] }
52 : gml-math-op ( a b scalar-quot mixed-quot vector-quot -- c )
54 { [ 5 npick float? ] [ gml-scalar-op ] }
55 { [ 5 npick integer? ] [ gml-scalar-op ] }
56 { [ 5 npick vec2d? ] [
58 { [ 4 npick vec2d? ] [ 2nip call ] }
59 { [ 4 npick float? ] [ drop nip [ scalar>vec2d ] dip call ] }
60 { [ 4 npick integer? ] [ drop nip [ scalar>vec2d ] dip call ] }
63 { [ 5 npick vec3d? ] [
65 { [ 4 npick vec3d? ] [ 2nip call ] }
66 { [ 4 npick float? ] [ drop nip [ scalar>vec3d ] dip call ] }
67 { [ 4 npick integer? ] [ drop nip [ scalar>vec3d ] dip call ] }
72 GML: add ( a b -- c ) [ + ] [ v+ ] [ v+ ] gml-math-op ;
73 GML: sub ( a b -- c ) [ - ] [ v- ] [ v- ] gml-math-op ;
74 GML: mul ( a b -- c ) [ * ] [ v* ] [ v. ] gml-math-op ;
75 GML: div ( a b -- c ) [ /f ] [ v/ mask-vec3d ] [ v/ mask-vec3d ] gml-math-op ;
76 GML: mod ( a b -- c ) mod ;
80 { [ dup integer? ] [ neg ] }
81 { [ dup float? ] [ neg ] }
82 { [ dup vec2d? ] [ vneg ] }
83 { [ dup vec3d? ] [ vneg mask-vec3d ] }
86 GML: eq ( a b -- c ) = >true ;
87 GML: ne ( a b -- c ) = not >true ;
88 GML: ge ( a b -- c ) >= >true ;
89 GML: gt ( a b -- c ) > >true ;
90 GML: le ( a b -- c ) <= >true ;
91 GML: lt ( a b -- c ) < >true ;
94 GML: sin ( x -- y ) >float deg>rad sin ;
95 GML: asin ( x -- y ) >float asin rad>deg ;
96 GML: cos ( x -- y ) >float deg>rad cos ;
97 GML: acos ( x -- y ) >float acos rad>deg ;
98 GML: tan ( x -- y ) >float deg>rad tan ;
99 GML: atan ( x -- y ) >float atan rad>deg ;
101 FROM: math.libm => fatan2 ;
102 GML: atan2 ( x y -- z ) [ >float ] bi@ fatan2 rad>deg ;
104 GML: pi ( -- pi ) pi ;
107 : logical-op ( a b quot -- c ) [ [ true? ] bi@ ] dip call >true ; inline
109 GML: and ( a b -- c ) [ and ] logical-op ;
110 GML: or ( a b -- c ) [ or ] logical-op ;
111 GML: not ( a -- b ) 0 number= >true ;
116 { [ dup integer? ] [ abs ] }
117 { [ dup float? ] [ abs ] }
118 { [ dup vec2d? ] [ norm ] }
119 { [ dup vec3d? ] [ norm ] }
122 : must-be-positive ( x -- x ) dup 0 < [ "Domain error" throw ] when ; inline
124 GML: sqrt ( x -- y ) must-be-positive sqrt ;
125 GML: inv ( x -- y ) >float recip ;
126 GML: log ( x -- y ) must-be-positive log10 ;
127 GML: ln ( x -- y ) must-be-positive log ;
128 GML: exp ( x -- y ) e^ ;
129 GML: pow ( x y -- z ) [ >float ] bi@ ^ ;
131 GML: ceiling ( x -- y ) ceiling ;
132 GML: floor ( x -- y ) floor ;
133 GML: trunc ( x -- y ) truncate ;
134 GML: round ( x -- y ) round ;
136 GML: clamp ( x v -- y ) first2 clamp ;
139 GML: getX ( vec -- x )
141 { [ dup vec2d? ] [ first ] }
142 { [ dup vec3d? ] [ first ] }
145 GML: getY ( vec -- x )
147 { [ dup vec2d? ] [ second ] }
148 { [ dup vec3d? ] [ second ] }
151 GML: getZ ( vec -- x )
153 { [ dup vec3d? ] [ third ] }
156 GML: putX ( vec x -- x )
158 { [ over vec2d? ] [ [ second ] dip swap <vec2d> ] }
159 { [ over vec3d? ] [ [ [ second ] [ third ] bi ] dip -rot <vec3d> ] }
162 GML: putY ( vec y -- x )
164 { [ over vec2d? ] [ [ first ] dip <vec2d> ] }
165 { [ over vec3d? ] [ [ [ first ] [ third ] bi ] dip swap <vec3d> ] }
168 GML: putZ ( vec z -- x )
170 { [ over vec3d? ] [ [ first2 ] dip <vec3d> ] }
173 GML: dist ( u v -- x ) distance ;
175 GML: normalize ( u -- v ) normalize mask-vec3d ;
177 GML: planemul ( u v p -- w )
178 first2 [ v*n ] bi-curry@ bi* v+ ;
180 GML: cross ( u v -- w ) cross ;
182 : normal ( vec -- norm )
183 [ first double-4{ 0 1 0 0 } n*v ]
184 [ second double-4{ -1 0 0 0 } n*v ]
185 [ third double-4{ -1 0 0 0 } n*v ] tri v+ v+ ; inline
187 GML: aNormal ( x -- y )
189 { [ dup vec2d? ] [ normalize double-2{ 1 -1 } v* { 1 0 } vshuffle ] }
190 { [ dup vec3d? ] [ normalize normal ] }
194 { 1 0 } vshuffle double-2{ 1 -1 } v* v* sum ; inline
196 : det3 ( x y z -- w )
197 [ cross ] dip v. ; inline
199 GML: determinant ( x -- y )
201 { [ dup vec2d? ] [ [ dup pop-operand ] dip det2 ] }
202 { [ dup vec3d? ] [ [ dup [ pop-operand ] [ pop-operand ] bi swap ] dip det3 ] }
205 GML: vector2 ( x y -- v ) <vec2d> ;
207 GML: vector3 ( x y z -- v ) <vec3d> ;
209 GML: random ( -- x ) 0.0 1.0 uniform-random-float ;
211 GML: randomseed ( n -- )
212 dup 0 < [ drop nano-count 1000000 /i ] when
213 <mersenne-twister> random-generator set ;
215 ! Extensions to real GML
216 GML: approx-eq ( a b -- c )
217 [ 10e-5 ~ ] [ 10e-5 v~ ] [ 10e-5 v~ ] gml-math-op >true ;