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

basis/cpu/ppc/bootstrap.factor

@@ -97,11 +97,11 @@ CONSTANT: ctx-reg 16
     rs-reg ctx-reg context-retainstack-offset LWZ ;
 
 [
-    0 3 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel
+    0 12 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel
-    11 3 profile-count-offset LWZ
+    11 12 profile-count-offset LWZ
     11 11 1 tag-fixnum ADDI
-    11 3 profile-count-offset STW
+    11 12 profile-count-offset STW
-    11 3 word-code-offset LWZ
+    11 12 word-code-offset LWZ
     11 11 compiled-header-size ADDI
     11 MTCTR
     BCTR

basis/cpu/x86/64/bootstrap.factor

@@ -28,7 +28,7 @@ IN: bootstrap.x86
 
 [
     ! load entry point
-    safe-reg -7 [] LEA
+    safe-reg 0 MOV rc-absolute-cell rt-this jit-rel
     ! save stack frame size
     stack-frame-size PUSH
     ! push entry point

basis/images/tga/tga.factor

@@ -238,7 +238,7 @@ ERROR: bad-tga-unsupported ;
         ] unless
     ] ignore-errors
 
-    #! Only 24-bit uncompressed RGB and 32-bit uncompressed ARGB are supported.
+    #! Only 24-bit uncompressed BGR and 32-bit uncompressed BGRA are supported.
     #! Other formats would need to be converted to work within the image class.
     map-type 0 = [ bad-tga-unsupported ] unless 
     image-type 2 = [ bad-tga-unsupported ] unless
@@ -247,7 +247,7 @@ ERROR: bad-tga-unsupported ;
     
     #! Create image instance
     image new
-    alpha-bits 0 = [ RGB ] [ ARGB ] if >>component-order
+    alpha-bits 0 = [ BGR ] [ BGRA ] if >>component-order
     { image-width image-height }       >>dim
     pixel-order 0 =                    >>upside-down?
     image-data                         >>bitmap
@@ -259,7 +259,7 @@ M: tga-image stream>image
 M: tga-image image>stream
     drop
     [
-        component-order>> { RGB ARGB } member? [ bad-tga-unsupported ] unless
+        component-order>> { BGRA BGRA } member? [ bad-tga-unsupported ] unless
     ] keep
 
     B{ 0 }         write #! id-length
@@ -272,15 +272,15 @@ M: tga-image image>stream
         [ dim>> second 2 >le write ]
         [ component-order>>
           {
-              {  RGB [ B{ 24 } write ] }
+              {  BGR [ B{ 24 } write ] }
-              { ARGB [ B{ 32 } write ] }
+              { BGRA [ B{ 32 } write ] }
           } case
         ]
         [
             dup component-order>>
             {
-                {  RGB [ 0 ] }
+                {  BGR [ 0 ] }
-                { ARGB [ 8 ] }
+                { BGRA [ 8 ] }
             } case swap
             upside-down?>> [ 0 ] [ 2 ] if 3 shift bitor
             1 >le write

basis/io/launcher/unix/unix-tests.factor

@@ -3,7 +3,7 @@ USING: io.files io.files.temp io.directories io.pathnames
 tools.test io.launcher arrays io namespaces continuations math
 io.encodings.binary io.encodings.ascii accessors kernel
 sequences io.encodings.utf8 destructors io.streams.duplex locals
-concurrency.promises threads unix.process calendar ;
+concurrency.promises threads unix.process calendar unix ;
 
 [ ] [
     [ "launcher-test-1" temp-file delete-file ] ignore-errors
@@ -134,7 +134,7 @@ concurrency.promises threads unix.process calendar ;
             [ p fulfill ] [ wait-for-process s fulfill ] bi
         ] in-thread
 
-        p 1 seconds ?promise-timeout handle>> 9 kill drop
+        p 1 seconds ?promise-timeout handle>> kill-process*
         s ?promise 0 =
     ]
 ] unit-test

basis/io/launcher/unix/unix.factor

@@ -91,7 +91,7 @@ M: unix kill-process* ( pid -- )
 TUPLE: signal n ;
 
 : code>status ( code -- obj )
-    dup WIFEXITED [ WEXITSTATUS ] [ WTERMSIG signal boa ] if ;
+    dup WIFSIGNALED [ WTERMSIG signal boa ] [ WEXITSTATUS ] if ;
 
 M: unix wait-for-processes ( -- ? )
     0 <int> -1 over WNOHANG waitpid

basis/ui/backend/windows/windows.factor

@@ -502,6 +502,7 @@ SYMBOL: nc-buttons
     {
         { APPCOMMAND_BROWSER_BACKWARD [ pick window left-action send-action ] }
         { APPCOMMAND_BROWSER_FORWARD [ pick window right-action send-action ] }
+        [ drop ]
     } case 3drop ;
     
 : handle-wm-buttondown ( hWnd uMsg wParam lParam -- )

basis/ui/text/text-docs.factor

@@ -49,7 +49,7 @@ HELP: line-metrics
 { $contract "Outputs a " { $link metrics } " object with text measurements." } ;
 
 ARTICLE: "text-rendering" "Rendering text"
-"The " { $vocab-link "ui.text" } " vocabulary provides a cross-platform interface to the operating system's native font rendering engine. Currently, it uses Core Text on Mac OS X and FreeType on Windows and X11."
+"The " { $vocab-link "ui.text" } " vocabulary provides a cross-platform interface to the operating system's native font rendering engine. Currently, it uses Core Text on Mac OS X, Uniscribe on Windows and Pango on X11."
 { $subsections "fonts" }
 "Measuring text:"
 { $subsections

extra/game/models/collada/collada-docs.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: help.markup help.crossref help.stylesheet help.topics help.syntax
 definitions io prettyprint summary arrays math sequences vocabs strings
-see xml.data hashtables assocs game.models.collada.private game.models.util ;
+see xml.data hashtables assocs game.models.collada.private game.models
+game.models.util ;
 IN: game.models.collada
 
 ABOUT: "game.models.collada"

extra/game/models/collada/collada.factor

@@ -5,7 +5,7 @@ locals math math.parser sequences sequences.deep
 specialized-arrays.instances.alien.c-types.float
 specialized-arrays.instances.alien.c-types.uint splitting xml
 xml.data xml.traversal math.order
-namespaces combinators images gpu.shaders io make
+namespaces combinators images gpu.shaders io make game.models
 game.models.util io.encodings.ascii game.models.loader ;
 IN: game.models.collada
 
@@ -152,7 +152,7 @@ VERTEX-FORMAT: collada-vertex-format
         soa>aos 
         [ flatten >float-array ]
         [ flatten >uint-array ]
-        bi* collada-vertex-format model boa
+        bi* collada-vertex-format f model boa
     ] bi ;
     
 : mesh>triangles ( sources vertices mesh-tag -- models )

extra/game/models/models-docs.factor

@@ -6,4 +6,4 @@ see ;
 IN: game.models
 
 HELP: model
-{ $class-description "Tuple of a packed attribute buffer, index buffer and vertex format suitable for a single OpenGL draw call." } ;
+{ $class-description "Tuple of a packed attribute buffer, index buffer, vertex format and material suitable for a single OpenGL draw call." } ;

extra/game/models/models.factor

@@ -3,5 +3,5 @@
 USING: ;
 IN: game.models
 
-TUPLE: model attribute-buffer index-buffer vertex-format ;
+TUPLE: model attribute-buffer index-buffer vertex-format material ;
 

extra/game/models/obj/obj-docs.factor

@@ -0,0 +1,70 @@
+! Copyright (C) 2010 Erik Charlebois
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.crossref help.stylesheet help.topics help.syntax
+definitions io prettyprint summary arrays math sequences vocabs strings
+see xml.data hashtables assocs game.models.obj.private game.models
+game.models.util io.pathnames ;
+IN: game.models.obj
+
+ABOUT: "game.models.obj"
+
+ARTICLE: "game.models.obj" "Conversion of Wavefront OBJ assets"
+"The " { $vocab-link "game.models.obj" } " vocabulary implements words for converting Wavefront OBJ assets to data suitable for use with OpenGL." ;
+
+HELP: material
+{ $class-description "Tuple describing the GPU state that needs to be applied prior to rendering geometry tagged with this material." } ;
+
+HELP: cm
+{ $values { "current-material" material } }
+{ $description "Convenience word for accessing the current material while parsing primitives." } ;
+
+HELP: md
+{ $values { "material-dictionary" assoc } }
+{ $description "Convenience word for accessing the material dictionary while parsing primitives. " } ;
+
+HELP: strings>floats
+{ $values { "strings" sequence } { "floats" sequence } }
+{ $description "Convert a sequence of strings to a sequence of floats." } ;
+
+HELP: strings>faces
+{ $values { "strings" sequence } { "faces" sequence } }
+{ $description "Convert a sequence of '/'-delimited strings into a sequence of sequences of numbers. Each number is an index into the vertex, texture or normal tables, respectively." } ;
+
+HELP: split-string
+{ $values { "string" string } { "strings" sequence } }
+{ $description "Split the given string on whitespace." } ;
+
+HELP: line>mtl
+{ $values { "line" string } }
+{ $description "Process a line from a material file within the current parsing context." } ;
+
+HELP: read-mtl
+{ $values { "file" pathname } { "material-dictionary" assoc } }
+{ $description "Read the specified material file and generate a material dictionary keyed by material name." } ;
+
+HELP: obj-vertex-format
+{ $class-description "Vertex format used for rendering OBJ geometry." } ;
+
+HELP: triangle>aos
+{ $values { "x" sequence } { "y" sequence } }
+{ $description "Convert a sequence of vertex, texture and normal indices into a sequence of vertex, texture and normal values." } ;
+
+HELP: quad>aos
+{ $values { "x" sequence } { "y" sequence } { "z" sequence } }
+{ $description "Convert a sequence of vertex, texture and normal indices into two sequences of vertex, texture and normal values. This splits a quad into two triangles." } ;
+
+HELP: face>aos
+{ $values { "x" sequence } { "y" sequence } }
+{ $description "Convert a face line to a sequence of vertex attributes." } ;
+
+HELP: push*
+{ $values { "elt" "an object" } { "seq" sequence } { "seq" sequence } }
+{ $description "Push the value onto the sequence, keeping the sequence on the stack." } ;
+
+HELP: push-current-model
+{ $description "Push the current model being built onto the models list and initialize a fresh empty model." } ;
+
+HELP: line>obj
+{ $values { "line" string } }
+{ $description "Process a line from the object file within the current parsing context." } ;
+

extra/game/models/obj/obj.factor

@@ -1,98 +1,166 @@
-! Copyright (C) 2010 Your name.
+! Copyright (C) 2010 Erik Charlebois
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io io.encodings.ascii math.parser sequences splitting kernel
 assocs io.files combinators math.order math namespaces
 arrays sequences.deep accessors
 specialized-arrays.instances.alien.c-types.float
 specialized-arrays.instances.alien.c-types.uint
-game.models.util gpu.shaders images game.models.loader ;
+game.models game.models.util gpu.shaders images
+game.models.loader prettyprint ;
 IN: game.models.obj
 
 SINGLETON: obj-models
 "obj" ascii obj-models register-models-class
 
 <PRIVATE
-SYMBOLS: v vt vn i ;
+SYMBOLS: vp vt vn current-model current-material material-dictionary models ;
+
+TUPLE: material
+    { name                     initial: f }
+    { ambient-reflectivity     initial: { 1.0 1.0 1.0 } }
+    { diffuse-reflectivity     initial: { 1.0 1.0 1.0 } }
+    { specular-reflectivity    initial: { 1.0 1.0 1.0 } }
+    { transmission-filter      initial: { 1.0 1.0 1.0 } }
+    { dissolve                 initial: 1.0 }
+    { specular-exponent        initial: 10.0 }
+    { refraction-index         initial: 1.5 }
+    { ambient-map              initial: f }
+    { diffuse-map              initial: f }
+    { specular-map             initial: f }
+    { specular-exponent-map    initial: f }
+    { dissolve-map             initial: f }
+    { displacement-map         initial: f }
+    { bump-map                 initial: f }
+    { reflection-map           initial: f } ;
+
+: cm ( -- current-material ) current-material get ; inline
+: md ( -- material-dictionary ) material-dictionary get ; inline
+
+: strings>floats ( strings -- floats )
+    [ string>float ] map ;
+
+: strings>faces ( strings -- faces )
+    [ "/" split [ string>number ] map ] map ;
+
+: split-string ( string -- strings )
+    " \t\n" split harvest ;
+
+: line>mtl ( line -- )
+    " \t\n" split harvest
+    [
+        [ rest ] [ first ] bi
+        {
+            { "newmtl" [ first
+                [ material new swap >>name current-material set ]
+                [ cm swap md set-at ] bi
+            ] }
+            { "Ka"       [ 3 head [ string>float ] map cm (>>ambient-reflectivity)  ] }
+            { "Kd"       [ 3 head [ string>float ] map cm (>>diffuse-reflectivity)  ] }
+            { "Ks"       [ 3 head [ string>float ] map cm (>>specular-reflectivity) ] }
+            { "Tf"       [ 3 head [ string>float ] map cm (>>transmission-filter)   ] }
+            { "d"        [ first string>float cm          (>>dissolve)              ] }
+            { "Ns"       [ first string>float cm          (>>specular-exponent)     ] }
+            { "Ni"       [ first string>float cm          (>>refraction-index)      ] }
+            { "map_Ka"   [ first cm                       (>>ambient-map)           ] }
+            { "map_Kd"   [ first cm                       (>>diffuse-map)           ] }
+            { "map_Ks"   [ first cm                       (>>specular-map)          ] }
+            { "map_Ns"   [ first cm                       (>>specular-exponent-map) ] }
+            { "map_d"    [ first cm                       (>>dissolve-map)          ] }
+            { "map_bump" [ first cm                       (>>bump-map)              ] }
+            { "bump"     [ first cm                       (>>bump-map)              ] }
+            { "disp"     [ first cm                       (>>displacement-map)      ] }
+            { "refl"     [ first cm                       (>>reflection-map)        ] }
+            [ 2drop ]
+        } case
+    ] unless-empty ;
+
+: read-mtl ( file -- material-dictionary )
+    [
+        f current-material set
+        H{ } clone material-dictionary set
+    ] H{ } make-assoc
+    [
+        ascii file-lines [ line>mtl ] each
+        md
+    ] bind ;
 
 VERTEX-FORMAT: obj-vertex-format
     { "POSITION" float-components 3 f }
     { "TEXCOORD" float-components 2 f }
     { "NORMAL"   float-components 3 f } ;
 
-: string>floats ( x -- y )
+: triangle>aos ( x -- y )
-    [ string>float ] map ;
+    dup length
-
+    {
-: string>faces ( x -- y )
+        { 3 [
-    [ "/" split [ string>number ] map ] map ;
-
-: 3face>aos ( x -- y )
-    dup length {
-        { 3
-          [
             first3
-              [ 1 - v get nth ]
+            [ 1 - vp get nth ]
             [ 1 - vt get nth ]
             [ 1 - vn get nth ] tri* 3array flatten
         ] }
-        { 2
+        { 2 [
-          [
             first2
-              [ 1 - v get nth ]
+            [ 1 - vp get nth ]
             [ 1 - vt get nth ] bi* 2array flatten
         ] }
     } case ;
           
+: quad>aos ( x -- y z )
+    [ 3 head [ triangle>aos 1array ] map ]
+    [ [ 2 swap nth ]
+      [ 3 swap nth ]
+      [ 0 swap nth ] tri 3array
+      [ triangle>aos 1array ] map ]
+    bi ;
 
-: 4face>aos ( x -- y z )
+: face>aos ( x -- y )
-    [ 3 head [ 3face>aos 1array ] map ]
-    [ [ 0 swap nth ] [ 2 swap nth ] [ 3 swap nth ] tri 3array [ 3face>aos 1array ] map ]
-    bi
-    ;
-
-: faces>aos ( x -- y )
     dup length
     {
-        { 3 [ [ 3face>aos 1array ] map 1array ] }
+        { 3 [ [ triangle>aos 1array ] map 1array ] }
-        { 4 [ 4face>aos 2array ] }
+        { 4 [ quad>aos 2array ] }
     } case ;
 
-: push* ( x z -- y )
+: push* ( elt seq -- seq )
     [ push ] keep ;
 
+: push-current-model ( -- )
+    current-model get [
+        [ dseq>> flatten >float-array ]
+        [ iseq>> flatten >uint-array ]
+        bi obj-vertex-format current-material get model boa models get push
+        V{ } V{ } H{ } <indexed-seq> current-model set
+    ] unless-empty ;
+
 : line>obj ( line -- )
-    " \t\n" split harvest dup
+    split-string
-    length 1 >
     [
         [ rest ] [ first ] bi
         {
-            { "#" [ drop ] }
+            { "mtllib" [ first read-mtl material-dictionary set ] }
-            { "v" [ string>floats 3 head v [ push* ] change ] }
+            { "v"      [ strings>floats 3 head vp [ push* ] change ] }
-            { "vt" [ string>floats 2 head vt [ push* ] change ] }
+            { "vt"     [ strings>floats 2 head vt [ push* ] change ] }
-            { "vn" [ string>floats 3 head vn [ push* ] change ] }
+            { "vn"     [ strings>floats 3 head vn [ push* ] change ] }
-            { "f" [ string>faces faces>aos [ [ i [ push* ] change ] each ] each ] }
+            { "usemtl" [ push-current-model first md at current-material set ] }
-            { "o" [ drop ] }
+            { "f"      [ strings>faces face>aos [ [ current-model [ push* ] change ] each ] each ] }
-            { "g" [ drop ] }
+            [ 2drop ]
-            { "s" [ drop ] }
-            { "mtllib" [ drop ] }
-            { "usemtl" [ drop ] }
         } case
-    ]
+    ] unless-empty ;
-    [ drop ] if ;
 
 PRIVATE>
 
 M: obj-models stream>models
     drop
     [
-        V{ }
+        V{ } clone vp set
-        [ clone v set ]
+        V{ } clone vt set
-        [ clone vt set ]
+        V{ } clone vn set
-        [ clone vn set ] tri
+        V{ } clone models set
-        V{ } V{ } H{ } <indexed-seq> i set
+        V{ } V{ } H{ } <indexed-seq> current-model set
+        f current-material set
+        f material-dictionary set
     ] H{ } make-assoc 
     [
-        [ line>obj ] each-stream-line i get
+        [ line>obj ] each-stream-line push-current-model
-    ] bind
+        models get
-    [ dseq>> flatten >float-array ]
+    ] bind ;
-    [ iseq>> flatten >uint-array ] bi obj-vertex-format model boa 1array ;
 

extra/game/models/util/util.factor

@@ -3,8 +3,6 @@
 USING: sequences accessors kernel locals assocs ;
 IN: game.models.util
 
-TUPLE: model attribute-buffer index-buffer vertex-format ;
-
 TUPLE: indexed-seq dseq iseq rassoc ;
 INSTANCE: indexed-seq sequence
 

extra/model-viewer/model-viewer.factor

@@ -8,92 +8,108 @@ io io.encodings.ascii io.files io.files.temp kernel locals math
 math.matrices math.vectors.simd math.parser math.vectors
 method-chains namespaces sequences splitting threads ui ui.gadgets
 ui.gadgets.worlds ui.pixel-formats specialized-arrays
-specialized-vectors literals fry xml
+specialized-vectors literals fry
-xml.traversal sequences.deep destructors math.bitwise opengl.gl
+sequences.deep destructors math.bitwise opengl.gl
-game.models.obj game.models.loader game.models.collada ;
+game.models game.models.obj game.models.loader game.models.collada
+prettyprint images.tga ;
 FROM: alien.c-types => float ;
 SPECIALIZED-ARRAY: float
 SPECIALIZED-VECTOR: uint
 IN: model-viewer
 
-GLSL-SHADER: model-vertex-shader vertex-shader
+GLSL-SHADER: obj-vertex-shader vertex-shader
-uniform mat4 mv_matrix, p_matrix;
+uniform mat4 mv_matrix;
-uniform vec3 light_position;
+uniform mat4 p_matrix;
 
 attribute vec3 POSITION;
+attribute vec3 TEXCOORD;
 attribute vec3 NORMAL;
-attribute vec2 TEXCOORD;
 
-varying vec2 texit;
+varying vec2 texcoord_fs;
-varying vec3 norm;
+varying vec3 normal_fs;
+varying vec3 world_pos_fs;
 
 void main()
 {
     vec4 position = mv_matrix * vec4(POSITION, 1.0);
     gl_Position   = p_matrix * position;
-    texit = TEXCOORD;
+    world_pos_fs  = POSITION;
-    norm = NORMAL;
+    texcoord_fs   = TEXCOORD;
+    normal_fs     = NORMAL;
 }
 ;
 
-GLSL-SHADER: model-fragment-shader fragment-shader
+GLSL-SHADER: obj-fragment-shader fragment-shader
-varying vec2 texit;
-varying vec3 norm;
-void main()
-{
-    gl_FragColor = vec4(texit, 0, 1) + vec4(norm, 1);
-}
-;
-
-GLSL-PROGRAM: model-program
-    model-vertex-shader model-fragment-shader ;
-
-GLSL-SHADER: debug-vertex-shader vertex-shader
 uniform mat4 mv_matrix, p_matrix;
-uniform vec3 light_position;
+uniform sampler2D map_Ka;
-
+uniform sampler2D map_bump;
-attribute vec3 POSITION;
+uniform vec3 Ka;
-attribute vec3 COLOR;
+uniform vec3 view_pos;
-varying vec4 color;
+uniform vec3 light;
-
+varying vec2 texcoord_fs;
+varying vec3 normal_fs;
+varying vec3 world_pos_fs;
 void main()
 {
-    gl_Position = p_matrix * mv_matrix * vec4(POSITION, 1.0);
+    vec4 d = texture2D(map_Ka, texcoord_fs.xy);
-    color = vec4(COLOR, 1);
+    vec3 b = texture2D(map_bump, texcoord_fs.xy).xyz;
+    vec3 n = normal_fs;
+    vec3 v = normalize(view_pos - world_pos_fs);
+    vec3 l = normalize(light);
+    vec3 h = normalize(v + l);
+    float cosTh = saturate(dot(n, l));
+    gl_FragColor = d * cosTh
+                 + d * 0.5 * cosTh * pow(saturate(dot(n, h)), 10.0) ;
 }
 ;
 
-GLSL-SHADER: debug-fragment-shader fragment-shader
+GLSL-PROGRAM: obj-program
-varying vec4 color;
+    obj-vertex-shader obj-fragment-shader ;
-void main()
-{
-    gl_FragColor = color;
-}
-;
-
-GLSL-PROGRAM: debug-program debug-vertex-shader debug-fragment-shader ;
 
 UNIFORM-TUPLE: model-uniforms < mvp-uniforms
-    { "light-position" vec3-uniform  f } ;
+    { "map_Ka"    texture-uniform   f }
+    { "map_bump"  texture-uniform   f }
+    { "Ka"        vec3-uniform      f }
+    { "light"     vec3-uniform      f }
+    { "view_pos"  vec3-uniform      f }
+    ;
 
 TUPLE: model-state
     models
     vertex-arrays
-    index-vectors ;
+    index-vectors
+    textures
+    bumps
+    kas ;
 
-TUPLE: model-world < wasd-world
+TUPLE: model-world < wasd-world model-path model-state ;
-    { model-state model-state } ;
 
-VERTEX-FORMAT: model-vertex
+TUPLE: vbo
-    { "POSITION"   float-components 3 f }
+    vertex-buffer
-    { "NORMAL" float-components 3 f }
+    index-buffer index-count vertex-format texture bump ka ;
-    { "TEXCOORD" float-components 2 f } ;
 
-VERTEX-FORMAT: debug-vertex
+: white-image ( -- image )
-    { "POSITION" float-components 3 f }
+    { 1 1 } BGR ubyte-components f
-    { "COLOR"    float-components 3 f } ;
+    B{ 255 255 255 } image boa ;
 
-TUPLE: vbo vertex-buffer index-buffer index-count vertex-format ;
+: up-image ( -- image )
+    { 1 1 } BGR ubyte-components f
+    B{ 0 0 0 } image boa ;
+        
+: make-texture ( pathname alt -- texture )
+    swap [ nip load-image ] [ ] if*
+    [
+        [ component-order>> ]
+        [ component-type>> ] bi
+        T{ texture-parameters
+           { wrap repeat-texcoord }
+           { min-filter filter-linear }
+           { min-mipmap-filter f } }
+        <texture-2d>
+    ]
+    [
+        0 swap [ allocate-texture-image ] 3keep 2drop
+    ] bi ;
         
 : <model-buffers> ( models -- buffers )
     [
@@ -102,14 +118,18 @@ TUPLE: vbo vertex-buffer index-buffer index-count vertex-format ;
             [ index-buffer>> underlying>> static-upload draw-usage index-buffer byte-array>buffer ]
             [ index-buffer>> length ]
             [ vertex-format>> ]
+            [ material>> ambient-map>> white-image make-texture ]
+            [ material>> bump-map>> up-image make-texture ]
+            [ material>> ambient-reflectivity>> ]
         } cleave vbo boa
     ] map ;
 
 : fill-model-state ( model-state -- )
     dup models>> <model-buffers>
+    {
         [
             [
-            [ vertex-buffer>> model-program <program-instance> ]
+                [ vertex-buffer>> obj-program <program-instance> ]
                 [ vertex-format>> ] bi buffer>vertex-array
             ] map >>vertex-arrays drop
         ]
@@ -118,61 +138,39 @@ TUPLE: vbo vertex-buffer index-buffer index-count vertex-format ;
                 [ index-buffer>> ] [ index-count>> ] bi
                 '[ _ 0 <buffer-ptr> _ uint-indexes <index-elements> ] call
             ] map >>index-vectors drop
-    ] 2bi ;
+        ]
+        [ [ texture>> ] map >>textures drop ]
+        [ [ bump>> ] map >>bumps drop ]
+        [ [ ka>> ] map >>kas drop ]
+    } 2cleave ;
 
-: model-files ( -- files )
+: <model-state> ( model-world -- model-state )
-    { "C:/Users/erikc/Downloads/test2.dae"
+    model-path>> 1array model-state new swap
-      "C:/Users/erikc/Downloads/Sponza.obj" } ;
+    [ load-models ] [ append ] map-reduce >>models ;
 
-: <model-state> ( -- model-state )
+:: <model-uniforms> ( world -- uniforms )
-    model-state new
+    world model-state>>
-    model-files [ load-models ] [ append ] map-reduce >>models ;
+    [ textures>> ] [ bumps>> ] [ kas>> ] tri
+    [| texture bump ka |
+        world wasd-mv-matrix
+        world wasd-p-matrix
+        texture bump ka
+        { 0.5 0.5 0.5 }
+        world location>>
+        model-uniforms boa
+    ] 3map ;
 
-M: model-world begin-game-world
+: clear-screen ( -- )
-    init-gpu
-    { 0.0 0.0 2.0 } 0 0 set-wasd-view
-    <model-state> [ fill-model-state drop ] [ >>model-state drop ] 2bi ;
-
-: <model-uniforms> ( world -- uniforms )
-    [ wasd-mv-matrix ] [ wasd-p-matrix ] bi
-    { -10000.0 10000.0 10000.0 } ! light position
-    model-uniforms boa ;
-
-: draw-line ( world from to color -- )
-    [ 3 head ] tri@ dup -rot append -rot append swap append >float-array
-    underlying>> stream-upload draw-usage vertex-buffer byte-array>buffer
-    debug-program <program-instance> debug-vertex buffer>vertex-array
-    
-    { 0 1 } >uint-array stream-upload draw-usage index-buffer byte-array>buffer
-    2 '[ _ 0 <buffer-ptr> _ uint-indexes <index-elements> ] call
-    
-    rot <model-uniforms>
-
-    {
-        { "primitive-mode"     [ 3drop lines-mode ] }
-        { "uniforms"           [ nip nip ] }
-        { "vertex-array"       [ drop drop ] }
-        { "indexes"            [ drop nip ] }
-    } 3<render-set> render ;
-
-: draw-lines ( world lines -- )
-    3 <groups> [ first3 draw-line ] with each ; inline
-
-: draw-axes ( world -- )
-    { { 0 0 0 } { 1 0 0 } { 1 0 0 }
-      { 0 0 0 } { 0 1 0 } { 0 1 0 }
-      { 0 0 0 } { 0 0 1 } { 0 0 1 } } draw-lines ;
-          
-: draw-model ( world -- )
     0 0 0 0 glClearColor 
     1 glClearDepth
     HEX: ffffffff glClearStencil
-    { GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT GL_STENCIL_BUFFER_BIT } flags glClear
+    { GL_COLOR_BUFFER_BIT
+      GL_DEPTH_BUFFER_BIT
+      GL_STENCIL_BUFFER_BIT } flags glClear ;
     
-    [
+: draw-model ( world -- )
-        triangle-fill dup t <triangle-state> set-gpu-state
+    clear-screen
     face-ccw cull-back <triangle-cull-state> set-gpu-state
-        
     cmp-less <depth-state> set-gpu-state
     [ model-state>> vertex-arrays>> ]
     [ model-state>> index-vectors>> ]
@@ -185,27 +183,39 @@ M: model-world begin-game-world
             { "vertex-array"       [ drop drop ] }
             { "indexes"            [ drop nip ] }
         } 3<render-set> render
-        ] curry 2each
+    ] 3each ;
-    ]
-    [
-        cmp-always <depth-state> set-gpu-state
-        draw-axes
-    ]
-    bi ;
 
-M: model-world draw-world*
+TUPLE: model-attributes < game-attributes model-path ;
-    draw-model ;
 
+M: model-world draw-world* draw-model ;
 M: model-world wasd-movement-speed drop 1/4. ;
 M: model-world wasd-near-plane drop 1/32. ;
 M: model-world wasd-far-plane drop 1024.0 ;
+M: model-world begin-game-world
+    init-gpu
+    { 0.0 0.0 2.0 } 0 0 set-wasd-view
+    [ <model-state> [ fill-model-state ] keep ] [ (>>model-state) ] bi ;
+M: model-world apply-world-attributes
+    {
+        [ model-path>> >>model-path ]
+        [ call-next-method ]
+    } cleave ;
 
-GAME: model-viewer {
+:: open-model-viewer ( model-path -- )
+    [
+        f
+        T{ model-attributes
            { world-class model-world }
-        { title "Model Viewer" }
-        { pixel-format-attributes { windowed double-buffered } }
            { grab-input? t }
-        { use-game-input? t }
+           { title "Model Viewer" }
+           { pixel-format-attributes
+             { windowed double-buffered }
+           }
            { pref-dim { 1024 768 } }
-        { tick-interval-micros $[ 60 fps ] }
+           { tick-interval-micros 16666 }
-    } ;
+           { use-game-input? t }
+           { model-path model-path }
+        }
+        clone
+        open-window
+    ] with-ui ;

misc/fuel/fuel-syntax.el

@@ -287,6 +287,7 @@
     ("\\_<\\()\\))\\_>" (1 ")("))
     ;; Quotations:
     ("\\_<'\\(\\[\\)\\_>" (1 "(]"))      ; fried
+    ("\\_<$\\(\\[\\)\\_>" (1 "(]"))      ; parse-time
     ("\\_<\\(\\[\\)\\_>" (1 "(]"))
     ("\\_<\\(\\]\\)\\_>" (1 ")["))))
 

vm/io.cpp

@@ -187,16 +187,11 @@ void factor_vm::primitive_fread()
 
 	data_root<byte_array> buf(allot_uninitialized_array<byte_array>(size),this);
 
-	for(;;)
-	{
 	int c = safe_fread(buf.untagged() + 1,1,size,file);
 	if(c == 0)
 	{
 		if(feof(file))
-			{
 			ctx->push(false_object);
-				break;
-			}
 		else
 			io_error();
 	}
@@ -210,8 +205,6 @@ void factor_vm::primitive_fread()
 		}
 
 		ctx->push(buf.value());
-			break;
-		}
 	}
 }
 

vm/os-windows-nt.cpp

@@ -37,8 +37,6 @@ u64 system_micros()
 		- EPOCH_OFFSET) / 10;
 }
 
-/* On VirtualBox, QueryPerformanceCounter does not increment
-the high part every time the low part overflows.  Workaround. */
 u64 nano_count()
 {
 	LARGE_INTEGER count;
@@ -53,8 +51,14 @@ u64 nano_count()
 	if(ret == 0)
 		fatal_error("QueryPerformanceFrequency", 0);
 
-	if(count.LowPart < lo)
+#ifdef FACTOR_64
-		hi += 1;
+	hi = count.HighPart;
+#else
+	/* On VirtualBox, QueryPerformanceCounter does not increment
+	the high part every time the low part overflows.  Workaround. */
+	if(lo > count.LowPart)
+		hi++;
+#endif
 	lo = count.LowPart;
 
 	return (u64)((((u64)hi << 32) | (u64)lo)*(1000000000.0/frequency.QuadPart));
@@ -91,7 +95,7 @@ LONG factor_vm::exception_handler(PEXCEPTION_POINTERS pe)
 	case STATUS_FLOAT_UNDERFLOW:
 	case STATUS_FLOAT_MULTIPLE_FAULTS:
 	case STATUS_FLOAT_MULTIPLE_TRAPS:
-#ifdef FACTOR_AMD64
+#ifdef FACTOR_64
 		signal_fpu_status = fpu_status(MXCSR(c));
 #else
 		signal_fpu_status = fpu_status(X87SW(c) | MXCSR(c));

vm/os-windows.cpp

@@ -128,7 +128,7 @@ segment::~segment()
 long getpagesize()
 {
 	static long g_pagesize = 0;
-	if (! g_pagesize)
+	if(!g_pagesize)
 	{
 		SYSTEM_INFO system_info;
 		GetSystemInfo (&system_info);