Merge branch 'master' of git://factorcode.org/git/factor

basis/math/vectors/vectors-tests.factor

@@ -14,3 +14,5 @@ USING: math.vectors tools.test ;
 [ { 1.75 1.75 } ] [ { 1.0 2.5 } { 2.5 1.0 } 0.5 vnlerp ] unit-test 
 
 [ { 1.75 2.125 } ] [ { 1.0 2.5 } { 2.5 1.0 } { 0.5 0.25 } vlerp ] unit-test 
+
+[ 1.125 ] [ 0.0 1.0 2.0 4.0 { 0.5 0.25 } bilerp ] unit-test

basis/math/vectors/vectors.factor

@@ -41,6 +41,10 @@ IN: math.vectors
 : set-axis ( u v axis -- w )
     [ [ zero? 2over ? ] dip swap nth ] map-index 2nip ;
 
+: bilerp ( aa ba ab bb {t,u} -- a_tu )
+    [ first lerp ] [ second lerp ] bi-curry
+    [ 2bi@ ] [ call ] bi* ;
+
 : vlerp ( a b t -- a_t )
     [ lerp ] 3map ;
 

basis/specialized-arrays/specialized-arrays-tests.factor

@@ -2,7 +2,8 @@ IN: specialized-arrays.tests
 USING: tools.test specialized-arrays sequences
 specialized-arrays.int specialized-arrays.bool
 specialized-arrays.ushort alien.c-types accessors kernel
-specialized-arrays.direct.int specialized-arrays.char arrays ;
+specialized-arrays.direct.int specialized-arrays.char
+specialized-arrays.uint arrays combinators ;
 
 [ t ] [ { 1 2 3 } >int-array int-array? ] unit-test
 
@@ -10,7 +11,13 @@ specialized-arrays.direct.int specialized-arrays.char arrays ;
 
 [ 2 ] [ int-array{ 1 2 3 } second ] unit-test
 
-[ t ] [ { t f t } >bool-array underlying>> { 1 0 1 } >char-array underlying>> = ] unit-test
+[ t ] [
+    { t f t } >bool-array underlying>>
+    { 1 0 1 } "bool" heap-size {
+        { 1 [ >char-array ] }
+        { 4 [ >uint-array ] }
+    } case underlying>> =
+] unit-test
 
 [ ushort-array{ 1234 } ] [
     little-endian? B{ 210 4 } B{ 4 210 } ? byte-array>ushort-array

core/math/math-docs.factor

@@ -245,10 +245,22 @@ HELP: times
     { $example "USING: io math ;" "3 [ \"Hi\" print ] times" "Hi\nHi\nHi" }
 } ;
 
+HELP: fp-special?
+{ $values { "x" real } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "x" } " is an IEEE special value (Not-a-Number or Infinity). While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
+
 HELP: fp-nan?
 { $values { "x" real } { "?" "a boolean" } }
 { $description "Tests if " { $snippet "x" } " is an IEEE Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
 
+HELP: fp-qnan?
+{ $values { "x" real } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "x" } " is an IEEE Quiet Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
+
+HELP: fp-snan?
+{ $values { "x" real } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "x" } " is an IEEE Signaling Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
+
 HELP: fp-infinity?
 { $values { "x" real } { "?" "a boolean" } }
 { $description "Tests if " { $snippet "x" } " is an IEEE Infinity value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." }
@@ -257,7 +269,26 @@ HELP: fp-infinity?
     { $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi and [ \"negative infinity\" print ] when" "negative infinity" }
 } ;
 
-{ fp-nan? fp-infinity? } related-words
+HELP: fp-nan-payload
+{ $values { "x" real } { "bits" integer } }
+{ $description "If " { $snippet "x" } " is an IEEE Not-a-Number value, returns the payload encoded in the value. Returns " { $link f } " if " { $snippet "x" } " is not a " { $link float } "." } ;
+
+HELP: <fp-nan>
+{ $values { "payload" integer } { "float" float } }
+{ $description "Constructs an IEEE Not-a-Number value with a payload of " { $snippet "payload" } "." }
+{ $notes "A " { $snippet "payload" } " of " { $snippet "0" } " will construct an Infinity value." } ;
+
+{ fp-special? fp-nan? fp-qnan? fp-snan? fp-infinity? fp-nan-payload <fp-nan> } related-words
+
+HELP: next-float
+{ $values { "m" float } { "n" float } }
+{ $description "Returns the least representable " { $link float } " value greater than " { $snippet "m" } "." } ;
+
+HELP: prev-float
+{ $values { "m" float } { "n" float } }
+{ $description "Returns the greatest representable " { $link float } " value less than " { $snippet "m" } "." } ;
+
+{ next-float prev-float } related-words
 
 HELP: real-part
 { $values { "z" number } { "x" real } }

core/math/math-tests.factor

@@ -12,7 +12,24 @@ IN: math.tests
 [ f ] [ 1/0. fp-nan? ] unit-test
 [ f ] [ -1/0. fp-nan? ] unit-test
 [ t ] [ -0/0. fp-nan? ] unit-test
+[ t ] [ 1 <fp-nan> fp-nan? ] unit-test
+! [ t ] [ 1 <fp-nan> fp-snan? ] unit-test
+! [ f ] [ 1 <fp-nan> fp-qnan? ] unit-test
+[ t ] [ HEX: 8000000000001 <fp-nan> fp-nan? ] unit-test
+[ f ] [ HEX: 8000000000001 <fp-nan> fp-snan? ] unit-test
+[ t ] [ HEX: 8000000000001 <fp-nan> fp-qnan? ] unit-test
 
 [ t ] [ 1/0. fp-infinity? ] unit-test
 [ t ] [ -1/0. fp-infinity? ] unit-test
 [ f ] [ -0/0. fp-infinity? ] unit-test
+
+[ f ] [ 0 <fp-nan> fp-nan? ] unit-test
+[ t ] [ 0 <fp-nan> fp-infinity? ] unit-test
+
+[ 0.0 ] [ -0.0 next-float ] unit-test
+[ t ] [ 1.0 dup next-float < ] unit-test
+[ t ] [ -1.0 dup next-float < ] unit-test
+
+[ -0.0 ] [ 0.0 prev-float ] unit-test
+[ t ] [ 1.0 dup prev-float > ] unit-test
+[ t ] [ -1.0 dup prev-float > ] unit-test

core/math/math.factor

@@ -81,26 +81,62 @@ TUPLE: complex { real real read-only } { imaginary real read-only } ;
 
 UNION: number real complex ;
 
+GENERIC: fp-special? ( x -- ? )
 GENERIC: fp-nan? ( x -- ? )
+GENERIC: fp-qnan? ( x -- ? )
+GENERIC: fp-snan? ( x -- ? )
+GENERIC: fp-infinity? ( x -- ? )
+GENERIC: fp-nan-payload ( x -- bits )
 
+M: object fp-special?
+    drop f ;
 M: object fp-nan?
     drop f ;
-
+M: object fp-qnan?
-M: float fp-nan?
+    drop f ;
-    double>bits -51 shift HEX: fff [ bitand ] keep = ;
+M: object fp-snan?
-
+    drop f ;
-GENERIC: fp-infinity? ( x -- ? )
-
 M: object fp-infinity?
     drop f ;
+M: object fp-nan-payload
+    drop f ;
 
-M: float fp-infinity? ( float -- ? )
+M: float fp-special?
+    double>bits -52 shift HEX: 7ff [ bitand ] keep = ;
+
+M: float fp-nan-payload
+    double>bits HEX: fffffffffffff bitand ; foldable flushable
+
+M: float fp-nan?
+    dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ;
+
+M: float fp-qnan?
+    dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? not ] [ drop f ] if ;
+
+M: float fp-snan?
+    dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? ] [ drop f ] if ;
+
+M: float fp-infinity?
+    dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ;
+
+: <fp-nan> ( payload -- nan )
+    HEX: 7ff0000000000000 bitor bits>double ; foldable flushable
+
+: next-float ( m -- n )
     double>bits
-    dup -52 shift HEX: 7ff [ bitand ] keep = [
+    dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero
-        HEX: fffffffffffff bitand 0 =
+        dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero
-    ] [
+            1 + bits>double ! positive
-        drop f
+        ] if
-    ] if ;
+    ] if ; foldable flushable
+
+: prev-float ( m -- n )
+    double>bits
+    dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative
+        dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero
+            1 - bits>double ! positive non-zero
+        ] if
+    ] if ; foldable flushable
 
 : next-power-of-2 ( m -- n )
     dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline

extra/mason/report/report.factor

@@ -113,7 +113,6 @@ IN: mason.report
             benchmark-error-messages-file
             error-dump
 
-            "Benchmark timings"
             benchmarks-file eval-file benchmarks-table
         ] output>array
     ] with-report ;

extra/terrain/shaders/shaders.factor

@@ -4,15 +4,14 @@ IN: terrain.shaders
 STRING: terrain-vertex-shader
 
 uniform sampler2D heightmap;
+uniform vec4 component_scale;
 
 varying vec2 heightcoords;
 
-const vec4 COMPONENT_SCALE = vec4(0.5, 0.01, 0.002, 0.0);
-
 float height(sampler2D map, vec2 coords)
 {
     vec4 v = texture2D(map, coords);
-    return dot(v, COMPONENT_SCALE);
+    return dot(v, component_scale);
 }
 
 void main()
@@ -27,15 +26,14 @@ void main()
 STRING: terrain-pixel-shader
 
 uniform sampler2D heightmap;
+uniform vec4 component_scale;
 
 varying vec2 heightcoords;
 
-const vec4 COMPONENT_SCALE = vec4(0.5, 0.01, 0.002, 0.0);
-
 float height(sampler2D map, vec2 coords)
 {
     vec4 v = texture2D(map, coords);
-    return dot(v, COMPONENT_SCALE);
+    return dot(v, component_scale);
 }
 
 void main()

extra/terrain/terrain.factor

@@ -1,6 +1,6 @@
 USING: accessors arrays combinators game-input
-game-input.scancodes game-loop kernel literals locals math
+game-input.scancodes game-loop grouping kernel literals locals
-math.constants math.functions math.matrices math.order
+math math.constants math.functions math.matrices math.order
 math.vectors opengl opengl.capabilities opengl.gl
 opengl.shaders opengl.textures opengl.textures.private
 sequences sequences.product specialized-arrays.float
@@ -9,19 +9,27 @@ ui.gadgets.worlds ui.pixel-formats ;
 IN: terrain
 
 CONSTANT: FOV $[ 2.0 sqrt 1+ ]
-CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ]
+CONSTANT: NEAR-PLANE $[ 1.0 2048.0 / ]
-CONSTANT: FAR-PLANE 2.0
+CONSTANT: FAR-PLANE 1.0
-CONSTANT: EYE-START { 0.5 0.5 1.2 }
+CONSTANT: PLAYER-START-LOCATION { 0.5 0.51 0.5 }
+CONSTANT: PLAYER-HEIGHT $[ 3.0 1024.0 / ]
+CONSTANT: GRAVITY $[ 1.0 4096.0 / ]
+CONSTANT: JUMP $[ 1.0 1024.0 / ]
 CONSTANT: TICK-LENGTH $[ 1000 30 /i ]
 CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ]
-CONSTANT: MOVEMENT-SPEED $[ 1.0 512.0 / ]
+CONSTANT: MOVEMENT-SPEED $[ 1.0 16384.0 / ]
+CONSTANT: FRICTION 0.95
+CONSTANT: COMPONENT-SCALE { 0.5 0.01 0.002 0.0 }
 
 CONSTANT: terrain-vertex-size { 512 512 }
 CONSTANT: terrain-vertex-distance { $[ 1.0 512.0 / ] $[ 1.0 512.0 / ] }
 CONSTANT: terrain-vertex-row-length $[ 512 1 + 2 * ]
 
+TUPLE: player
+    location yaw pitch velocity ;
+
 TUPLE: terrain-world < world
-    eye yaw pitch
+    player
     terrain terrain-segment terrain-texture terrain-program
     terrain-vertex-buffer
     game-loop ;
@@ -35,9 +43,10 @@ TUPLE: terrain-world < world
     GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
     GL_MODELVIEW glMatrixMode
     glLoadIdentity
+    player>>
     [ pitch>> 1.0 0.0 0.0 glRotatef ]
     [ yaw>> 0.0 1.0 0.0 glRotatef ]
-    [ eye>> vneg first3 glTranslatef ] tri ;
+    [ location>> vneg first3 glTranslatef ] tri ;
 
 : vertex-array-vertex ( x z -- vertex )
     [ terrain-vertex-distance first * ]
@@ -84,42 +93,84 @@ TUPLE: terrain-world < world
     siny cosp *  sinp neg  cosy cosp *      3array 3array
     v swap v.m ;
 
-: forward-vector ( world -- v )
+: forward-vector ( player -- v )
-    [ yaw>> ] [ pitch>> ] bi
+    yaw>> 0.0
     { 0.0 0.0 $ MOVEMENT-SPEED } vneg eye-rotate ;
-: rightward-vector ( world -- v )
+: rightward-vector ( player -- v )
-    [ yaw>> ] [ pitch>> ] bi
+    yaw>> 0.0
     { $ MOVEMENT-SPEED 0.0 0.0 } eye-rotate ;
 
-: move-forward ( world -- )
+: walk-forward ( player -- )
-    dup forward-vector [ v+ ] curry change-eye drop ;
+    dup forward-vector [ v+ ] curry change-velocity drop ;
-: move-backward ( world -- )
+: walk-backward ( player -- )
-    dup forward-vector [ v- ] curry change-eye drop ;
+    dup forward-vector [ v- ] curry change-velocity drop ;
-: move-leftward ( world -- )
+: walk-leftward ( player -- )
-    dup rightward-vector [ v- ] curry change-eye drop ;
+    dup rightward-vector [ v- ] curry change-velocity drop ;
-: move-rightward ( world -- )
+: walk-rightward ( player -- )
-    dup rightward-vector [ v+ ] curry change-eye drop ;
+    dup rightward-vector [ v+ ] curry change-velocity drop ;
+: jump ( player -- )
+    [ { 0.0 $ JUMP 0.0 } v+ ] change-velocity drop ;
 
-: rotate-with-mouse ( world mouse -- )
+: clamp-pitch ( pitch -- pitch' )
+    90.0 min -90.0 max ;
+
+: rotate-with-mouse ( player mouse -- )
     [ dx>> MOUSE-SCALE * [ + ] curry change-yaw ]
-    [ dy>> MOUSE-SCALE * [ + ] curry change-pitch ] bi
+    [ dy>> MOUSE-SCALE * [ + clamp-pitch ] curry change-pitch ] bi
     drop ;
 
 :: handle-input ( world -- )
+    world player>> :> player
     read-keyboard keys>> :> keys
-    key-w keys nth [ world move-forward ] when 
+    key-w keys nth [ player walk-forward ] when 
-    key-s keys nth [ world move-backward ] when 
+    key-s keys nth [ player walk-backward ] when 
-    key-a keys nth [ world move-leftward ] when 
+    key-a keys nth [ player walk-leftward ] when 
-    key-d keys nth [ world move-rightward ] when 
+    key-d keys nth [ player walk-rightward ] when 
+    key-space keys nth [ player jump ] when 
     key-escape keys nth [ world close-window ] when
-    world read-mouse rotate-with-mouse
+    player read-mouse rotate-with-mouse
     reset-mouse ;
 
-M: terrain-world tick*
+: apply-friction ( velocity -- velocity' )
-    [ handle-input ] keep
+    FRICTION v*n ;
-    ! [ eye>> ] [ yaw>> ] [ pitch>> ] tri 3array P ! debug
+
+: apply-gravity ( velocity -- velocity' )
+    1 over [ GRAVITY - ] change-nth ;
+
+:: pixel-indices ( coords dim -- indices )
+    coords vfloor [ >integer ] map :> floor-coords
+    floor-coords first2 dim first * + :> base-index
+    base-index dim first + :> next-row-index
+
+    base-index
+    base-index 1 +
+    next-row-index
+    next-row-index 1 + 4array ;
+
+:: terrain-height-at ( segment point -- height )
+    segment dim>> :> dim
+    dim point v* :> pixel
+    pixel dup vfloor v- :> pixel-mantissa
+    segment bitmap>> 4 <groups> :> pixels
+    pixel dim pixel-indices :> indices
+    
+    indices [ pixels nth COMPONENT-SCALE v. 255.0 / ] map
+    first4 pixel-mantissa bilerp ;
+
+: collide ( segment location -- location' )
+    [ [ first ] [ third ] bi 2array terrain-height-at PLAYER-HEIGHT + ]
+    [ [ 1 ] 2dip [ max ] with change-nth ]
+    [ ] tri ;
+
+: tick-player ( world player -- )
+    [ apply-friction apply-gravity ] change-velocity
+    dup velocity>> [ v+ [ terrain-segment>> ] dip collide ] curry with change-location
     drop ;
 
+M: terrain-world tick*
+    [ dup focused?>> [ handle-input ] [ drop ] if ]
+    [ dup player>> tick-player ] bi ;
+
 M: terrain-world draw*
     nip draw-world ;
 
@@ -137,9 +188,7 @@ M: terrain-world begin-world
     GL_TEXTURE_2D glEnable
     GL_VERTEX_ARRAY glEnableClientState
     0.5 0.5 0.5 1.0 glClearColor
-    EYE-START >>eye
+    PLAYER-START-LOCATION 0.0 0.0 { 0.0 0.0 0.0 } player boa >>player
-    0.0 >>yaw
-    0.0 >>pitch
     <terrain> [ >>terrain ] keep
     { 0 0 } terrain-segment [ >>terrain-segment ] keep
     make-texture [ set-heightmap-texture-parameters ] keep >>terrain-texture
@@ -169,7 +218,8 @@ M: terrain-world draw-world*
     [ set-modelview-matrix ]
     [ terrain-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ]
     [ dup terrain-program>> [
-        "heightmap" glGetUniformLocation 0 glUniform1i
+        [ "heightmap" glGetUniformLocation 0 glUniform1i ]
+        [ "component_scale" glGetUniformLocation COMPONENT-SCALE first4 glUniform4f ] bi
         terrain-vertex-buffer>> draw-vertex-buffer
     ] with-gl-program ]
     tri gl-error ;
@@ -190,3 +240,5 @@ M: terrain-world pref-dim* drop { 640 480 } ;
             { grab-input? t }
         } open-window
     ] with-ui ;
+
+MAIN: terrain-window