fix exception for large images

extra/images/viewer/viewer-docs.factor

@@ -88,7 +88,11 @@ $nl
 " 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 } "." }
+" 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 :"

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,15 +1,16 @@
 ! 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 locals combinators.short-circuit 
-literals ;
+literals destructors ui.gadgets.worlds continuations ;
 IN: images.viewer
 
 TUPLE: image-gadget < gadget image texture ;
 <PRIVATE
-M: image-gadget pref-dim* image>> dim>> ;
+M: image-gadget pref-dim* image>> [ dim>> ] [ { 640 480 } ] if* ;
 
 : (image-gadget-texture) ( gadget -- texture )
     dup image>> { 0 0 } <texture> >>texture texture>> ;
@@ -24,42 +25,42 @@ M: image-gadget draw-gadget* ( gadget -- )
     ] if ;
 
 : delete-current-texture ( image-gadget -- )
-    [ texture>> [ texture>> [ delete-texture ] when* ] when* ]
+    [ texture>> [ dispose ] when* ]
     [ f >>texture drop ] bi ;
 
-M: image-gadget ungraft* delete-current-texture ;
+! 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
 
 : (bind-2d-texture) ( texture-id -- )
     [ GL_TEXTURE_2D ] dip glBindTexture ;
-: bind-2d-texture ( texture -- )
+: bind-2d-texture ( single-texture -- )
     texture>> (bind-2d-texture) ;
-: (update-texture) ( image texture -- ) 
+: (update-texture) ( image single-texture -- ) 
-    bind-2d-texture
+    bind-2d-texture tex-sub-image ;
-    [ GL_TEXTURE_2D 0 0 0 ] dip
+! works only for single-texture
-    [ dim>> first2 ]
-    [ [ component-order>> ] [ component-type>> ] bi image-data-format ]
-    [ bitmap>> ] tri
-    glTexSubImage2D ;
 : update-texture ( image-gadget -- )
     [ image>> ] [ texture>> ] bi
     (update-texture) ;
-: (texture-size) ( texture-id -- size )
+GENERIC: texture-size ( texture -- dim )
-    (bind-2d-texture) GL_TEXTURE_2D 0 
+M: single-texture texture-size dim>> ;
-    ${ GL_TEXTURE_WIDTH GL_TEXTURE_HEIGHT } [ get-texture-int ] with with map ;
+
-: texture-size ( image-gadget -- size/f )
+:: grid-width ( grid element-quot -- width )
-    texture>> [
+    grid [ 0 ] [
-        texture>> [
+        first element-quot [ + ] map-reduce
-            (texture-size)
+    ] if-empty ; inline
-        ] [ { 0 0 } ] if*
+: grid-dim ( grid -- dim )
-    ] [ f ] if* ;
+    [ [ dim>> first ] grid-width ] [ flip [ dim>> second ] grid-width ] bi 2array ;
+M: multi-texture texture-size 
+    grid>> grid-dim ;
 : same-size? ( image-gadget -- ? )
-    [ texture-size ] [ image>> dim>> ] bi = ;
+    [ 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>> [
@@ -68,15 +69,18 @@ TUPLE: image-control < image-gadget image-updated? ;
     ] [ 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 -- ? )
-    { [ same-size? ] [ same-internal-format? ] } 1&& ;
+    { [ 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 pref-dim* image>> [ dim>> ] [ { 640 480 } ] if* ;
 M: image-control model-changed
     swap value>> >>image t >>image-updated? relayout ;
 M: image-control draw-gadget* [ ?update-texture ] [ call-next-method ] bi ;