basis/ui/gadgets/glass/glass.factor

   1 ! Copyright (C) 2005, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel namespaces ui.gadgets ui.gadgets.worlds
   4 ui.gadgets.wrappers ui.gestures math.rectangles
   5 math.rectangles.positioning combinators vectors ;
   6 IN: ui.gadgets.glass
   7
   8 GENERIC: hide-glass-hook ( gadget -- )
   9
  10 M: gadget hide-glass-hook drop ;
  11
  12 <PRIVATE
  13
  14 TUPLE: glass < gadget visible-rect owner ;
  15
  16 : <glass> ( owner child visible-rect -- glass )
  17     glass new
  18         swap >>visible-rect
  19         swap add-gadget
  20         swap >>owner ;
  21
  22 : visible-rect ( glass -- rect )
  23     [ visible-rect>> ] [ owner>> ] bi screen-loc offset-rect ;
  24
  25 M: glass layout*
  26     [
  27         [ visible-rect ]
  28         [ gadget-child pref-dim ]
  29         [ find-world dim>> ]
  30         tri popup-rect
  31     ] [ gadget-child ] bi set-rect-bounds ;
  32
  33 M: glass ungraft* gadget-child hide-glass-hook ;
  34
  35 : add-glass ( glass world -- )
  36     [ swap add-gadget drop ] [ [ ?push ] change-layers drop ] 2bi ;
  37
  38 PRIVATE>
  39
  40 : hide-glass ( child -- )
  41     [ glass? ] find-parent
  42     [ dup find-world [ unparent ] dip request-focus ]
  43     when* ;
  44
  45 : show-glass ( owner child visible-rect -- )
  46     <glass>
  47     dup gadget-child hand-clicked set
  48     dup owner>> find-world add-glass ;
  49
  50 \ glass H{
  51     { T{ button-down } [ hide-glass ] }
  52     { T{ drag } [ update-clicked drop ] }
  53 } set-gestures
  54
  55 SLOT: popup
  56
  57 <PRIVATE
  58
  59 TUPLE: popup < wrapper owner ;
  60
  61 : <popup> ( owner gadget -- popup )
  62     popup new-wrapper
  63         swap >>owner ; inline
  64
  65 M: popup hide-glass-hook
  66     owner>> f >>popup request-focus ;
  67
  68 PRIVATE>
  69
  70 popup H{
  71     { T{ key-down f f "ESC" } [ hide-glass ] }
  72 } set-gestures
  73
  74 : pass-to-popup ( gesture interactor -- ? )
  75     popup>> focusable-child resend-gesture ;
  76
  77 : show-popup ( owner popup visible-rect -- )
  78     [ <popup> ] dip
  79     [ drop dup owner>> (>>popup) ]
  80     [ [ [ owner>> ] keep ] dip show-glass ]
  81     2bi ;