basis/ui/gadgets/glass/glass.factor

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