From badbb3fbfdf844b9335e105f4ecef403c6465577 Mon Sep 17 00:00:00 2001 From: Jon Harper Date: Sat, 15 May 2010 20:35:04 +0200 Subject: [PATCH] fix images.viewer + documentation --- extra/images/viewer/viewer-docs.factor | 99 ++++++++++++++++++++++++ extra/images/viewer/viewer.factor | 102 ++++++++++++++++++++----- 2 files changed, 181 insertions(+), 20 deletions(-) create mode 100644 extra/images/viewer/viewer-docs.factor diff --git a/extra/images/viewer/viewer-docs.factor b/extra/images/viewer/viewer-docs.factor new file mode 100644 index 0000000000..78a8f4626d --- /dev/null +++ b/extra/images/viewer/viewer-docs.factor @@ -0,0 +1,99 @@ +! 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 +"Utility words for displaying images :" +{ $subsections +image. image-window } + +; +ABOUT: "images.viewer" diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor index c62293bbe7..ebdf1ed218 100644 --- a/extra/images/viewer/viewer.factor +++ b/extra/images/viewer/viewer.factor @@ -3,15 +3,19 @@ USING: accessors images images.loader io.pathnames kernel models namespaces opengl opengl.gl opengl.textures sequences strings ui ui.gadgets ui.gadgets.panes ui.images ui.render -constructors ; +constructors locals combinators.short-circuit +literals ; +FROM: gpu.textures.private => get-texture-int ; IN: images.viewer TUPLE: image-gadget < gadget image texture ; - +> 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,85 @@ M: image-gadget draw-gadget* ( gadget -- ) drop ] if ; -TUPLE: image-control < image-gadget ; +: delete-current-texture ( image-gadget -- ) + [ texture>> [ texture>> [ delete-texture ] when* ] when* ] + [ f >>texture drop ] bi ; -CONSTRUCTOR: image-control ( model -- image-control ) ; +M: image-gadget ungraft* delete-current-texture ; +PRIVATE> +TUPLE: image-control < image-gadget image-updated? ; +> (bind-2d-texture) ; +: (update-texture) ( image texture -- ) + bind-2d-texture + [ GL_TEXTURE_2D 0 0 0 ] dip + [ 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 ) + (bind-2d-texture) GL_TEXTURE_2D 0 + ${ GL_TEXTURE_WIDTH GL_TEXTURE_HEIGHT } [ get-texture-int ] with with map ; +: texture-size ( image-gadget -- size/f ) + texture>> [ + texture>> [ + (texture-size) + ] [ { 0 0 } ] if* + ] [ f ] if* ; +: same-size? ( image-gadget -- ? ) + [ texture-size ] [ image>> dim>> ] bi = ; +: (texture-format) ( texture-id -- format ) + (bind-2d-texture) GL_TEXTURE_2D 0 + GL_TEXTURE_INTERNAL_FORMAT get-texture-int ; +: 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 = ; +: keep-same-texture? ( image-gadget -- ? ) + { [ 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 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. ; + +