1 ! Copyright (C) 2007, 2009 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays combinators.short-circuit continuations
4 destructors images images.loader io.pathnames kernel locals
5 math models opengl.gl opengl.textures opengl.textures.private
6 sequences strings ui ui.gadgets ui.gadgets.panes
7 ui.gadgets.worlds ui.render ;
8 FROM: images => image-dim ;
11 TUPLE: image-gadget < gadget image texture ;
13 M: image-gadget pref-dim* image>> [ image-dim ] [ { 640 480 } ] if* ;
15 : (image-gadget-texture) ( gadget -- texture )
16 dup image>> { 0 0 } <texture> >>texture texture>> ;
17 : image-gadget-texture ( gadget -- texture )
18 dup texture>> [ ] [ (image-gadget-texture) ] ?if ;
20 M: image-gadget draw-gadget* ( gadget -- )
22 [ dim>> ] [ image-gadget-texture ] bi draw-scaled-texture
27 : delete-current-texture ( image-gadget -- )
28 [ texture>> [ dispose ] when* ]
29 [ f >>texture drop ] bi ;
31 ! In unit tests, find-gl-context throws no-world-found when using with-grafted-gadget.
32 M: image-gadget ungraft* [ dup find-gl-context delete-current-texture ] [ 2drop ] recover ;
34 TUPLE: image-control < image-gadget image-updated? ;
37 : (bind-2d-texture) ( texture-id -- )
38 [ GL_TEXTURE_2D ] dip glBindTexture ;
39 : bind-2d-texture ( single-texture -- )
40 texture>> (bind-2d-texture) ;
41 : (update-texture) ( image single-texture -- )
42 bind-2d-texture tex-sub-image ;
43 ! works only for single-texture
44 : update-texture ( image-gadget -- )
45 [ image>> ] [ texture>> ] bi
47 GENERIC: texture-size ( texture -- dim )
48 M: single-texture texture-size dim>> ;
50 :: grid-width ( grid element-quot -- width )
52 first element-quot [ + ] map-reduce
54 : grid-dim ( grid -- dim )
55 [ [ dim>> first ] grid-width ] [ flip [ dim>> second ] grid-width ] bi 2array ;
56 M: multi-texture texture-size
58 : same-size? ( image-gadget -- ? )
59 [ texture>> texture-size ] [ image>> dim>> ] bi = ;
60 : (texture-format) ( texture-id -- format )
61 (bind-2d-texture) GL_TEXTURE_2D 0
62 GL_TEXTURE_INTERNAL_FORMAT get-texture-int ;
63 ! works only for single-texture
64 : texture-format ( image-gadget -- format/f )
70 : same-internal-format? ( image-gadget -- ? )
71 [ texture-format ] [ image>> image-format 2drop ] bi = ;
73 ! TODO: also keep multitextures if possible ?
74 : keep-same-texture? ( image-gadget -- ? )
75 { [ texture>> single-texture? ]
77 [ same-internal-format? ] } 1&& ;
78 : ?update-texture ( image-gadget -- )
79 dup image-updated?>> [
81 dup keep-same-texture? [ update-texture ] [ delete-current-texture ] if
84 M: image-control model-changed
85 swap value>> >>image t >>image-updated? relayout ;
86 M: image-control draw-gadget* [ ?update-texture ] [ call-next-method ] bi ;
88 GENERIC: set-image ( gadget object -- gadget )
89 M: image set-image >>image ;
90 M: string set-image load-image >>image ;
91 M: pathname set-image string>> load-image >>image ;
92 M: model set-image [ value>> >>image drop ] [ >>model ] 2bi ;
93 : new-image-gadget ( class -- gadget ) new ;
94 : new-image-gadget* ( object class -- gadget )
95 new-image-gadget swap set-image ;
96 : <image-gadget> ( object -- gadget )
97 \ image-gadget new-image-gadget* ;
98 : <image-control> ( model -- gadget )
99 \ image-control new-image-gadget* ;
100 : image-window ( object -- ) <image-gadget> "Image" open-window ;
102 ! move these words to ui.gadgets because they affect all controls ?
103 : stop-control ( gadget -- ) dup model>> [ remove-connection ] [ drop ] if* ;
104 : start-control ( gadget -- ) dup model>> [ add-connection ] [ drop ] if* ;
106 : image. ( object -- ) <image-gadget> gadget. ;
109 M: image-control graft* start-control ;
110 M: image-control ungraft* [ stop-control ] [ call-next-method ] bi ;
113 M: image content-gadget