Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
9318568b13
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 } }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
: <fp-nan> ( 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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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()
|
||||
|
|
|
|||
|
|
@ -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 <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
|
||||
0.0 >>yaw
|
||||
0.0 >>pitch
|
||||
PLAYER-START-LOCATION 0.0 0.0 { 0.0 0.0 0.0 } player boa >>player
|
||||
<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
|
||||
|
|
|
|||
Loading…
Reference in New Issue