basis/ui/tools/button-list/button-list.factor

   1 ! Copyright (C) 2021 Kevin Cope.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 USING: accessors arrays assocs classes kernel linked-assocs
   5 math.rectangles models models.arrow namespaces sequences ui
   6 ui.gadgets ui.gadgets.buttons ui.gadgets.glass
   7 ui.gadgets.labeled ui.gadgets.presentations
   8 ui.gadgets.search-tables ui.gadgets.labels ui.gadgets.tables
   9 ui.gadgets.worlds ui.gadgets.wrappers ui.gestures ui.theme
  10 ui.tools.browser.popups ui.tools.common ;
  11
  12 FROM: ui.gadgets.wrappers => wrapper ;
  13 IN: ui.tools.button-list
  14
  15 TUPLE: button-list-popup < wrapper ;
  16
  17 MIXIN: clickable
  18 INSTANCE: button clickable
  19
  20 SYMBOL: active-buttons
  21 active-buttons [ H{ } ] initialize
  22
  23 : label-from-button ( button -- str/f )
  24     children>> [ label? ] find swap [ text>> ] [ drop f ] if ;
  25
  26 : world-buttons ( -- assoc )
  27     world get active-buttons get [ drop LH{ } clone ] cache ;
  28
  29 : store-labelled-button ( button -- str/f )
  30     dup label-from-button [ [ world-buttons set-at ] keep ] [ drop f ] if* ;
  31
  32 : remove-labelled-button ( button -- str/f )
  33     label-from-button [ dup world-buttons delete-at ] [ f ] if* ;
  34
  35 M: clickable graft*
  36     [ store-labelled-button drop ] [ call-next-method ] bi ;
  37
  38 M: clickable ungraft*
  39     [ remove-labelled-button drop ] [ call-next-method ] bi ;
  40
  41 : <active-buttons-table> ( model -- table )
  42     [ keys [ ">" swap 2array ] map ] <arrow> trivial-renderer [ second ] <search-table>
  43     dup table>>
  44         [
  45             second world-buttons at dup presentation?
  46             [ invoke-primary ] [ button-invoke ] if
  47         ] >>action
  48         [ hide-glass ] >>hook
  49         t >>selection-required?
  50         10 >>min-rows
  51         10 >>max-rows
  52         30 >>min-cols
  53         30 >>max-cols
  54     drop
  55     ;
  56
  57 : <active-buttons-popup> ( model title -- gadget )
  58     [ <active-buttons-table> white-interior ] dip
  59     popup-color <framed-labeled-gadget> button-list-popup new-wrapper ;
  60
  61 button-list-popup H{
  62     { T{ key-down f f "ESC" } [ hide-glass ] }
  63 } set-gestures
  64
  65 : show-active-buttons-popup ( tool -- )
  66     world-buttons <model> "Active Buttons" <active-buttons-popup>
  67     [ hand-loc get-global point>rect show-glass ] [ request-focus ] bi ; inline