Clean up OpenGL code a bit

basis/opengl/opengl-docs.factor

@@ -1,9 +1,9 @@
-USING: help.markup help.syntax io kernel math quotations
+USING: alien help.markup help.syntax io kernel math quotations
-opengl.gl assocs vocabs.loader sequences accessors ;
+opengl.gl assocs vocabs.loader sequences accessors colors ;
 IN: opengl
 
 HELP: gl-color
-{ $values { "color" "a color specifier" } }
+{ $values { "color" color } }
 { $description "Wrapper for " { $link glColor4d } " taking a color specifier." } ;
 
 HELP: gl-error
@@ -60,20 +60,9 @@ HELP: do-attribs
 { $values { "bits" integer } { "quot" quotation } }
 { $description "Wraps a quotation in " { $link glPushAttrib } "/" { $link glPopAttrib } " calls." } ;
 
-HELP: sprite
+HELP: make-texture
-{ $class-description "A sprite is an OpenGL texture together with a display list which renders a textured quad. Sprites are used to draw text in the UI. Sprites have the following slots:"
+  { $values { "dim" "a pair of integers" } { "pixmap" c-ptr } { "type" "an OpenGL texture type" } { "id" "an OpenGL texture ID" } }
-    { $list
+{ $description "Creates a new OpenGL texture from a pixmap image whose dimensions are equal to " { $snippet "dim" } "." } ;
-        { { $snippet "dlist" } " - an OpenGL display list ID" }
-        { { $snippet "texture" } " - an OpenGL texture ID" }
-        { { $snippet "loc" } " - top-left corner of the sprite" }
-        { { $snippet "dim" } " - dimensions of the sprite" }
-        { { $snippet "dim2" } " - dimensions of the sprite, rounded up to the nearest powers of two" }
-    }
-} ;
-
-HELP: gray-texture
-{ $values { "sprite" sprite } { "pixmap" "an alien or byte array" } { "id" "an OpenGL texture ID" } }
-{ $description "Creates a new OpenGL texture from a 1 byte per pixel image whose dimensions are equal to " { $snippet "dim2" } "." } ;
   
 HELP: gen-dlist
 { $values { "id" integer } }
@@ -87,10 +76,6 @@ HELP: gl-translate
 { $values { "point" "a pair of integers" } }
 { $description "Wrapper for " { $link glTranslated } " taking a point object." } ;
 
-HELP: free-sprites
-{ $values { "sprites" "a sequence of " { $link sprite } " instances" } }
-{ $description "Deallocates native resources associated toa  sequence of sprites." } ;
-
 HELP: with-translation
 { $values { "loc" "a pair of integers" } { "quot" quotation } }
 { $description "Calls the quotation with a translation by " { $snippet "loc" } " pixels applied to the current " { $link GL_MODELVIEW } " matrix, restoring the matrix when the quotation is done." } ;

basis/opengl/opengl.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! Portions copyright (C) 2007 Eduardo Cavazos.
 ! Portions copyright (C) 2008 Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
@@ -188,31 +188,26 @@ MACRO: set-draw-buffers ( buffers -- )
 : gl-look-at ( eye focus up -- )
     [ first3 ] tri@ gluLookAt ;
 
-TUPLE: sprite loc dim dim2 dlist texture ;
+: make-texture ( dim pixmap type -- id )
-
+    [ gen-texture ] 3dip swap '[
-: <sprite> ( loc dim dim2 -- sprite )
-    f f sprite boa ;
-
-: sprite-size2 ( sprite -- w h ) dim2>> first2 ;
-
-: sprite-width ( sprite -- w ) dim>> first ;
-
-: gray-texture ( sprite pixmap -- id )
-    gen-texture [
         GL_TEXTURE_BIT [
             GL_TEXTURE_2D swap glBindTexture
-            [
+            GL_TEXTURE_2D
-                [ GL_TEXTURE_2D 0 GL_RGBA ] dip
+            0
-                sprite-size2 0 GL_LUMINANCE_ALPHA
+            GL_RGBA
+            _ first2
+            0
+            _
             GL_UNSIGNED_BYTE
-            ] dip glTexImage2D
+            _
+            glTexImage2D
         ] do-attribs
     ] keep ;
 
 : gen-dlist ( -- id ) 1 glGenLists ;
 
 : make-dlist ( type quot -- id )
-    gen-dlist [ rot glNewList call glEndList ] keep ; inline
+    [ gen-dlist ] 2dip '[ _ glNewList @ glEndList ] keep ; inline
 
 : init-texture ( -- )
     GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
@@ -225,34 +220,8 @@ TUPLE: sprite loc dim dim2 dlist texture ;
 : rect-texture-coords ( -- )
     float-array{ 0 0 1 0 1 1 0 1 } gl-texture-coord-pointer ;
 
-: draw-sprite ( sprite -- )
-    GL_TEXTURE_COORD_ARRAY [
-        dup loc>> gl-translate
-        GL_TEXTURE_2D over texture>> glBindTexture
-        init-texture rect-texture-coords
-        dim2>> fill-rect-vertices
-        (gl-fill-rect)
-        GL_TEXTURE_2D 0 glBindTexture
-    ] do-enabled-client-state ;
-
-: make-sprite-dlist ( sprite -- id )
-    GL_MODELVIEW [
-        GL_COMPILE [ draw-sprite ] make-dlist
-    ] do-matrix ;
-
-: init-sprite ( texture sprite -- )
-    swap >>texture
-    dup make-sprite-dlist >>dlist drop ;
-
 : delete-dlist ( id -- ) 1 glDeleteLists ;
 
-: free-sprite ( sprite -- )
-    [ dlist>> delete-dlist ]
-    [ texture>> delete-texture ] bi ;
-
-: free-sprites ( sprites -- )
-    [ nip [ free-sprite ] when* ] assoc-each ;
-
 : with-translation ( loc quot -- )
     GL_MODELVIEW [ [ gl-translate ] dip call ] do-matrix ; inline
 

basis/opengl/sprites/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/opengl/sprites/sprites-docs.factor

@@ -0,0 +1,18 @@
+IN: opengl.sprites
+USING: help.markup help.syntax ;
+
+HELP: sprite
+{ $class-description "A sprite is an OpenGL texture together with a display list which renders a textured quad. Sprites are used to draw text in the UI. Sprites have the following slots:"
+    { $list
+        { { $snippet "dlist" } " - an OpenGL display list ID" }
+        { { $snippet "texture" } " - an OpenGL texture ID" }
+        { { $snippet "loc" } " - top-left corner of the sprite" }
+        { { $snippet "dim" } " - dimensions of the sprite" }
+        { { $snippet "dim2" } " - dimensions of the sprite, rounded up to the nearest powers of two" }
+    }
+} ;
+
+HELP: free-sprites
+{ $values { "sprites" "a sequence of " { $link sprite } " instances" } }
+{ $description "Deallocates native resources associated toa  sequence of sprites." } ;
+

basis/opengl/sprites/sprites-tests.factor

@@ -0,0 +1,4 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test opengl.sprites ;
+IN: opengl.sprites.tests

basis/opengl/sprites/sprites.factor

@@ -0,0 +1,39 @@
+! Copyright (C) 2005, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences opengl opengl.gl assocs ;
+IN: opengl.sprites
+
+TUPLE: sprite loc dim dim2 dlist texture ;
+
+: <sprite> ( loc dim dim2 -- sprite )
+    f f sprite boa ;
+
+: sprite-size2 ( sprite -- w h ) dim2>> first2 ;
+
+: sprite-width ( sprite -- w ) dim>> first ;
+
+: draw-sprite ( sprite -- )
+    GL_TEXTURE_COORD_ARRAY [
+        dup loc>> gl-translate
+        GL_TEXTURE_2D over texture>> glBindTexture
+        init-texture rect-texture-coords
+        dim2>> fill-rect-vertices
+        (gl-fill-rect)
+        GL_TEXTURE_2D 0 glBindTexture
+    ] do-enabled-client-state ;
+
+: make-sprite-dlist ( sprite -- id )
+    GL_MODELVIEW [
+        GL_COMPILE [ draw-sprite ] make-dlist
+    ] do-matrix ;
+
+: init-sprite ( texture sprite -- )
+    swap >>texture
+    dup make-sprite-dlist >>dlist drop ;
+
+: free-sprite ( sprite -- )
+    [ dlist>> delete-dlist ]
+    [ texture>> delete-texture ] bi ;
+
+: free-sprites ( sprites -- )
+    [ nip [ free-sprite ] when* ] assoc-each ;

basis/ui/freetype/freetype.factor

@@ -1,7 +1,7 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.accessors alien.c-types arrays io kernel libc
-math math.vectors namespaces opengl opengl.gl assocs
+math math.vectors namespaces opengl opengl.gl opengl.sprites assocs
 sequences io.files io.styles continuations freetype
 ui.gadgets.worlds ui.render ui.backend byte-arrays accessors
 locals specialized-arrays.direct.uchar ;
@@ -128,8 +128,9 @@ M: freetype-renderer string-height ( open-font string -- h )
     drop height>> ;
 
 : glyph-size ( glyph -- dim )
-    dup glyph-hori-advance ft-ceil
+    [ glyph-hori-advance ft-ceil ]
-    swap glyph-height ft-ceil 2array ;
+    [ glyph-height ft-ceil ]
+    bi 2array ;
 
 : render-glyph ( font char -- bitmap )
     load-glyph dup
@@ -157,17 +158,17 @@ M: freetype-renderer string-height ( open-font string -- h )
             width [ glyph glyph-bitmap-width ]
             width2 [ width next-power-of-2 2 * ] |
         bitmap [
-            [let | bitmap' [ bitmap rows width * <direct-uchar-array> ] |
+            bitmap rows width * <direct-uchar-array> :> bitmap'
             0 0
             rows [ bitmap' texture width width2 copy-row ] times
             2drop
-            ]
         ] when
     ] ;
 
 : bitmap>texture ( glyph sprite -- id )
-    tuck sprite-size2 * 2 * <byte-array>
+    tuck dim2>> product 2 * <byte-array>
-    [ copy-bitmap ] keep gray-texture ;
+    [ copy-bitmap ] keep [ dim2>> ] dip
+    GL_LUMINANCE_ALPHA make-texture ;
 
 : glyph-texture-loc ( glyph font -- loc )
     [ drop glyph-hori-bearing-x ft-floor ]