extra/gml/coremath/coremath.factor

   1 ! Copyright (C) 2010 Slava Pestov.
   2 USING: gml.types gml.printer gml.runtime math math.constants
   3 math.functions math.matrices math.order 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
   8 system namespaces ;
   9 IN: gml.coremath
  10
  11 ! :: gml-scalar-op ( a b scalar-quot mixed-quot vector-quot -- c )
  12 !     {
  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 ] }
  17 !     } cond ; inline
  18 !
  19 ! :: gml-math-op ( a b scalar-quot mixed-quot vector-quot -- c )
  20 !     {
  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 ] }
  23 !         { [ a vec2d? ] [
  24 !             {
  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 ] }
  28 !             } cond
  29 !         ] }
  30 !         { [ a vec3d? ] [
  31 !             {
  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 ] }
  35 !             } cond
  36 !         ] }
  37 !     } cond ; inline
  38
  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 ;
  43
  44 : gml-scalar-op ( a b scalar-quot mixed-quot vector-quot -- c )
  45     {
  46         { [ reach float? ] [ 2drop call ] }
  47         { [ reach integer? ] [ 2drop call ] }
  48         { [ reach vec2d? ] [ drop nip [ scalar>vec2d ] 2dip call ] }
  49         { [ reach vec3d? ] [ drop nip [ scalar>vec3d ] 2dip call ] }
  50     } cond ; inline
  51
  52 : gml-math-op ( a b scalar-quot mixed-quot vector-quot -- c )
  53     {
  54         { [ 5 npick float? ] [ gml-scalar-op ] }
  55         { [ 5 npick integer? ] [ gml-scalar-op ] }
  56         { [ 5 npick vec2d? ] [
  57             {
  58                 { [ reach vec2d? ] [ 2nip call ] }
  59                 { [ reach float? ] [ drop nip [ scalar>vec2d ] dip call ] }
  60                 { [ reach integer? ] [ drop nip [ scalar>vec2d ] dip call ] }
  61             } cond
  62         ] }
  63         { [ 5 npick vec3d? ] [
  64             {
  65                 { [ reach vec3d? ] [ 2nip call ] }
  66                 { [ reach float? ] [ drop nip [ scalar>vec3d ] dip call ] }
  67                 { [ reach integer? ] [ drop nip [ scalar>vec3d ] dip call ] }
  68             } cond
  69         ] }
  70     } cond ; inline
  71
  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* ] [ vdot ] 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 ;
  77
  78 GML: neg ( x -- y )
  79     {
  80         { [ dup integer? ] [ neg ] }
  81         { [ dup float? ] [ neg ] }
  82         { [ dup vec2d? ] [ vneg ] }
  83         { [ dup vec3d? ] [ vneg mask-vec3d ] }
  84     } cond ;
  85
  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 ;
  92
  93 ! Trig
  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 ;
 100
 101 FROM: math.libm => fatan2 ;
 102 GML: atan2 ( x y -- z ) [ >float ] bi@ fatan2 rad>deg ;
 103
 104 GML: pi ( -- pi ) pi ;
 105
 106 ! Bitwise ops
 107 : logical-op ( a b quot -- c ) [ [ true? ] bi@ ] dip call >true ; inline
 108
 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 ;
 112
 113 ! Misc functions
 114 GML: abs ( x -- y )
 115     {
 116         { [ dup integer? ] [ abs ] }
 117         { [ dup float? ] [ abs ] }
 118         { [ dup vec2d? ] [ norm ] }
 119         { [ dup vec3d? ] [ norm ] }
 120     } cond ;
 121
 122 : must-be-positive ( x -- x ) dup 0 < [ "Domain error" throw ] when ; inline
 123
 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@ ^ ;
 130
 131 GML: ceiling ( x -- y ) ceiling ;
 132 GML: floor ( x -- y ) floor ;
 133 GML: trunc ( x -- y ) truncate ;
 134 GML: round ( x -- y ) round ;
 135
 136 GML: clamp ( x v -- y ) first2 clamp ;
 137
 138 ! Vector functions
 139 GML: getX ( vec -- x )
 140     {
 141         { [ dup vec2d? ] [ first ] }
 142         { [ dup vec3d? ] [ first ] }
 143     } cond ;
 144
 145 GML: getY ( vec -- x )
 146     {
 147         { [ dup vec2d? ] [ second ] }
 148         { [ dup vec3d? ] [ second ] }
 149     } cond ;
 150
 151 GML: getZ ( vec -- x )
 152     {
 153         { [ dup vec3d? ] [ third ] }
 154     } cond ;
 155
 156 GML: putX ( vec x -- x )
 157     {
 158         { [ over vec2d? ] [ [ second ] dip swap <vec2d> ] }
 159         { [ over vec3d? ] [ [ [ second ] [ third ] bi ] dip -rot <vec3d> ] }
 160     } cond ;
 161
 162 GML: putY ( vec y -- x )
 163     {
 164         { [ over vec2d? ] [ [ first ] dip <vec2d> ] }
 165         { [ over vec3d? ] [ [ [ first ] [ third ] bi ] dip swap <vec3d> ] }
 166     } cond ;
 167
 168 GML: putZ ( vec z -- x )
 169     {
 170         { [ over vec3d? ] [ [ first2 ] dip <vec3d> ] }
 171     } cond ;
 172
 173 GML: dist ( u v -- x ) distance ;
 174
 175 GML: normalize ( u -- v ) normalize mask-vec3d ;
 176
 177 GML: planemul ( u v p -- w )
 178     first2 [ v*n ] bi-curry@ bi* v+ ;
 179
 180 GML: cross ( u v -- w ) cross ;
 181
 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
 186
 187 GML: aNormal ( x -- y )
 188     {
 189         { [ dup vec2d? ] [ normalize double-2{ 1 -1 } v* { 1 0 } vshuffle ] }
 190         { [ dup vec3d? ] [ normalize normal ] }
 191     } cond ;
 192
 193 : det2 ( x y -- z )
 194     { 1 0 } vshuffle double-2{ 1 -1 } v* vdot ; inline
 195
 196 : det3 ( x y z -- w )
 197     [ cross ] dip vdot ; inline
 198
 199 GML: determinant ( x -- y )
 200     {
 201         { [ dup vec2d? ] [ [ dup pop-operand ] dip det2 ] }
 202         { [ dup vec3d? ] [ [ dup [ pop-operand ] [ pop-operand ] bi swap ] dip det3 ] }
 203     } cond ;
 204
 205 GML: vector2 ( x y -- v ) <vec2d> ;
 206
 207 GML: vector3 ( x y z -- v ) <vec3d> ;
 208
 209 GML: random ( -- x ) 0.0 1.0 uniform-random-float ;
 210
 211 GML: randomseed ( n -- )
 212     dup 0 < [ drop nano-count 1000000 /i ] when
 213     <mersenne-twister> random-generator set ;
 214
 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 ;