115 lines
4.0 KiB
Factor
115 lines
4.0 KiB
Factor
! Copyright (C) 2007, 2009 Doug Coleman.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: accessors arrays combinators.short-circuit continuations
|
|
destructors images images.loader io.pathnames kernel locals
|
|
math models opengl.gl opengl.textures opengl.textures.private
|
|
sequences strings ui ui.gadgets ui.gadgets.panes
|
|
ui.gadgets.worlds ui.render ;
|
|
FROM: images => image-dim ;
|
|
IN: images.viewer
|
|
|
|
TUPLE: image-gadget < gadget image texture ;
|
|
<PRIVATE
|
|
M: image-gadget pref-dim* image>> [ image-dim ] [ { 640 480 } ] if* ;
|
|
|
|
: (image-gadget-texture) ( gadget -- texture )
|
|
dup image>> { 0 0 } <texture> >>texture texture>> ;
|
|
: image-gadget-texture ( gadget -- texture )
|
|
dup texture>> [ ] [ (image-gadget-texture) ] ?if ;
|
|
|
|
M: image-gadget draw-gadget* ( gadget -- )
|
|
dup image>> [
|
|
[ dim>> ] [ image-gadget-texture ] bi draw-scaled-texture
|
|
] [
|
|
drop
|
|
] if ;
|
|
|
|
: delete-current-texture ( image-gadget -- )
|
|
[ texture>> [ dispose ] when* ]
|
|
[ f >>texture drop ] bi ;
|
|
|
|
! 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 ( 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 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>
|
|
|
|
M: image content-gadget
|
|
<image-gadget> ;
|