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

db4
Slava Pestov 2009-05-07 23:26:37 -05:00
commit 94bd764d35
17 changed files with 363 additions and 53 deletions

View File

@ -21,43 +21,48 @@ CONSTANT: rs-reg 14
: xt-save ( -- n ) stack-frame 2 bootstrap-cells - ;
[
0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
11 6 profile-count-offset LWZ
0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
11 3 profile-count-offset LWZ
11 11 1 tag-fixnum ADDI
11 6 profile-count-offset STW
11 6 word-code-offset LWZ
11 3 profile-count-offset STW
11 3 word-code-offset LWZ
11 11 compiled-header-size ADDI
11 MTCTR
BCTR
] jit-profiling jit-define
[
0 6 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel
0 3 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel
0 MFLR
1 1 stack-frame SUBI
6 1 xt-save STW
stack-frame 6 LI
6 1 next-save STW
3 1 xt-save STW
stack-frame 3 LI
3 1 next-save STW
0 1 lr-save stack-frame + STW
] jit-prolog jit-define
[
0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
6 ds-reg 4 STWU
0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
3 ds-reg 4 STWU
] jit-push-immediate jit-define
[
0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
7 6 0 LWZ
1 7 0 STW
0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
6 MTCTR
0 3 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
4 3 0 LWZ
1 4 0 STW
0 3 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
3 MTCTR
BCTR
] jit-primitive jit-define
[ 0 BL rc-relative-ppc-3 rt-xt-pic jit-rel ] jit-word-call jit-define
[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-jump jit-define
[
0 6 LOAD32 rc-absolute-ppc-2/2 rt-here jit-rel
0 B rc-relative-ppc-3 rt-xt-pic-tail jit-rel
] jit-word-jump jit-define
[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-special jit-define
[
3 ds-reg 0 LWZ
@ -152,6 +157,9 @@ CONSTANT: rs-reg 14
! ! ! Polymorphic inline caches
! Don't touch r6 here; it's used to pass the tail call site
! address for tail PICs
! Load a value from a stack position
[
4 ds-reg 0 LWZ rc-absolute-ppc-2 rt-untagged jit-rel
@ -225,7 +233,7 @@ CONSTANT: rs-reg 14
! if(get(cache) == class)
6 3 0 LWZ
6 0 4 CMP
5 BNE
10 BNE
! megamorphic_cache_hits++
0 4 LOAD32 rc-absolute-ppc-2/2 rt-megamorphic-cache-hits jit-rel
5 4 0 LWZ

View File

@ -713,3 +713,4 @@ USE: vocabs.loader
} cond
"complex-double" c-type t >>return-in-registers? drop
"bool" c-type 4 >>size 4 >>align drop

View File

@ -0,0 +1,4 @@
IN: io.backend.windows.privileges.tests
USING: io.backend.windows.privileges tools.test ;
[ [ ] with-privileges ] must-infer

9
basis/io/backend/windows/privileges/privileges.factor Normal file → Executable file
View File

@ -1,12 +1,13 @@
USING: io.backend kernel continuations sequences
system vocabs.loader combinators ;
system vocabs.loader combinators fry ;
IN: io.backend.windows.privileges
HOOK: set-privilege io-backend ( name ? -- ) inline
HOOK: set-privilege io-backend ( name ? -- )
: with-privileges ( seq quot -- )
over [ [ t set-privilege ] each ] curry compose
swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline
[ '[ _ [ t set-privilege ] each @ ] ]
[ drop '[ _ [ f set-privilege ] each ] ]
2bi [ ] cleanup ; inline
{
{ [ os winnt? ] [ "io.backend.windows.nt.privileges" require ] }

View File

@ -42,7 +42,7 @@ IN: io.launcher.windows.nt.tests
console-vm "-run=listener" 2array >>command
+closed+ >>stdin
+stdout+ >>stderr
ascii [ input-stream get contents ] with-process-reader
ascii [ contents ] with-process-reader
] unit-test
: launcher-test-path ( -- str )
@ -85,7 +85,7 @@ IN: io.launcher.windows.nt.tests
<process>
console-vm "-script" "stderr.factor" 3array >>command
"err2.txt" temp-file >>stderr
ascii <process-reader> lines first
ascii <process-reader> stream-lines first
] with-directory
] unit-test
@ -97,7 +97,7 @@ IN: io.launcher.windows.nt.tests
launcher-test-path [
<process>
console-vm "-script" "env.factor" 3array >>command
ascii <process-reader> contents
ascii <process-reader> stream-contents
] with-directory eval( -- alist )
os-envs =
@ -109,7 +109,7 @@ IN: io.launcher.windows.nt.tests
console-vm "-script" "env.factor" 3array >>command
+replace-environment+ >>environment-mode
os-envs >>environment
ascii <process-reader> contents
ascii <process-reader> stream-contents
] with-directory eval( -- alist )
os-envs =
@ -120,7 +120,7 @@ IN: io.launcher.windows.nt.tests
<process>
console-vm "-script" "env.factor" 3array >>command
{ { "A" "B" } } >>environment
ascii <process-reader> contents
ascii <process-reader> stream-contents
] with-directory eval( -- alist )
"A" swap at
@ -132,7 +132,7 @@ IN: io.launcher.windows.nt.tests
console-vm "-script" "env.factor" 3array >>command
{ { "USERPROFILE" "XXX" } } >>environment
+prepend-environment+ >>environment-mode
ascii <process-reader> contents
ascii <process-reader> stream-contents
] with-directory eval( -- alist )
"USERPROFILE" swap at "XXX" =

View File

@ -5,8 +5,6 @@ random sequences sets combinators.short-circuit math.bitwise
math math.order ;
IN: math.miller-rabin
<PRIVATE
: >odd ( n -- int ) 0 set-bit ; foldable
: >even ( n -- int ) 0 clear-bit ; foldable
@ -15,7 +13,7 @@ IN: math.miller-rabin
: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ;
TUPLE: positive-even-expected n ;
<PRIVATE
:: (miller-rabin) ( n trials -- ? )
n 1 - :> n-1

View File

@ -39,6 +39,8 @@ SLOT: display-list
GENERIC: draw-scaled-texture ( dim texture -- )
DEFER: make-texture
<PRIVATE
TUPLE: single-texture image dim loc texture-coords texture display-list disposed ;
@ -61,18 +63,6 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed
[ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri
glTexSubImage2D ;
: make-texture ( image -- id )
#! We use glTexSubImage2D to work around the power of 2 texture size
#! limitation
gen-texture [
GL_TEXTURE_BIT [
GL_TEXTURE_2D swap glBindTexture
non-power-of-2-textures? get
[ dup bitmap>> (tex-image) ]
[ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if
] do-attribs
] keep ;
: init-texture ( -- )
GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri
GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri
@ -176,6 +166,18 @@ CONSTANT: max-texture-size { 512 512 }
PRIVATE>
: make-texture ( image -- id )
#! We use glTexSubImage2D to work around the power of 2 texture size
#! limitation
gen-texture [
GL_TEXTURE_BIT [
GL_TEXTURE_2D swap glBindTexture
non-power-of-2-textures? get
[ dup bitmap>> (tex-image) ]
[ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if
] do-attribs
] keep ;
: <texture> ( image loc -- texture )
over dim>> max-texture-size [ <= ] 2all?
[ <single-texture> ]

View File

@ -29,7 +29,7 @@ PIXEL-FORMAT-ATTRIBUTE-TABLE: NSOpenGLPFA { } H{
{ fullscreen { $ NSOpenGLPFAFullScreen } }
{ windowed { $ NSOpenGLPFAWindow } }
{ accelerated { $ NSOpenGLPFAAccelerated } }
{ software-rendered { $ NSOpenGLPFASingleRenderer $ kCGLRendererGenericFloatID } }
{ software-rendered { $ NSOpenGLPFARendererID $ kCGLRendererGenericFloatID } }
{ backing-store { $ NSOpenGLPFABackingStore } }
{ multisampled { $ NSOpenGLPFAMultisample } }
{ supersampled { $ NSOpenGLPFASupersample } }

View File

@ -89,7 +89,7 @@ M: bunny-buffers bunny-geom
GL_FLOAT 0 0 buffer-offset glNormalPointer
[
nv>> "float" heap-size * buffer-offset
3 GL_FLOAT 0 roll glVertexPointer
[ 3 GL_FLOAT 0 ] dip glVertexPointer
] [
ni>>
GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements

View File

@ -120,7 +120,7 @@ TUPLE: bunny-outlined
: outlining-supported? ( -- ? )
"2.0" {
"GL_ARB_shading_objects"
"GL_ARB_shader_objects"
"GL_ARB_draw_buffers"
"GL_ARB_multitexture"
} has-gl-version-or-extensions? {

View File

@ -1,4 +1,4 @@
USING: accessors destructors kernel math math.order namespaces
USING: accessors calendar destructors kernel math math.order namespaces
system threads ;
IN: game-loop
@ -50,7 +50,7 @@ CONSTANT: MAX-FRAMES-TO-SKIP 5
: (run-loop) ( loop -- )
dup running?>>
[ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ yield (run-loop) ] tri ]
[ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ 1 milliseconds sleep (run-loop) ] tri ]
[ drop ] if ;
: run-loop ( loop -- )

View File

@ -25,7 +25,7 @@ M: image <image-gadget>
M: string <image-gadget> load-image <image-gadget> ;
M: pathname <image-gadget> load-image <image-gadget> ;
M: pathname <image-gadget> string>> load-image <image-gadget> ;
: image-window ( object -- ) <image-gadget> "Image" open-window ;

View File

@ -7,6 +7,9 @@ IN: noise
: <perlin-noise-table> ( -- table )
256 iota >byte-array randomize dup append ;
: with-seed ( seed quot -- )
[ <mersenne-twister> ] dip with-random ; inline
<PRIVATE
: fade ( point -- point' )
@ -54,9 +57,6 @@ IN: noise
v w quot call
; inline
: with-seed ( seed quot -- )
[ <mersenne-twister> ] dip with-random ; inline
: >byte-map ( floats -- bytes )
[ 255.0 * >fixnum ] B{ } map-as ;

View File

@ -1,9 +1,9 @@
USING: arrays kernel math math.functions math.order math.vectors
namespaces opengl opengl.gl sequences ui ui.gadgets ui.gestures
ui.gadgets.worlds ui.render accessors combinators ;
ui.gadgets.worlds ui.render accessors combinators literals ;
IN: opengl.demo-support
: FOV ( -- x ) 2.0 sqrt 1+ ; inline
CONSTANT: FOV $[ 2.0 sqrt 1+ ]
CONSTANT: MOUSE-MOTION-SCALE 0.5
CONSTANT: KEY-ROTATE-STEP 10.0

View File

@ -0,0 +1,60 @@
USING: accessors arrays byte-arrays combinators fry grouping
images kernel math math.affine-transforms math.order
math.vectors noise random sequences ;
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 }
TUPLE: terrain big-noise-table small-noise-table tiny-noise-seed ;
: <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 ;
: 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 )
[ tiny-noise-seed>> ] dip seed-at 0.1
terrain-segment-size normal-noise-byte-map ;
: padding ( terrain at -- padding )
2drop terrain-segment-size product 255 <repetition> ;
TUPLE: segment image ;
: terrain-segment ( terrain at -- image )
{
[ big-noise-segment ]
[ small-noise-segment ]
[ tiny-noise-segment ]
[ padding ]
} 2cleave
4array flip concat >byte-array
[ terrain-segment-size RGBA f ] dip image boa ;
: 4max ( a b c d -- max )
max max max ; inline
: mipmap ( {{pixels}} quot: ( aa ab ba bb -- c ) -- pixels' )
[ [ 2 <groups> ] map 2 <groups> ] dip
'[ first2 [ [ first2 ] bi@ @ ] 2map ] map ; inline
: group-pixels ( bitmap dim -- scanlines )
[ 4 <groups> ] [ first <groups> ] bi* ;
: concat-pixels ( scanlines -- bitmap )
[ concat ] map concat ;
: segment-mipmap ( image -- image' )
[ clone ] [ bitmap>> ] [ dim>> ] tri
group-pixels [ 4max ] mipmap concat-pixels >>bitmap
[ 2 v/n ] change-dim ;

View File

@ -0,0 +1,46 @@
USING: multiline ;
IN: terrain.shaders
STRING: terrain-vertex-shader
uniform sampler2D heightmap;
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);
}
void main()
{
gl_Position = gl_ModelViewProjectionMatrix
* (gl_Vertex + vec4(0, height(heightmap, gl_Vertex.xz), 0, 0));
heightcoords = gl_Vertex.xz;
}
;
STRING: terrain-pixel-shader
uniform sampler2D heightmap;
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);
}
void main()
{
gl_FragColor = texture2D(heightmap, heightcoords);
}
;

View File

@ -0,0 +1,190 @@
USING: accessors arrays combinators game-input
game-input.scancodes game-loop 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
terrain.generation terrain.shaders ui ui.gadgets
ui.gadgets.worlds ui.pixel-formats ;
IN: terrain
CONSTANT: FOV $[ 2.0 sqrt 1+ ]
CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ]
CONSTANT: FAR-PLANE 1.0
CONSTANT: EYE-START { 0.5 0.5 1.2 }
CONSTANT: TICK-LENGTH $[ 1000 30 /i ]
CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ]
CONSTANT: MOVEMENT-SPEED $[ 1.0 512.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: terrain-world < world
eye yaw pitch
terrain terrain-segment terrain-texture terrain-program
terrain-vertex-buffer
game-loop ;
: frustum ( dim -- -x x -y y near far )
dup first2 min v/n
NEAR-PLANE FOV / v*n first2 [ [ neg ] keep ] bi@
NEAR-PLANE FAR-PLANE ;
: set-modelview-matrix ( gadget -- )
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
GL_MODELVIEW glMatrixMode
glLoadIdentity
[ pitch>> 1.0 0.0 0.0 glRotatef ]
[ yaw>> 0.0 1.0 0.0 glRotatef ]
[ eye>> vneg first3 glTranslatef ] tri ;
: vertex-array-vertex ( x z -- vertex )
[ terrain-vertex-distance first * ]
[ terrain-vertex-distance second * ] bi*
[ 0 ] dip float-array{ } 3sequence ;
: vertex-array-row ( z -- vertices )
dup 1 + 2array
terrain-vertex-size first 1 + iota
2array [ first2 swap vertex-array-vertex ] product-map
concat ;
: vertex-array ( -- vertices )
terrain-vertex-size second iota
[ vertex-array-row ] map concat ;
: >vertex-buffer ( bytes -- buffer )
[ GL_ARRAY_BUFFER ] dip GL_STATIC_DRAW <gl-buffer> ;
: draw-vertex-buffer-row ( i -- )
[ GL_TRIANGLE_STRIP ] dip
terrain-vertex-row-length * terrain-vertex-row-length
glDrawArrays ;
: draw-vertex-buffer ( buffer -- )
[ GL_ARRAY_BUFFER ] dip [
3 GL_FLOAT 0 f glVertexPointer
terrain-vertex-size second iota [ draw-vertex-buffer-row ] each
] with-gl-buffer ;
: degrees ( deg -- rad )
pi 180.0 / * ;
:: 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 ;
: forward-vector ( world -- v )
[ yaw>> ] [ pitch>> ] bi
{ 0.0 0.0 $ MOVEMENT-SPEED } vneg eye-rotate ;
: rightward-vector ( world -- v )
[ yaw>> ] [ pitch>> ] bi
{ $ 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 ;
: rotate-with-mouse ( world mouse -- )
[ dx>> MOUSE-SCALE * [ + ] curry change-yaw ]
[ dy>> MOUSE-SCALE * [ + ] curry change-pitch ] bi
drop ;
:: handle-input ( world -- )
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
world read-mouse rotate-with-mouse
reset-mouse ;
M: terrain-world tick*
[ handle-input ] keep
! [ eye>> ] [ yaw>> ] [ pitch>> ] tri 3array P ! debug
drop ;
M: terrain-world draw*
nip draw-world ;
: set-heightmap-texture-parameters ( texture -- )
GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit
GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri
GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri ;
M: terrain-world begin-world
"2.0" { "GL_ARB_vertex_buffer_object" "GL_ARB_shader_objects" }
require-gl-version-or-extensions
GL_DEPTH_TEST glEnable
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
<terrain> [ >>terrain ] keep
{ 0 0 } terrain-segment [ >>terrain-segment ] keep
make-texture [ set-heightmap-texture-parameters ] keep >>terrain-texture
terrain-vertex-shader terrain-pixel-shader <simple-gl-program>
>>terrain-program
vertex-array >vertex-buffer >>terrain-vertex-buffer
TICK-LENGTH over <game-loop> [ >>game-loop ] keep start-loop
reset-mouse
drop ;
M: terrain-world end-world
{
[ game-loop>> stop-loop ]
[ terrain-vertex-buffer>> delete-gl-buffer ]
[ terrain-program>> delete-gl-program ]
[ terrain-texture>> delete-texture ]
} cleave ;
M: terrain-world resize-world
GL_PROJECTION glMatrixMode
glLoadIdentity
dim>> [ [ 0 0 ] dip first2 glViewport ]
[ frustum glFrustum ] bi ;
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
terrain-vertex-buffer>> draw-vertex-buffer
] with-gl-program ]
tri gl-error ;
M: terrain-world focusable-child* drop t ;
M: terrain-world pref-dim* drop { 640 480 } ;
: terrain-window ( -- )
[
open-game-input
f T{ world-attributes
{ world-class terrain-world }
{ title "Terrain" }
{ pixel-format-attributes {
windowed
double-buffered
T{ depth-bits { value 24 } }
} }
} open-window
] with-ui ;