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.geometry.rect ;
   6 IN: ui.gadgets.viewports
   7
   8 CONSTANT: viewport-gap { 3 3 }
   9 CONSTANT: scroller-border { 1 1 }
  10
  11 TUPLE: viewport < gadget ;
  12
  13 : find-viewport ( gadget -- viewport )
  14     [ viewport? ] find-parent ;
  15
  16 : viewport-padding ( -- padding )
  17     viewport-gap 2 v*n scroller-border v+ ;
  18
  19 : viewport-dim ( viewport -- dim )
  20     gadget-child pref-dim viewport-padding v+ ;
  21
  22 : <viewport> ( content model -- viewport )
  23     viewport new-gadget
  24         swap >>model
  25         t >>clipped?
  26         swap add-gadget ;
  27
  28 M: viewport layout*
  29     [ gadget-child ] [
  30         [ dim>> viewport-padding v- ]
  31         [ gadget-child pref-dim ]
  32         bi vmax
  33     ] bi >>dim drop ;
  34
  35 M: viewport focusable-child*
  36     gadget-child ;
  37
  38 M: viewport pref-dim* viewport-dim ;
  39
  40 : scroller-value ( scroller -- loc )
  41     model>> range-value [ >fixnum ] map ;
  42
  43 M: viewport model-changed
  44     nip
  45     [ relayout-1 ]
  46     [
  47         [ gadget-child ]
  48         [
  49             scroller-value vneg
  50             viewport-gap v+
  51             scroller-border v+
  52         ] bi
  53         >>loc drop
  54     ] bi ;
  55
  56 : visible-dim ( gadget -- dim )
  57     dup parent>> viewport?
  58     [ parent>> rect-dim viewport-gap 2 v*n v- ] [ dim>> ] if ;