diff --git a/extra/noise/noise.factor b/extra/noise/noise.factor index 7ae0f36bda..032090cae3 100644 --- a/extra/noise/noise.factor +++ b/extra/noise/noise.factor @@ -1,41 +1,96 @@ -USING: accessors arrays byte-arrays combinators -combinators.short-circuit fry hints images kernel locals math -math.affine-transforms math.functions math.order math.polynomials -math.vectors random random.mersenne-twister sequences -sequences.private sequences.product ; +USING: accessors alien.data.map byte-arrays combinators combinators.short-circuit +fry generalizations images kernel locals math math.constants math.functions +math.libm math.matrices.simd math.vectors math.vectors.conversion math.vectors.simd +memoize random random.mersenne-twister sequences sequences.private specialized-arrays +typed ; +QUALIFIED-WITH: alien.c-types c +SIMDS: c:float c:int c:short c:uchar ; +SPECIALIZED-ARRAYS: c:float c:uchar float-4 uchar-16 ; IN: noise -: ( -- table ) - 256 iota >byte-array randomize dup append ; inline - : with-seed ( seed quot -- ) [ ] dip with-random ; inline -> int-4 boa ; inline -: (fade) ( x y z -- x' y' z' ) - [ { 0.0 0.0 0.0 10.0 -15.0 6.0 } polyval* ] tri@ ; +: (random-float-4) ( -- v ) + random-int-4 int-4 float-4 vconvert ; inline -HINTS: (fade) { float float float } ; +! XXX redundant add +: uniform-random-float-4 ( min max -- n ) + (random-float-4) (random-float-4) + 2.0 31 ^ v+n 2.0 32 ^ v*n v+ + [ over - 2.0 -64 ^ * ] dip n*v n+v ; inline -: fade ( point -- point' ) - first3 (fade) 3array ; inline +: normal-random-float-4 ( mean sigma -- n ) + 0.0 1.0 uniform-random-float-4 + 0.0 1.0 uniform-random-float-4 + [ 2 pi * v*n [ fcos ] map ] + [ 1.0 swap n-v [ flog ] map -2.0 v*n vsqrt ] + bi* v* n*v n+v ; inline -:: grad ( hash x y z -- gradient ) - hash 8 bitand zero? [ x ] [ y ] if - :> u - hash 12 bitand zero? - [ y ] [ hash 13 bitand 12 = [ x ] [ z ] if ] if - :> v +: float-map>byte-map ( floats: float-array scale: float bias: float -- bytes: byte-array ) + '[ + [ _ 255.0 * v*n _ 255.0 * v+n float-4 int-4 vconvert ] 4 napply + [ int-4 short-8 vconvert ] 2bi@ + short-8 uchar-16 vconvert + ] data-map( float-4[4] -- uchar-16 ) ; inline - hash 1 bitand zero? [ u ] [ u neg ] if - hash 2 bitand zero? [ v ] [ v neg ] if + ; +TYPED:: float-map>image ( floats: float-array dim scale: float bias: float -- image: image ) + image new + dim >>dim + floats scale bias float-map>byte-map >>bitmap + L >>component-order + ubyte-components >>component-type ; -HINTS: grad { fixnum float float float } ; +TYPED: uniform-noise-map ( seed: integer dim -- map: float-array ) + '[ + _ product 4 / [ 0.0 1.0 uniform-random-float-4 ] + float-4-array{ } replicate-as + byte-array>float-array + ] with-seed ; -: unit-cube ( point -- cube ) - [ floor 256 rem ] map ; +: uniform-noise-image ( seed dim -- image ) + [ uniform-noise-map ] [ 1.0 0.0 float-map>image ] bi ; inline +TYPED: normal-noise-map ( seed: integer sigma: float dim -- map: float-array ) + swap '[ + _ product 4 / [ 0.5 _ normal-random-float-4 ] + float-4-array{ } replicate-as + byte-array>float-array + ] with-seed ; + +: normal-noise-image ( seed sigma dim -- image ) + [ normal-noise-map ] [ 1.0 0.0 float-map>image ] bi ; inline + +ERROR: invalid-perlin-noise-table table ; + +: ( -- table ) + 256 iota >byte-array randomize dup append ; inline + +: validate-table ( table -- table ) + dup { [ byte-array? ] [ length 512 >= ] } 1&& + [ invalid-perlin-noise-table ] unless ; + +! XXX doesn't work for NaNs or very large floats +: floor-vector ( v -- v' ) + [ float-4 int-4 vconvert int-4 float-4 vconvert ] + [ [ v> -1.0 float-4-with vand ] curry keep v+ ] bi ; inline + +: unit-cubed ( floats -- ints ) + float-4 int-4 vconvert 255 int-4-with vbitand ; inline + +: fade ( gradient -- gradient' ) + { + [ drop 6.0 ] + [ n*v -15.0 v+n ] + [ v* 10.0 v+n ] + [ v* ] + [ v* ] + [ v* ] + } cleave ; inline + :: hashes ( table x y z -- aaa baa aba bba aab bab abb bbb ) x table nth-unsafe y + :> a x 1 + table nth-unsafe y + :> b @@ -54,79 +109,41 @@ HINTS: grad { fixnum float float float } ; ab 1 + table nth-unsafe bb 1 + table nth-unsafe ; inline -HINTS: hashes { byte-array fixnum fixnum fixnum } ; +:: grad ( hash v -- gradient ) + hash 8 bitand zero? [ v first ] [ v second ] if + :> u + hash 12 bitand zero? + [ v second ] [ hash 13 bitand 12 = [ v first ] [ v third ] if ] if + :> v -: >byte-map ( floats -- bytes ) - [ 255.0 * >fixnum ] B{ } map-as ; + hash 1 bitand zero? [ u ] [ u neg ] if + hash 2 bitand zero? [ v ] [ v neg ] if + ; inline -: >image ( bytes dim -- image ) - image new - swap >>dim - swap >>bitmap - L >>component-order - ubyte-components >>component-type ; - -:: perlin-noise-unsafe ( table point -- value ) - point unit-cube :> cube - point dup vfloor v- :> gradients +TYPED:: perlin-noise ( table: byte-array point: float-4 -- value: float ) + point floor-vector :> _point_ + _point_ unit-cubed :> cube + point _point_ v- :> gradients gradients fade :> faded table cube first3 hashes { - [ gradients first3 grad ] - [ gradients first3 [ 1.0 - ] [ ] [ ] tri* grad ] - [ gradients first3 [ ] [ 1.0 - ] [ ] tri* grad ] - [ gradients first3 [ 1.0 - ] [ 1.0 - ] [ ] tri* grad ] - [ gradients first3 [ ] [ ] [ 1.0 - ] tri* grad ] - [ gradients first3 [ 1.0 - ] [ ] [ 1.0 - ] tri* grad ] - [ gradients first3 [ ] [ 1.0 - ] [ 1.0 - ] tri* grad ] - [ gradients first3 [ 1.0 - ] [ 1.0 - ] [ 1.0 - ] tri* grad ] + [ gradients grad ] + [ gradients float-4{ 1.0 0.0 0.0 0.0 } v- grad ] + [ gradients float-4{ 0.0 1.0 0.0 0.0 } v- grad ] + [ gradients float-4{ 1.0 1.0 0.0 0.0 } v- grad ] + [ gradients float-4{ 0.0 0.0 1.0 0.0 } v- grad ] + [ gradients float-4{ 1.0 0.0 1.0 0.0 } v- grad ] + [ gradients float-4{ 0.0 1.0 1.0 0.0 } v- grad ] + [ gradients float-4{ 1.0 1.0 1.0 0.0 } v- grad ] } spread faded trilerp ; -ERROR: invalid-perlin-noise-table table ; +MEMO: perlin-noise-map-coords ( dim -- coords ) + first2 [| x y | x [ y 0.0 0.0 float-4-boa ] float-4-array{ } map-as ] with map concat ; -: validate-table ( table -- table ) - dup { [ byte-array? ] [ length 512 >= ] } 1&& - [ invalid-perlin-noise-table ] unless ; - -PRIVATE> - -: perlin-noise ( table point -- value ) - [ validate-table ] dip perlin-noise-unsafe ; inline - -: normalize-0-1 ( sequence -- sequence' ) - [ supremum ] [ infimum [ - ] keep ] [ ] tri - [ swap - ] with map [ swap / ] with map ; - -: clamp-0-1 ( sequence -- sequence' ) - [ 0.0 max 1.0 min ] map ; - -: perlin-noise-map ( table transform dim -- map ) - [ validate-table ] 2dip - [ iota ] map [ a.v 0.0 suffix perlin-noise-unsafe ] with with product-map ; - -: perlin-noise-byte-map ( table transform dim -- map ) - perlin-noise-map normalize-0-1 >byte-map ; +TYPED:: perlin-noise-map ( table: byte-array transform: matrix4 coords: float-4-array -- map: float-array ) + coords [| coord | table transform coord m4.v perlin-noise ] data-map( float-4 -- c:float ) + byte-array>float-array ; : perlin-noise-image ( table transform dim -- image ) - [ perlin-noise-byte-map ] [ >image ] bi ; + [ perlin-noise-map-coords perlin-noise-map ] [ 5/7. 0.5 float-map>image ] bi ; -: uniform-noise-map ( seed dim -- map ) - [ product [ 0.0 1.0 uniform-random-float ] replicate ] - curry with-seed ; - -: uniform-noise-byte-map ( seed dim -- map ) - uniform-noise-map >byte-map ; - -: uniform-noise-image ( seed dim -- image ) - [ uniform-noise-byte-map ] [ >image ] bi ; - -: normal-noise-map ( seed sigma dim -- map ) - swap '[ _ product [ 0.5 _ normal-random-float ] replicate ] - with-seed ; - -: normal-noise-byte-map ( seed sigma dim -- map ) - normal-noise-map clamp-0-1 >byte-map ; - -: normal-noise-image ( seed sigma dim -- image ) - [ normal-noise-byte-map ] [ >image ] bi ; diff --git a/extra/terrain/generation/generation.factor b/extra/terrain/generation/generation.factor index 661ea88de6..d1b6dededa 100644 --- a/extra/terrain/generation/generation.factor +++ b/extra/terrain/generation/generation.factor @@ -1,38 +1,50 @@ -USING: accessors arrays byte-arrays combinators +USING: accessors alien.data.map arrays byte-arrays combinators combinators.smart fry grouping images kernel math -math.affine-transforms math.order math.vectors noise random -sequences ; +math.matrices.simd math.order math.vectors noise random +sequences math.vectors.simd ; +FROM: alien.c-types => float uchar ; +SIMDS: float uchar ; IN: terrain.generation CONSTANT: terrain-segment-size { 512 512 } -CONSTANT: terrain-big-noise-scale { 0.002 0.002 } -CONSTANT: terrain-small-noise-scale { 0.05 0.05 } +CONSTANT: terrain-segment-size-vector { 512.0 512.0 1.0 1.0 } +CONSTANT: terrain-big-noise-scale float-4{ 0.002 0.002 0.002 0.002 } +CONSTANT: terrain-small-noise-scale float-4{ 0.05 0.05 0.05 0.05 } -TUPLE: terrain big-noise-table small-noise-table tiny-noise-seed ; +TUPLE: terrain + { big-noise-table byte-array } + { small-noise-table byte-array } + { tiny-noise-seed integer } ; : ( -- terrain ) 32 random-bits terrain boa ; : seed-at ( seed at -- seed' ) - first2 [ + ] dip [ 32 random-bits + ] curry with-seed ; + first2 [ >integer ] bi@ [ + ] dip [ 32 random-bits + ] curry with-seed ; -: big-noise-segment ( terrain at -- map ) - [ big-noise-table>> terrain-big-noise-scale first2 ] dip - terrain-segment-size [ v* a. ] keep perlin-noise-byte-map ; -: small-noise-segment ( terrain at -- map ) - [ small-noise-table>> terrain-small-noise-scale first2 ] dip - terrain-segment-size [ v* a. ] keep perlin-noise-byte-map ; -: tiny-noise-segment ( terrain at -- map ) +: big-noise-segment ( terrain at -- bytes ) + [ big-noise-table>> terrain-big-noise-scale scale-matrix4 ] dip + terrain-segment-size-vector v* translation-matrix4 m4. + terrain-segment-size perlin-noise-image bitmap>> ; inline +: small-noise-segment ( terrain at -- bytes ) + [ small-noise-table>> terrain-small-noise-scale scale-matrix4 ] dip + terrain-segment-size-vector v* translation-matrix4 m4. + terrain-segment-size perlin-noise-image bitmap>> ; inline +: tiny-noise-segment ( terrain at -- bytes ) [ tiny-noise-seed>> ] dip seed-at 0.1 - terrain-segment-size normal-noise-byte-map ; - + terrain-segment-size normal-noise-image bitmap>> ; inline : padding ( terrain at -- padding ) - 2drop terrain-segment-size product 255 ; + 2drop terrain-segment-size product 255 >byte-array ; inline TUPLE: segment image ; -: ( bytes -- image ) +: fold-rgba-planes ( r g b a -- rgba ) + [ vmerge-transpose vmerge-transpose ] + data-map( uchar-16 uchar-16 uchar-16 uchar-16 -- uchar-16[4] ) ; + +: ( big small tiny padding -- image ) + fold-rgba-planes swap >>bitmap RGBA >>component-order @@ -40,14 +52,12 @@ TUPLE: segment image ; terrain-segment-size >>dim ; : terrain-segment ( terrain at -- image ) - [ - { - [ big-noise-segment ] - [ small-noise-segment ] - [ tiny-noise-segment ] - [ padding ] - } 2cleave - ] output>array flip B{ } concat-as ; + { + [ big-noise-segment ] + [ small-noise-segment ] + [ tiny-noise-segment ] + [ padding ] + } 2cleave ; : 4max ( a b c d -- max ) max max max ; inline diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index 18e49f3e2f..4062dca108 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -1,42 +1,47 @@ ! (c)2009 Joe Groff, Doug Coleman. bsd license USING: accessors arrays combinators game.input game.loop game.input.scancodes grouping kernel literals locals -math math.constants math.functions math.matrices math.order +math math.constants math.functions math.order math.vectors opengl opengl.capabilities opengl.gl opengl.shaders opengl.textures opengl.textures.private sequences sequences.product specialized-arrays -terrain.generation terrain.shaders ui ui.gadgets +terrain.generation terrain.shaders typed ui ui.gadgets ui.gadgets.worlds ui.pixel-formats game.worlds method-chains -math.affine-transforms noise ui.gestures combinators.short-circuit -destructors grid-meshes ; -FROM: alien.c-types => float ; -SPECIALIZED-ARRAY: float +math.matrices.simd noise ui.gestures combinators.short-circuit +destructors grid-meshes math.vectors.simd ; +QUALIFIED-WITH: alien.c-types c +SPECIALIZED-ARRAY: c:float +SIMD: c:float IN: terrain CONSTANT: FOV $[ 2.0 sqrt 1 + ] -CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ] +CONSTANT: NEAR-PLANE 1/1024. CONSTANT: FAR-PLANE 2.0 -CONSTANT: PLAYER-START-LOCATION { 0.5 0.51 0.5 } -CONSTANT: VELOCITY-MODIFIER-NORMAL { 1.0 1.0 1.0 } -CONSTANT: VELOCITY-MODIFIER-FAST { 2.0 1.0 2.0 } -CONSTANT: PLAYER-HEIGHT $[ 1.0 256.0 / ] -CONSTANT: GRAVITY $[ 1.0 4096.0 / ] -CONSTANT: JUMP $[ 1.0 1024.0 / ] -CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ] -CONSTANT: MOVEMENT-SPEED $[ 1.0 16384.0 / ] -CONSTANT: FRICTION { 0.95 0.99 0.95 } -CONSTANT: COMPONENT-SCALE { 0.5 0.01 0.0005 0.0 } +CONSTANT: PLAYER-START-LOCATION float-4{ 0.5 0.51 0.5 1.0 } +CONSTANT: VELOCITY-MODIFIER-NORMAL float-4{ 1.0 1.0 1.0 0.0 } +CONSTANT: VELOCITY-MODIFIER-FAST float-4{ 2.0 1.0 2.0 0.0 } +CONSTANT: PLAYER-HEIGHT 1/256. +CONSTANT: GRAVITY float-4{ 0.0 -1/4096. 0.0 0.0 } +CONSTANT: JUMP 1/1024. +CONSTANT: MOUSE-SCALE 1/10. +CONSTANT: MOVEMENT-SPEED 1/16384. +CONSTANT: FRICTION float-4{ 0.95 0.99 0.95 1.0 } +CONSTANT: COMPONENT-SCALE float-4{ 0.5 0.01 0.0005 0.0 } CONSTANT: SKY-PERIOD 1200 CONSTANT: SKY-SPEED 0.0005 CONSTANT: terrain-vertex-size { 512 512 } TUPLE: player - location yaw pitch velocity velocity-modifier + { location float-4 } + { yaw float } + { pitch float } + { velocity float-4 } + { velocity-modifier float-4 } reverse-time ; TUPLE: terrain-world < game-world - player + { player player } sky-image sky-texture sky-program terrain terrain-segment terrain-texture terrain-program terrain-mesh @@ -47,7 +52,7 @@ TUPLE: terrain-world < game-world PLAYER-START-LOCATION >>location 0.0 >>yaw 0.0 >>pitch - { 0.0 0.0 0.0 } >>velocity + float-4{ 0.0 0.0 0.0 1.0 } >>velocity VELOCITY-MODIFIER-NORMAL >>velocity-modifier ; M: terrain-world tick-length @@ -68,48 +73,40 @@ M: terrain-world tick-length [ location>> vneg first3 glTranslatef ] tri ; : degrees ( deg -- rad ) - pi 180.0 / * ; + pi 180.0 / * ; inline -:: eye-rotate ( yaw pitch v -- v' ) - yaw degrees neg :> y - pitch degrees neg :> p - y cos :> cosy - y sin :> siny - 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 - v swap v.m ; +TYPED: eye-rotate ( yaw: float pitch: float v: float-4 -- v': float-4 ) + [ float-4{ 0.0 -1.0 0.0 0.0 } swap degrees rotation-matrix4 ] + [ float-4{ -1.0 0.0 0.0 0.0 } swap degrees rotation-matrix4 m4. ] + [ m4.v ] tri* float-4{ t t t f } vand ; : forward-vector ( player -- v ) yaw>> 0.0 - ${ 0.0 0.0 MOVEMENT-SPEED } vneg eye-rotate ; + float-4{ 0.0 0.0 $ MOVEMENT-SPEED 1.0 } vneg eye-rotate ; inline : rightward-vector ( player -- v ) yaw>> 0.0 - ${ MOVEMENT-SPEED 0.0 0.0 } eye-rotate ; + float-4{ $ MOVEMENT-SPEED 0.0 0.0 1.0 } eye-rotate ; inline : clamp-pitch ( pitch -- pitch' ) - -90.0 90.0 clamp ; + -90.0 90.0 clamp ; inline : walk-forward ( player -- ) - dup forward-vector [ v+ ] curry change-velocity drop ; + dup forward-vector [ v+ ] curry change-velocity drop ; inline : walk-backward ( player -- ) - dup forward-vector [ v- ] curry change-velocity drop ; + dup forward-vector [ v- ] curry change-velocity drop ; inline : walk-leftward ( player -- ) - dup rightward-vector [ v- ] curry change-velocity drop ; + dup rightward-vector [ v- ] curry change-velocity drop ; inline : walk-rightward ( player -- ) - dup rightward-vector [ v+ ] curry change-velocity drop ; + dup rightward-vector [ v+ ] curry change-velocity drop ; inline : jump ( player -- ) - [ ${ 0.0 JUMP 0.0 } v+ ] change-velocity drop ; + [ float-4{ 0.0 $ JUMP 0.0 0.0 } v+ ] change-velocity drop ; inline : rotate-leftward ( player x -- ) - [ - ] curry change-yaw drop ; + [ - ] curry change-yaw drop ; inline : rotate-rightward ( player x -- ) - [ + ] curry change-yaw drop ; + [ + ] curry change-yaw drop ; inline : look-horizontally ( player x -- ) - [ + ] curry change-yaw drop ; + [ + ] curry change-yaw drop ; inline : look-vertically ( player x -- ) - [ + clamp-pitch ] curry change-pitch drop ; + [ + clamp-pitch ] curry change-pitch drop ; inline : rotate-with-mouse ( player mouse -- ) @@ -155,7 +152,7 @@ terrain-world H{ FRICTION v* ; : apply-gravity ( velocity -- velocity' ) - 1 over [ GRAVITY - ] change-nth ; + GRAVITY v+ ; : clamp-coords ( coords dim -- coords' ) [ { 0 0 } vmax ] dip { 2 2 } v- vmin ; @@ -206,11 +203,9 @@ terrain-world H{ drop ; : tick-player ( world player -- ) - dup reverse-time>> [ - tick-player-reverse - ] [ - tick-player-forward - ] if ; + dup reverse-time>> + [ tick-player-reverse ] + [ tick-player-forward ] if ; M: terrain-world tick* [ dup focused?>> [ handle-input ] [ drop ] if ] @@ -236,11 +231,11 @@ BEFORE: terrain-world begin-world GL_VERTEX_ARRAY glEnableClientState >>player V{ } clone >>history - 0.01 0.01 { 512 512 } perlin-noise-image + 0.01 float-4-with scale-matrix4 { 512 512 } perlin-noise-image [ >>sky-image ] keep make-texture [ set-texture-parameters ] keep >>sky-texture [ >>terrain ] keep - { 0 0 } terrain-segment [ >>terrain-segment ] keep + float-4{ 0.0 0.0 0.0 1.0 } terrain-segment [ >>terrain-segment ] keep make-texture [ set-texture-parameters ] keep >>terrain-texture sky-vertex-shader sky-pixel-shader >>sky-program @@ -282,7 +277,7 @@ M: terrain-world draw-world* ] with-gl-program ] } cleave gl-error ; -M: terrain-world pref-dim* drop { 640 480 } ; +M: terrain-world pref-dim* drop { 1024 768 } ; : terrain-window ( -- ) [