Merge branch 'images.viewer' of git://github.com/jonenst/factor

extra/images/viewer/viewer-docs.factor

@@ -0,0 +1,103 @@
+! Copyright (C) 2010 Jon Harper.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel strings io.pathnames images 
+models opengl.textures classes ui.gadgets ;
+IN: images.viewer
+
+HELP: <image-gadget>
+{ $values
+    { "object" { $or pathname string image } }
+    { "gadget" image-gadget }
+}
+{ $description "Creates " { $instance image-gadget } " with the given image. See " { $link set-image } "." } ;
+HELP: <image-control>
+{ $values
+    { "model" model }
+    { "gadget" image-control }
+}
+{ $description "Creates " { $instance image-control } " with the given image. See " { $link set-image } "." } ;
+
+HELP: new-image-gadget
+{ $values
+    { "class" class }
+    { "gadget" image-gadget }
+}
+{ $description "Use this if the image is not available when you want to construct the gadget. Don't forget to call "
+{ $link set-image } " before grafting this gadget. You can also use this constructor if you want to extend image-gadget or image-control."
+} ;
+
+HELP: new-image-gadget*
+{ $values
+    { "object" { $or pathname string image } } { "class" class }
+    { "gadget" image-gadget }
+}
+{ $description "Use this constructor when you want to extend image-gadget or image-control." } ;
+
+HELP: set-image
+{ $values
+    { "gadget" image-gadget } { "object" { $or pathname string image } }
+}
+{ $description "Sets the image of this gadget. This word loads the image from disk if the input is a string or a pathname."
+"If the input is a model, gadget has to be " { $instance image-control } "." } ;
+
+HELP: image-control
+{ $var-description "This gadget is like " { $instance image-gadget } ", but it's image must be in " { $instance model } ". It's used to display changing images." } ;
+
+HELP: image-gadget
+{ $var-description "This gadget can render " { $instance image } "." } ;
+
+HELP: image-window
+{ $values
+    { "object" { $or pathname string image } }
+}
+{ $description "Opens a new window displaying the image." } ;
+
+HELP: image.
+{ $values
+    { "object" { $or pathname string image } }
+}
+{ $description "Displays the image in the listener." } ;
+HELP: start-control
+{ $values
+    { "gadget" gadget }
+}
+{ $description "Adds a connection between the gadget and it's model." } ;
+
+HELP: stop-control
+{ $values
+    { "gadget" gadget }
+}
+{ $description "Removes the connection between the gadget and it's model" } ;
+ARTICLE: "images.viewer" "Displaying Images"
+"The " { $vocab-link "images.viewer" } " vocabulary uses the " { $vocab-link "opengl.textures" } 
+" vocabulary to display any instance of " { $link image } "."$nl 
+"An " { $link image-gadget } " can be used for static images and " { $instance image-control } 
+" for changing images (for example a video feed). For changing images, the image should be containted in " { $instance model } 
+". Change the model value with " { $link set-model } " or mutate the image and call "
+{ $link notify-connections } " when you want to update the image. To stop refreshing the image, call " { $link stop-control } "."
+" To start refreshing again, call " { $link start-control } "."
+
+$nl
+"If the " { $link image } " or " { $link model } " containing the image "
+"is available when the object is created, use the following words to create the gadget:"
+{ $subsections <image-gadget> <image-control> }
+"The " { $link image } " or " { $link model }
+" can also be given after the construction of the object. In this case, use "
+{ $link new-image-gadget } " and " { $link set-image } "." 
+" The gadget will automatically detect if the image changes size or format and reallocate a new texture if needed."
+" This means images can be set even after the gadget has been grafted. Grafted gadgets without an image will display a blank screen."
+
+{ $notes "The image can be set after the gadget has been grafted. However, for " { $instance image-gadget } ", this can "
+" be done only once. If your image is changing, you should be using " { $instance image-control } " and " { $instance model } "." 
+$nl
+" Performance will be greatly reduced if you are using images that have more than 512 pixels on one of their"
+" axis." }
+
+
+$nl
+"Utility words for displaying images :"
+{ $subsections
+image. image-window }
+
+;
+ABOUT: "images.viewer"

extra/images/viewer/viewer-tests.factor

@@ -0,0 +1,36 @@
+! Copyright (C) 2010 Jon Harper.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test images.viewer images.viewer.private kernel accessors sequences images
+namespaces ui ui.gadgets.debug math opengl.textures opengl.textures.private 
+models ;
+IN: images.viewer.tests
+
+: (gen-image) ( dim -- bitmap )
+    product 3 * [ 200 ] BV{ } replicate-as ;
+: gen-image ( dim -- image )
+    dup (gen-image) <image> swap >>bitmap swap >>dim 
+    RGB >>component-order ubyte-components >>component-type ;
+
+[ ] [ { 50 50 } gen-image "s" set ] unit-test
+[ ] [ "s" get <image-gadget> "ig" set ] unit-test
+"ig" get [
+   [ t ] [ "ig" get image-gadget-texture single-texture? ] unit-test
+] with-grafted-gadget 
+
+[ ] [ "s" get <model> "m" set ] unit-test
+[ ] [ { 150 150 } gen-image "s1" set ] unit-test
+[ ] [ "m" get <image-control> "ic" set ] unit-test
+"ic" get [
+   [ t ] [ "ic" get image-gadget-texture single-texture? ] unit-test
+   [ { 50 50 } ] [ "ic" get texture>> texture-size ] unit-test
+] with-grafted-gadget
+
+! TODO
+! test that when changing the model, the gadget updates the texture.
+! - same size images (both smaller than 512x512) (updates)
+! test that when changing the model, the gadget creates a new texture.
+! test different cases : 
+! - same size images (both bigger than 512x512) (creates)
+! - different size images (both smaller than 512x512) (creates)
+! - different size images (both bigger than 512x512) (creates)
+! - different size images (1 smaller than, 1 bigger than 512x512)

extra/images/viewer/viewer.factor

@@ -1,17 +1,21 @@
 ! Copyright (C) 2007, 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors images images.loader io.pathnames kernel
-models namespaces opengl opengl.gl opengl.textures sequences
+models namespaces opengl opengl.gl opengl.textures opengl.textures.private
+sequences math arrays
 strings ui ui.gadgets ui.gadgets.panes ui.images ui.render
-constructors ;
+constructors locals combinators.short-circuit 
+literals destructors ui.gadgets.worlds continuations ;
 IN: images.viewer
 
 TUPLE: image-gadget < gadget image texture ;
+<PRIVATE
+M: image-gadget pref-dim* image>> [ dim>> ] [ { 640 480 } ] if* ;
 
-M: image-gadget pref-dim* image>> dim>> ;
+: (image-gadget-texture) ( gadget -- texture )
-
+    dup image>> { 0 0 } <texture> >>texture texture>> ;
 : image-gadget-texture ( gadget -- texture )
-    dup texture>> [ ] [ dup image>> { 0 0 } <texture> >>texture texture>> ] ?if ;
+    dup texture>> [ ] [ (image-gadget-texture) ] ?if ;
 
 M: image-gadget draw-gadget* ( gadget -- )
     dup image>> [
@@ -20,27 +24,88 @@ M: image-gadget draw-gadget* ( gadget -- )
         drop
     ] if ;
 
-TUPLE: image-control < image-gadget ;
+: delete-current-texture ( image-gadget -- )
+    [ texture>> [ dispose ] when* ]
+    [ f >>texture drop ] bi ;
 
-CONSTRUCTOR: image-control ( model -- image-control ) ;
+! In unit tests, find-gl-context throws no-world-found when using with-grafted-gadget.
+M: image-gadget ungraft* [ dup find-gl-context delete-current-texture ] [ 2drop ] recover ;
+PRIVATE>
+TUPLE: image-control < image-gadget image-updated? ;
+<PRIVATE
 
-M: image-control pref-dim* image>> [ dim>> ] [ { 640 480 } ] if* ;
+: (bind-2d-texture) ( texture-id -- )
+    [ GL_TEXTURE_2D ] dip glBindTexture ;
+: bind-2d-texture ( single-texture -- )
+    texture>> (bind-2d-texture) ;
+: (update-texture) ( image single-texture -- ) 
+    bind-2d-texture tex-sub-image ;
+! works only for single-texture
+: update-texture ( image-gadget -- )
+    [ image>> ] [ texture>> ] bi
+    (update-texture) ;
+GENERIC: texture-size ( texture -- dim )
+M: single-texture texture-size dim>> ;
+
+:: grid-width ( grid element-quot -- width )
+    grid [ 0 ] [
+        first element-quot [ + ] map-reduce
+    ] if-empty ; inline
+: grid-dim ( grid -- dim )
+    [ [ dim>> first ] grid-width ] [ flip [ dim>> second ] grid-width ] bi 2array ;
+M: multi-texture texture-size 
+    grid>> grid-dim ;
+: same-size? ( image-gadget -- ? )
+    [ texture>> texture-size ] [ image>> dim>> ] bi = ;
+: (texture-format) ( texture-id -- format )
+    (bind-2d-texture) GL_TEXTURE_2D 0
+    GL_TEXTURE_INTERNAL_FORMAT get-texture-int ;
+! works only for single-texture
+: texture-format ( image-gadget -- format/f )
+    texture>> [
+        texture>> [
+            (texture-format)
+        ] [ f ] if*
+    ] [ f ] if* ;
+: same-internal-format? ( image-gadget -- ? ) 
+   [ texture-format ] [ image>> image-format 2drop ] bi = ;
+
+! TODO: also keep multitextures if possible ?
+: keep-same-texture? ( image-gadget -- ? )
+    { [ texture>> single-texture? ]
+      [ same-size? ]
+      [ same-internal-format? ] } 1&& ;
+: ?update-texture ( image-gadget -- )
+    dup image-updated?>> [
+        f >>image-updated?
+        dup keep-same-texture? [ update-texture ] [ delete-current-texture ] if
+    ] [ drop ] if ;
 
 M: image-control model-changed
-    swap value>> >>image relayout ;
+    swap value>> >>image t >>image-updated? relayout ;
-
+M: image-control draw-gadget* [ ?update-texture ] [ call-next-method ] bi ;
-! Todo: delete texture on ungraft
+PRIVATE>
-
+GENERIC: set-image ( gadget object -- gadget )
-GENERIC: <image-gadget> ( object -- gadget )
+M: image set-image >>image ;
-
+M: string set-image load-image >>image ;
-M: image <image-gadget>
+M: pathname set-image string>> load-image >>image ;
-    \ image-gadget new
+M: model set-image [ value>> >>image drop ] [ >>model ] 2bi ;
-        swap >>image ;
+: new-image-gadget ( class -- gadget ) new ;
-
+: new-image-gadget* ( object class -- gadget ) 
-M: string <image-gadget> load-image <image-gadget> ;
+    new-image-gadget swap set-image ;
-
+: <image-gadget> ( object -- gadget )
-M: pathname <image-gadget> string>> load-image <image-gadget> ;
+    \ image-gadget new-image-gadget* ;
-
+: <image-control> ( model -- gadget )
+    \ image-control new-image-gadget* ;
 : image-window ( object -- ) <image-gadget> "Image" open-window ;
 
+! move these words to ui.gadgets because they affect all controls ?
+: stop-control ( gadget -- ) dup model>> [ remove-connection ] [ drop ] if* ;
+: start-control ( gadget -- ) dup model>> [ add-connection ] [ drop ] if* ;
+
 : image. ( object -- ) <image-gadget> gadget. ;
+
+<PRIVATE
+M: image-control graft* start-control ;
+M: image-control ungraft* [ stop-control ] [ call-next-method ] bi ;
+PRIVATE>