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 FROM: ui.gadgets.wrappers => wrapper ;
   7 IN: ui.gadgets.glass
   8
   9 GENERIC: hide-glass-hook ( gadget -- )
  10
  11 M: gadget hide-glass-hook drop ;
  12
  13 <PRIVATE
  14
  15 TUPLE: glass < gadget visible-rect owner ;
  16
  17 : <glass> ( owner child visible-rect -- glass )
  18     glass new
  19         swap >>visible-rect
  20         swap add-gadget
  21         swap >>owner ;
  22
  23 : visible-rect ( glass -- rect )
  24     [ visible-rect>> ] [ owner>> ] bi screen-loc offset-rect ;
  25
  26 M: glass layout*
  27     [
  28         [ visible-rect ]
  29         [ gadget-child pref-dim ]
  30         [ find-world dim>> ]
  31         tri popup-rect
  32     ] [ gadget-child ] bi set-rect-bounds ;
  33
  34 M: glass ungraft* gadget-child hide-glass-hook ;
  35
  36 : add-glass ( glass world -- )
  37     [ swap add-gadget drop ] [ [ ?push ] change-layers drop ] 2bi ;
  38
  39 PRIVATE>
  40
  41 : hide-glass ( child -- )
  42     [ glass? ] find-parent
  43     [ dup find-world [ unparent ] dip request-focus ]
  44     when* ;
  45
  46 : show-glass ( owner child visible-rect -- )
  47     <glass>
  48     dup gadget-child hand-clicked set
  49     dup owner>> find-world add-glass ;
  50
  51 \ glass H{
  52     { T{ button-down } [ hide-glass ] }
  53     { T{ drag } [ update-clicked drop ] }
  54 } set-gestures
  55
  56 SLOT: popup
  57
  58 <PRIVATE
  59
  60 TUPLE: popup < wrapper owner ;
  61
  62 : <popup> ( owner gadget -- popup )
  63     popup new-wrapper
  64         swap >>owner ; inline
  65
  66 M: popup hide-glass-hook
  67     dup owner>> 2dup popup>> eq?
  68     [ f >>popup request-focus drop ] [ 2drop ] if ;
  69
  70 PRIVATE>
  71
  72 popup H{
  73     { T{ key-down f f "ESC" } [ hide-glass ] }
  74 } set-gestures
  75
  76 : pass-to-popup ( gesture owner -- ? )
  77     popup>> focusable-child resend-gesture ;
  78
  79 : show-popup ( owner popup visible-rect -- )
  80     [ [ dup dup popup>> [ hide-glass ] when* ] dip <popup> ] dip
  81     [ drop >>popup drop ] [ show-glass ] 3bi ;