basis/ui/gadgets/viewports/viewports.factor

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