-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
-: <perlin-noise-table> ( -- table )
- 256 iota >byte-array randomize dup append ; inline
-
: with-seed ( seed quot -- )
[ <mersenne-twister> ] dip with-random ; inline
-<PRIVATE
+: random-int-4 ( -- v )
+ 16 random-bytes underlying>> int-4 boa ; inline
+
+: (random-float-4) ( -- v )
+ random-int-4 int-4 float-4 vconvert ; inline
+
+! 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
+
+: 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
+
+: 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
+
+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 ;
-: (fade) ( x y z -- x' y' z' )
- [ { 0.0 0.0 0.0 10.0 -15.0 6.0 } polyval* ] tri@ ;
+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 ;
-HINTS: (fade) { float float float } ;
+: uniform-noise-image ( seed dim -- image )
+ [ uniform-noise-map ] [ 1.0 0.0 float-map>image ] bi ; inline
-: fade ( point -- point' )
- first3 (fade) 3array ; 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 ;
-:: 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
+: normal-noise-image ( seed sigma dim -- image )
+ [ normal-noise-map ] [ 1.0 0.0 float-map>image ] bi ; inline
- hash 1 bitand zero? [ u ] [ u neg ] if
- hash 2 bitand zero? [ v ] [ v neg ] if + ;
+ERROR: invalid-perlin-noise-table table ;
-HINTS: grad { fixnum float float float } ;
+: <perlin-noise-table> ( -- table )
+ 256 iota >byte-array randomize dup append ; inline
-: unit-cube ( point -- cube )
- [ floor 256 rem ] map ;
+: 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
ab 1 + table nth-unsafe
bb 1 + table nth-unsafe ; inline
-HINTS: hashes { byte-array fixnum fixnum fixnum } ;
-
-: >byte-map ( floats -- bytes )
- [ 255.0 * >fixnum ] B{ } map-as ;
+:: 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
-: >image ( bytes dim -- image )
- image new
- swap >>dim
- swap >>bitmap
- L >>component-order
- ubyte-components >>component-type ;
+ hash 1 bitand zero? [ u ] [ u neg ] if
+ hash 2 bitand zero? [ v ] [ v neg ] if + ; inline
-:: 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 ;
-
-: 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
+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 ;
-: 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 ;
-
-: 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 ;
+ [ perlin-noise-map-coords perlin-noise-map ] [ 5/7. 0.5 float-map>image ] bi ;
-: 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 ;
-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> ( -- terrain )
<perlin-noise-table> <perlin-noise-table>
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 <scale> ] dip
- terrain-segment-size [ v* <translation> a. ] keep perlin-noise-byte-map ;
-: small-noise-segment ( terrain at -- map )
- [ small-noise-table>> terrain-small-noise-scale first2 <scale> ] dip
- terrain-segment-size [ v* <translation> 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 <repetition> ;
+ 2drop terrain-segment-size product 255 <repetition> >byte-array ; inline
TUPLE: segment image ;
-: <terrain-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] ) ;
+
+: <terrain-image> ( big small tiny padding -- image )
+ fold-rgba-planes
<image>
swap >>bitmap
RGBA >>component-order
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 <terrain-image> ;
+ {
+ [ big-noise-segment ]
+ [ small-noise-segment ]
+ [ tiny-noise-segment ]
+ [ padding ]
+ } 2cleave <terrain-image> ;
: 4max ( a b c d -- max )
max max max ; inline
! (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
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
[ 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 -- )
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 ;
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 ]
GL_VERTEX_ARRAY glEnableClientState
<player> >>player
V{ } clone >>history
- <perlin-noise-table> 0.01 0.01 <scale> { 512 512 } perlin-noise-image
+ <perlin-noise-table> 0.01 float-4-with scale-matrix4 { 512 512 } perlin-noise-image
[ >>sky-image ] keep
make-texture [ set-texture-parameters ] keep >>sky-texture
<terrain> [ >>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 <simple-gl-program>
>>sky-program
] with-gl-program ]
} cleave gl-error ;
-M: terrain-world pref-dim* drop { 640 480 } ;
+M: terrain-world pref-dim* drop { 1024 768 } ;
: terrain-window ( -- )
[
projects / factor.git / commitdiff