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 math
   5 models opengl.gl opengl.textures opengl.textures.private
   6 sequences strings ui ui.gadgets ui.gadgets.panes
   7 ui.gadgets.worlds ui.render ;
   8 IN: images.viewer
   9
  10 TUPLE: image-gadget < gadget image texture ;
  11 <PRIVATE
  12 M: image-gadget pref-dim* image>> [ image-dim ] [ { 640 480 } ] if* ;
  13
  14 : (image-gadget-texture) ( gadget -- texture )
  15     dup image>> { 0 0 } <texture> >>texture texture>> ;
  16 : image-gadget-texture ( gadget -- texture )
  17     dup texture>> [ ] [ (image-gadget-texture) ] ?if ;
  18
  19 M: image-gadget draw-gadget* ( gadget -- )
  20     dup image>> [
  21         [ dim>> ] [ image-gadget-texture ] bi draw-scaled-texture
  22     ] [
  23         drop
  24     ] if ;
  25
  26 : delete-current-texture ( image-gadget -- )
  27     [ texture>> [ dispose ] when* ]
  28     [ f >>texture drop ] bi ;
  29
  30 ! In unit tests, find-gl-context throws no-world-found when using with-grafted-gadget.
  31 M: image-gadget ungraft* [ dup find-gl-context delete-current-texture ] [ 2drop ] recover ;
  32 PRIVATE>
  33 TUPLE: image-control < image-gadget image-updated? ;
  34 <PRIVATE
  35
  36 : (bind-2d-texture) ( texture-id -- )
  37     [ GL_TEXTURE_2D ] dip glBindTexture ;
  38 : bind-2d-texture ( single-texture -- )
  39     texture>> (bind-2d-texture) ;
  40 : (update-texture) ( image single-texture -- )
  41     bind-2d-texture tex-sub-image ;
  42 ! works only for single-texture
  43 : update-texture ( image-gadget -- )
  44     [ image>> ] [ texture>> ] bi
  45     (update-texture) ;
  46 GENERIC: texture-size ( texture -- dim )
  47 M: single-texture texture-size dim>> ;
  48
  49 :: grid-width ( grid element-quot -- width )
  50     grid [ 0 ] [
  51         first element-quot [ + ] map-reduce
  52     ] if-empty ; inline
  53 : grid-dim ( grid -- dim )
  54     [ [ dim>> first ] grid-width ] [ flip [ dim>> second ] grid-width ] bi 2array ;
  55 M: multi-texture texture-size
  56     grid>> grid-dim ;
  57 : same-size? ( image-gadget -- ? )
  58     [ texture>> texture-size ] [ image>> dim>> ] bi = ;
  59 : (texture-format) ( texture-id -- format )
  60     (bind-2d-texture) GL_TEXTURE_2D 0
  61     GL_TEXTURE_INTERNAL_FORMAT get-texture-int ;
  62 ! works only for single-texture
  63 : texture-format ( image-gadget -- format/f )
  64     texture>> [
  65         texture>> [
  66             (texture-format)
  67         ] [ f ] if*
  68     ] [ f ] if* ;
  69 : same-internal-format? ( image-gadget -- ? )
  70    [ texture-format ] [ image>> image-format 2drop ] bi = ;
  71
  72 ! TODO: also keep multitextures if possible ?
  73 : keep-same-texture? ( image-gadget -- ? )
  74     { [ texture>> single-texture? ]
  75       [ same-size? ]
  76       [ same-internal-format? ] } 1&& ;
  77 : ?update-texture ( image-gadget -- )
  78     dup image-updated?>> [
  79         f >>image-updated?
  80         dup keep-same-texture? [ update-texture ] [ delete-current-texture ] if
  81     ] [ drop ] if ;
  82
  83 M: image-control model-changed
  84     swap value>> >>image t >>image-updated? relayout ;
  85 M: image-control draw-gadget* [ ?update-texture ] [ call-next-method ] bi ;
  86 PRIVATE>
  87 GENERIC: set-image ( gadget object -- gadget )
  88 M: image set-image >>image ;
  89 M: string set-image load-image >>image ;
  90 M: pathname set-image string>> load-image >>image ;
  91 M: model set-image [ value>> >>image drop ] [ >>model ] 2bi ;
  92 : new-image-gadget ( class -- gadget ) new ;
  93 : new-image-gadget* ( object class -- gadget )
  94     new-image-gadget swap set-image ;
  95 : <image-gadget> ( object -- gadget )
  96     \ image-gadget new-image-gadget* ;
  97 : <image-control> ( model -- gadget )
  98     \ image-control new-image-gadget* ;
  99 : image-window ( object -- ) <image-gadget> "Image" open-window ;
 100
 101 : image. ( object -- ) <image-gadget> gadget. ;
 102
 103 M: image content-gadget
 104     <image-gadget> ;