extra/images/viewer/viewer.factor

   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 ;
   9 IN: images.viewer
  10
  11 TUPLE: image-gadget < gadget image texture ;
  12 <PRIVATE
  13 M: image-gadget pref-dim* image>> [ image-dim ] [ { 640 480 } ] if* ;
  14
  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 ;
  19
  20 M: image-gadget draw-gadget* ( gadget -- )
  21     dup image>> [
  22         [ dim>> ] [ image-gadget-texture ] bi draw-scaled-texture
  23     ] [
  24         drop
  25     ] if ;
  26
  27 : delete-current-texture ( image-gadget -- )
  28     [ texture>> [ dispose ] when* ]
  29     [ f >>texture drop ] bi ;
  30
  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 ;
  33 PRIVATE>
  34 TUPLE: image-control < image-gadget image-updated? ;
  35 <PRIVATE
  36
  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
  46     (update-texture) ;
  47 GENERIC: texture-size ( texture -- dim )
  48 M: single-texture texture-size dim>> ;
  49
  50 :: grid-width ( grid element-quot -- width )
  51     grid [ 0 ] [
  52         first element-quot [ + ] map-reduce
  53     ] if-empty ; inline
  54 : grid-dim ( grid -- dim )
  55     [ [ dim>> first ] grid-width ] [ flip [ dim>> second ] grid-width ] bi 2array ;
  56 M: multi-texture texture-size
  57     grid>> grid-dim ;
  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 )
  65     texture>> [
  66         texture>> [
  67             (texture-format)
  68         ] [ f ] if*
  69     ] [ f ] if* ;
  70 : same-internal-format? ( image-gadget -- ? )
  71    [ texture-format ] [ image>> image-format 2drop ] bi = ;
  72
  73 ! TODO: also keep multitextures if possible ?
  74 : keep-same-texture? ( image-gadget -- ? )
  75     { [ texture>> single-texture? ]
  76       [ same-size? ]
  77       [ same-internal-format? ] } 1&& ;
  78 : ?update-texture ( image-gadget -- )
  79     dup image-updated?>> [
  80         f >>image-updated?
  81         dup keep-same-texture? [ update-texture ] [ delete-current-texture ] if
  82     ] [ drop ] if ;
  83
  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 ;
  87 PRIVATE>
  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 ;
 101
 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* ;
 105
 106 : image. ( object -- ) <image-gadget> gadget. ;
 107
 108 <PRIVATE
 109 M: image-control graft* start-control ;
 110 M: image-control ungraft* [ stop-control ] [ call-next-method ] bi ;
 111 PRIVATE>
 112
 113 M: image content-gadget
 114     <image-gadget> ;