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