fix images.viewer + documentation
Jon Harper
parent
010b5069bd
commit
badbb3fbfd
|
|
@ -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: <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
|
||||
"Utility words for displaying images :"
|
||||
{ $subsections
|
||||
image. image-window }
|
||||
|
||||
;
|
||||
ABOUT: "images.viewer"
|
||||
|
|
@ -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 ;
|
||||
|
||||
<PRIVATE
|
||||
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,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? ;
|
||||
<PRIVATE
|
||||
|
||||
: (bind-2d-texture) ( texture-id -- )
|
||||
[ GL_TEXTURE_2D ] dip glBindTexture ;
|
||||
: bind-2d-texture ( texture -- )
|
||||
texture>> (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: <image-gadget> ( object -- gadget )
|
||||
|
||||
M: image <image-gadget>
|
||||
\ image-gadget new
|
||||
swap >>image ;
|
||||
|
||||
M: string <image-gadget> load-image <image-gadget> ;
|
||||
|
||||
M: pathname <image-gadget> string>> load-image <image-gadget> ;
|
||||
|
||||
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 ;
|
||||
: <image-gadget> ( object -- 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>
|
||||
|
|
|
|||
Loading…
Reference in New Issue