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

basis/cpu/ppc/bootstrap.factor

@@ -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
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
-    11 6 profile-count-offset LWZ
+    11 3 profile-count-offset LWZ
     11 11 1 tag-fixnum ADDI
-    11 6 profile-count-offset STW
+    11 3 profile-count-offset STW
-    11 6 word-code-offset LWZ
+    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
+    3 1 xt-save STW
-    stack-frame 6 LI
+    stack-frame 3 LI
-    6 1 next-save STW
+    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
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
-    6 ds-reg 4 STWU
+    3 ds-reg 4 STWU
 ] jit-push-immediate jit-define
 
 [
-    0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
-    7 6 0 LWZ
+    4 3 0 LWZ
-    1 7 0 STW
+    1 4 0 STW
-    0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
-    6 MTCTR
+    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

basis/cpu/ppc/ppc.factor

@@ -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

basis/io/backend/windows/privileges/privileges-tests.factor

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

basis/io/backend/windows/privileges/privileges.factor

@@ -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
+    [ '[ _ [ t set-privilege ] each @ ] ]
-    swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline
+    [ drop '[ _ [ f set-privilege ] each ] ]
+    2bi [ ] cleanup ; inline
 
 {
     { [ os winnt? ] [ "io.backend.windows.nt.privileges" require ] }

basis/io/launcher/windows/nt/nt-tests.factor

@@ -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" =

basis/math/miller-rabin/miller-rabin.factor

@@ -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

basis/opengl/textures/textures.factor

@@ -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> ]

basis/ui/backend/cocoa/cocoa.factor

@@ -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 } }

extra/bunny/model/model.factor

@@ -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

extra/bunny/outlined/outlined.factor

@@ -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? {

extra/game-loop/game-loop.factor

@@ -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 -- )

extra/images/viewer/viewer.factor

@@ -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 ;
 

extra/noise/noise.factor

@@ -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 ;
 

extra/opengl/demo-support/demo-support.factor

@@ -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
 

extra/terrain/generation/generation.factor

@@ -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 ;

extra/terrain/shaders/shaders.factor

@@ -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);
+}
+
+;

extra/terrain/terrain.factor

@@ -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 ;