Cel shading demo. Caching implementation of GL-FUNCTION: for windows.

Makefile

@@ -140,7 +140,7 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
 
 clean:
 	rm -f vm/*.o
-	rm -f libfactor.a
+	rm -f factor*.dll libfactor*.*
 
 vm/resources.o:
 	windres vm/factor.rs vm/resources.o

extra/cel-shading/cel-shading.factor

@@ -0,0 +1,152 @@
+USING: arrays bunny io io.files kernel
+       math math.functions math.vectors
+       namespaces
+       opengl opengl.gl
+       prettyprint
+       sequences ui ui.gadgets ui.gestures ui.render ;
+IN: cel-shading
+
+: NEAR-PLANE 1.0 64.0 / ; inline
+: FAR-PLANE 4.0 ; inline
+: FOV 2.0 sqrt 1+ ; inline
+: MOUSE-MOTION-SCALE 0.5 ; inline
+: MOUSE-DISTANCE-SCALE 1.0 64.0 / ; inline
+: KEY-ROTATE-STEP 1.0 ; inline
+: KEY-DISTANCE-STEP 1.0 64.0 / ; inline
+: DIMS { 640 480 } ; inline
+
+: FOV-RATIO ( -- fov ) DIMS dup first2 min v/n ;
+
+SYMBOL: last-drag-loc
+
+TUPLE: cel-shading-gadget yaw pitch distance model program ;
+
+: <cel-shading-gadget> ( -- cel-shading-gadget )
+    cel-shading-gadget construct-gadget
+    0.0 over set-cel-shading-gadget-yaw
+    0.0 over set-cel-shading-gadget-pitch
+    0.375 over set-cel-shading-gadget-distance
+    maybe-download read-model over set-cel-shading-gadget-model ;
+
+: yaw-cel-shading-gadget ( yaw gadget -- )
+    [ [ cel-shading-gadget-yaw + ] keep set-cel-shading-gadget-yaw ] keep relayout-1 ;
+
+: pitch-cel-shading-gadget ( pitch gadget -- )
+    [ [ cel-shading-gadget-pitch + ] keep set-cel-shading-gadget-pitch ] keep relayout-1 ;
+
+: zoom-cel-shading-gadget ( distance gadget -- )
+    [ [ cel-shading-gadget-distance + ] keep set-cel-shading-gadget-distance ] keep relayout-1 ;
+
+M: cel-shading-gadget pref-dim* ( gadget -- dim )
+    drop DIMS ;
+
+: -+ ( x -- -x x )
+    dup neg swap ;
+
+: cel-shading-frustum ( -- -x x -y y near far )
+    FOV-RATIO NEAR-PLANE FOV / v*n
+    first2 [ -+ ] 2apply NEAR-PLANE FAR-PLANE ;
+
+: cel-shading-vertex-shader-source
+    {
+        "varying vec3 position, normal;"
+        ""
+        "void"
+        "main()"
+        "{"
+            "gl_Position = ftransform();"
+            ""
+            "position = gl_Vertex.xyz;"
+            "normal = gl_Normal;"
+        "}"
+    } "\n" join ;
+
+: cel-shading-fragment-shader-source
+    {
+        "varying vec3 position, normal;"
+        "uniform vec3 light_direction;"
+        "uniform vec4 color;"
+        "uniform vec4 ambient, diffuse;"
+        ""
+        "float"
+        "smooth_modulate(vec3 direction, vec3 normal)"
+        "{"
+            "return clamp(dot(direction, normal), 0.0, 1.0);"
+        "}"
+        ""
+        "float"
+        "modulate(vec3 direction, vec3 normal)"
+        "{"
+            "float m = smooth_modulate(direction, normal);"
+            "return smoothstep(0.0, 0.01, m) * 0.4 + smoothstep(0.49, 0.5, m) * 0.5;"
+        "}"
+        ""
+        "void"
+        "main()"
+        "{"
+            "vec3 direction = normalize(light_direction - position);"
+            "gl_FragColor = ambient + diffuse * color * vec4(vec3(modulate(direction, normal)), 1); "
+        "}"
+    } "\n" join ;
+
+: cel-shading-program ( -- program )
+    cel-shading-vertex-shader-source <vertex-shader> check-gl-shader
+    cel-shading-fragment-shader-source <fragment-shader> check-gl-shader
+    2array <gl-program> check-gl-program ;
+
+M: cel-shading-gadget graft* ( gadget -- )
+    0.0 0.0 0.0 1.0 glClearColor
+    GL_CULL_FACE glEnable
+    GL_DEPTH_TEST glEnable
+    cel-shading-program swap set-cel-shading-gadget-program ;
+
+M: cel-shading-gadget ungraft* ( gadget -- )
+    cel-shading-gadget-program delete-gl-program ;
+
+: cel-shading-draw-setup ( gadget -- gadget )
+    GL_PROJECTION glMatrixMode
+    glLoadIdentity
+    cel-shading-frustum glFrustum
+    GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
+    GL_MODELVIEW glMatrixMode
+    glLoadIdentity
+    [ >r 0.0 0.0 r> cel-shading-gadget-distance neg glTranslatef ] keep
+    [ cel-shading-gadget-pitch 1.0 0.0 0.0 glRotatef ] keep
+    [ cel-shading-gadget-yaw   0.0 1.0 0.0 glRotatef ] keep
+    [ cel-shading-gadget-program [ "light_direction" glGetUniformLocation -25.0 45.0 80.0 glUniform3f ] keep
+                                   [ "color" glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f ] keep
+                                   [ "ambient" glGetUniformLocation 0.2 0.2 0.2 0.2 glUniform4f ] keep
+                                   "diffuse" glGetUniformLocation 0.8 0.8 0.8 0.8 glUniform4f ] keep ;
+
+M: cel-shading-gadget draw-gadget* ( gadget -- )
+    dup cel-shading-gadget-program [
+        cel-shading-draw-setup
+        0.0 -0.12 0.0 glTranslatef
+        cel-shading-gadget-model first3 draw-bunny
+    ] with-gl-program ;
+
+: reset-last-drag-rel ( -- )
+    { 0 0 } last-drag-loc set ;
+: last-drag-rel ( -- rel )
+    drag-loc [ last-drag-loc get v- ] keep last-drag-loc set ;
+
+: drag-yaw-pitch ( -- yaw pitch )
+    last-drag-rel MOUSE-MOTION-SCALE v*n first2 ;
+
+cel-shading-gadget H{
+    { T{ key-down f f "LEFT"  } [ KEY-ROTATE-STEP neg swap yaw-cel-shading-gadget ] }
+    { T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP     swap yaw-cel-shading-gadget ] }
+    { T{ key-down f f "DOWN"  } [ KEY-ROTATE-STEP neg swap pitch-cel-shading-gadget ] }
+    { T{ key-down f f "UP"    } [ KEY-ROTATE-STEP     swap pitch-cel-shading-gadget ] }
+    { T{ key-down f f "="     } [ KEY-DISTANCE-STEP neg swap zoom-cel-shading-gadget ] }
+    { T{ key-down f f "-"     } [ KEY-DISTANCE-STEP     swap zoom-cel-shading-gadget ] }
+    
+    { T{ button-down f f 1 }    [ drop reset-last-drag-rel ] }
+    { T{ drag f 1 }             [ drag-yaw-pitch rot [ pitch-cel-shading-gadget ] keep yaw-cel-shading-gadget ] }
+    { T{ mouse-scroll }         [ scroll-direction get second MOUSE-DISTANCE-SCALE * swap zoom-cel-shading-gadget ] }
+} set-gestures
+
+: cel-shading-window ( -- )
+    [ <cel-shading-gadget> "Cel Shading" open-window ] with-ui ;
+    
+MAIN: cel-shading-window

extra/opengl/gl/windows/windows.factor

@@ -1,18 +1,34 @@
-USING: alien alien.syntax kernel libc namespaces parser
-       sequences syntax system vectors ;
+USING: alien alien.syntax arrays assocs hashtables init kernel
+       libc math namespaces parser sequences syntax system vectors
+       windows.opengl32 ;
 
 IN: opengl.gl.windows
 
+<PRIVATE
+
+SYMBOL: gl-function-number-counter
 SYMBOL: gl-function-pointers
 
-LIBRARY: gl
-FUNCTION: void* wglGetProcAddress ( char* name ) ;
+0 gl-function-number-counter set
+[ 100 <hashtable> gl-function-pointers set ] "opengl.gl.windows init hook" add-init-hook
+
+: gl-function-number ( -- n )
+    gl-function-number-counter get
+    dup 1+ gl-function-number-counter set ;
+
+: gl-function-pointer ( name n -- funptr )
+    wglGetCurrentContext 2array dup gl-function-pointers get at
+    [ -rot 2drop ]
+    [ >r wglGetProcAddress dup r> gl-function-pointers get set-at ]
+    if* ;
+
+PRIVATE>
 
 : GL-FUNCTION:
     "stdcall"
     scan
     scan
-    dup [ wglGetProcAddress check-ptr ] curry swap
+    dup gl-function-number [ gl-function-pointer ] 2curry swap
     ";" parse-tokens [ "()" subseq? not ] subset
     define-indirect
     ; parsing

extra/windows/opengl32/opengl32.factor

@@ -1,8 +1,7 @@
 ! Copyright (C) 2005, 2006 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.syntax parser namespaces kernel
-math windows.types windows.types init assocs sequences opengl.gl
-libc ;
+math windows.types windows.types init assocs sequences libc ;
 IN: windows.opengl32
 
 ! PIXELFORMATDESCRIPTOR flags
@@ -100,4 +99,5 @@ LIBRARY: gl
 FUNCTION: HGLRC wglCreateContext ( HDC hDC ) ;
 FUNCTION: BOOL wglDeleteContext ( HGLRC hRC ) ;
 FUNCTION: BOOL wglMakeCurrent ( HDC hDC, HGLRC hglrc ) ;
+FUNCTION: HGLRC wglGetCurrentContext ( ) ;
 FUNCTION: void* wglGetProcAddress ( char* name ) ;