diff --git a/basis/math/vectors/vectors-tests.factor b/basis/math/vectors/vectors-tests.factor index b4b12d619b..968af6a3aa 100644 --- a/basis/math/vectors/vectors-tests.factor +++ b/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 diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index eb203a5f12..17f6c39f04 100644 --- a/basis/math/vectors/vectors.factor +++ b/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 ; diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor index f64542fa00..1e470b699a 100644 --- a/basis/specialized-arrays/specialized-arrays-tests.factor +++ b/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 diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index c28bf062c1..75370d6cfd 100644 --- a/core/math/math-docs.factor +++ b/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: +{ $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 } 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 } } diff --git a/core/math/math-tests.factor b/core/math/math-tests.factor index c2077eb790..b7cc51e669 100644 --- a/core/math/math-tests.factor +++ b/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? ] unit-test +! [ t ] [ 1 fp-snan? ] unit-test +! [ f ] [ 1 fp-qnan? ] unit-test +[ t ] [ HEX: 8000000000001 fp-nan? ] unit-test +[ f ] [ HEX: 8000000000001 fp-snan? ] unit-test +[ t ] [ HEX: 8000000000001 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? ] unit-test +[ t ] [ 0 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 diff --git a/core/math/math.factor b/core/math/math.factor index 8e0000326f..6a087ec909 100755 --- a/core/math/math.factor +++ b/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: float fp-nan? - double>bits -51 shift HEX: fff [ bitand ] keep = ; - -GENERIC: fp-infinity? ( x -- ? ) - +M: object fp-qnan? + drop f ; +M: object fp-snan? + drop f ; 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 ; + +: ( payload -- nan ) + HEX: 7ff0000000000000 bitor bits>double ; foldable flushable + +: next-float ( m -- n ) double>bits - dup -52 shift HEX: 7ff [ bitand ] keep = [ - HEX: fffffffffffff bitand 0 = - ] [ - drop f - ] if ; + dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero + dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero + 1 + bits>double ! positive + ] 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 diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index 0340941449..6e48e7cf04 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -112,8 +112,7 @@ IN: mason.report benchmark-error-vocabs-file benchmark-error-messages-file error-dump - - "Benchmark timings" + benchmarks-file eval-file benchmarks-table ] output>array ] with-report ; diff --git a/extra/terrain/shaders/shaders.factor b/extra/terrain/shaders/shaders.factor index 2dc793f078..c341545956 100644 --- a/extra/terrain/shaders/shaders.factor +++ b/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() diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index 6617275784..d58aa4ec30 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -1,6 +1,6 @@ USING: accessors arrays combinators game-input -game-input.scancodes game-loop kernel literals locals math -math.constants math.functions math.matrices math.order +game-input.scancodes game-loop grouping kernel literals locals +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: FAR-PLANE 2.0 -CONSTANT: EYE-START { 0.5 0.5 1.2 } +CONSTANT: NEAR-PLANE $[ 1.0 2048.0 / ] +CONSTANT: FAR-PLANE 1.0 +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 * ] @@ -79,47 +88,89 @@ TUPLE: terrain-world < world p cos :> cosp p sin :> sinp - cosy 0.0 siny neg 3array - siny sinp * cosp cosy sinp * 3array - siny cosp * sinp neg cosy cosp * 3array 3array + cosy 0.0 siny neg 3array + siny sinp * cosp cosy sinp * 3array + siny cosp * sinp neg cosy cosp * 3array 3array v swap v.m ; -: forward-vector ( world -- v ) - [ yaw>> ] [ pitch>> ] bi +: forward-vector ( player -- v ) + yaw>> 0.0 { 0.0 0.0 $ MOVEMENT-SPEED } vneg eye-rotate ; -: rightward-vector ( world -- v ) - [ yaw>> ] [ pitch>> ] bi +: rightward-vector ( player -- v ) + yaw>> 0.0 { $ MOVEMENT-SPEED 0.0 0.0 } eye-rotate ; -: move-forward ( world -- ) - dup forward-vector [ v+ ] curry change-eye drop ; -: move-backward ( world -- ) - dup forward-vector [ v- ] curry change-eye drop ; -: move-leftward ( world -- ) - dup rightward-vector [ v- ] curry change-eye drop ; -: move-rightward ( world -- ) - dup rightward-vector [ v+ ] curry change-eye drop ; +: walk-forward ( player -- ) + dup forward-vector [ v+ ] curry change-velocity drop ; +: walk-backward ( player -- ) + dup forward-vector [ v- ] curry change-velocity drop ; +: walk-leftward ( player -- ) + dup rightward-vector [ v- ] curry change-velocity drop ; +: walk-rightward ( player -- ) + 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-s keys nth [ world move-backward ] when - key-a keys nth [ world move-leftward ] when - key-d keys nth [ world move-rightward ] when + key-w keys nth [ player walk-forward ] when + key-s keys nth [ player walk-backward ] when + key-a keys nth [ player walk-leftward ] 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* - [ handle-input ] keep - ! [ eye>> ] [ yaw>> ] [ pitch>> ] tri 3array P ! debug +: apply-friction ( velocity -- velocity' ) + FRICTION v*n ; + +: 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 :> 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 - 0.0 >>yaw - 0.0 >>pitch + PLAYER-START-LOCATION 0.0 0.0 { 0.0 0.0 0.0 } player boa >>player [ >>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