diff --git a/extra/images/viewer/viewer-docs.factor b/extra/images/viewer/viewer-docs.factor new file mode 100644 index 0000000000..1d24bef2e3 --- /dev/null +++ b/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: +{ $values + { "object" { $or pathname string image } } + { "gadget" image-gadget } +} +{ $description "Creates " { $instance image-gadget } " with the given image. See " { $link set-image } "." } ; +HELP: +{ $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 } +"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" diff --git a/extra/images/viewer/viewer-tests.factor b/extra/images/viewer/viewer-tests.factor new file mode 100644 index 0000000000..b59c673752 --- /dev/null +++ b/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) swap >>bitmap swap >>dim + RGB >>component-order ubyte-components >>component-type ; + +[ ] [ { 50 50 } gen-image "s" set ] unit-test +[ ] [ "s" get "ig" set ] unit-test +"ig" get [ + [ t ] [ "ig" get image-gadget-texture single-texture? ] unit-test +] with-grafted-gadget + +[ ] [ "s" get "m" set ] unit-test +[ ] [ { 150 150 } gen-image "s1" set ] unit-test +[ ] [ "m" get "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) diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor index c62293bbe7..33042f5dd0 100644 --- a/extra/images/viewer/viewer.factor +++ b/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 ; +> [ dim>> ] [ { 640 480 } ] if* ; -M: image-gadget pref-dim* image>> dim>> ; - +: (image-gadget-texture) ( gadget -- texture ) + dup image>> { 0 0 } >>texture texture>> ; : image-gadget-texture ( gadget -- texture ) - dup texture>> [ ] [ dup image>> { 0 0 } >>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? ; +> [ 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 ; - -! Todo: delete texture on ungraft - -GENERIC: ( object -- gadget ) - -M: image - \ image-gadget new - swap >>image ; - -M: string load-image ; - -M: pathname string>> load-image ; - + swap value>> >>image t >>image-updated? relayout ; +M: image-control draw-gadget* [ ?update-texture ] [ call-next-method ] bi ; +PRIVATE> +GENERIC: set-image ( gadget object -- gadget ) +M: image set-image >>image ; +M: string set-image load-image >>image ; +M: pathname set-image string>> load-image >>image ; +M: model set-image [ value>> >>image drop ] [ >>model ] 2bi ; +: new-image-gadget ( class -- gadget ) new ; +: new-image-gadget* ( object class -- gadget ) + new-image-gadget swap set-image ; +: ( object -- gadget ) + \ image-gadget new-image-gadget* ; +: ( model -- gadget ) + \ image-control new-image-gadget* ; : image-window ( object -- ) "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 -- ) gadget. ; + +