basis/ui/gadgets/viewports/viewports.factor

   1 ! Copyright (C) 2005, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays ui.gadgets ui.gadgets.borders
   4 kernel math namespaces sequences models math.vectors
   5 math.rectangles ;
   6 IN: ui.gadgets.viewports
   7
   8 TUPLE: viewport < gadget { constraint initial: { 1 1 } } ;
   9
  10 : find-viewport ( gadget -- viewport )
  11     [ viewport? ] find-parent ;
  12
  13 : <viewport> ( content model -- viewport )
  14     viewport new
  15         swap >>model
  16         t >>clipped?
  17         swap add-gadget ;
  18
  19 M: viewport layout*
  20     [ gadget-child ]
  21     [ [ dim>> ] [ gadget-child pref-dim ] bi vmax ] bi >>dim drop ;
  22
  23 M: viewport focusable-child*
  24     gadget-child ;
  25
  26 : scroller-value ( scroller -- loc )
  27     model>> range-value [ >integer ] map ;
  28
  29 M: viewport model-changed
  30     nip
  31     [ relayout-1 ]
  32     [
  33         [ gadget-child ]
  34         [ scroller-value vneg ]
  35         [ constraint>> ]
  36         tri v* >>loc drop
  37     ] bi ;
  38
  39 : visible-dim ( gadget -- dim )
  40     dup parent>> viewport? [ parent>> ] when dim>> ;