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

db4
Joe Groff 2010-05-17 13:08:58 -07:00
commit d639baa319
3 changed files with 226 additions and 22 deletions

View File

@ -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"

View File

@ -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)

View File

@ -1,17 +1,21 @@
! Copyright (C) 2007, 2009 Doug Coleman. ! Copyright (C) 2007, 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors images images.loader io.pathnames kernel 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 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 IN: images.viewer
TUPLE: image-gadget < gadget image texture ; 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 ) : 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 -- ) M: image-gadget draw-gadget* ( gadget -- )
dup image>> [ dup image>> [
@ -20,27 +24,88 @@ M: image-gadget draw-gadget* ( gadget -- )
drop drop
] if ; ] 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 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 ; : 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. ; : image. ( object -- ) <image-gadget> gadget. ;
<PRIVATE
M: image-control graft* start-control ;
M: image-control ungraft* [ stop-control ] [ call-next-method ] bi ;
PRIVATE>