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.worlds
8 ui.gadgets.wrappers ui.gestures ui.theme ui.tools.browser.popups
10 FROM: ui.gadgets.wrappers => wrapper ;
11 IN: ui.tools.button-list
13 TUPLE: button-list-popup < wrapper ;
16 INSTANCE: button clickable
18 SYMBOL: active-buttons
19 active-buttons [ H{ } ] initialize
21 : label-from-button ( button -- str/f )
22 children>> [ label? ] find swap [ text>> ] [ drop f ] if ;
24 : world-buttons ( -- assoc )
25 world get active-buttons get [ drop H{ } clone ] cache ;
27 : store-labelled-button ( button -- str/f )
28 dup label-from-button [ [ world-buttons set-at ] keep ] [ drop f ] if* ;
30 : remove-labelled-button ( button -- str/f )
31 label-from-button [ dup world-buttons delete-at ] [ f ] if* ;
34 [ store-labelled-button drop ] [ call-next-method ] bi ;
37 [ remove-labelled-button drop ] [ call-next-method ] bi ;
39 : <active-buttons-table> ( model -- table )
40 [ keys [ ">" swap 2array ] map ] <arrow> trivial-renderer [ second ] <search-table>
42 [ second world-buttons at invoke-primary ] >>action
44 t >>selection-required?
52 : <active-buttons-popup> ( model title -- gadget )
53 [ <active-buttons-table> white-interior ] dip
54 popup-color <framed-labeled-gadget> button-list-popup new-wrapper ;
57 { T{ key-down f f "ESC" } [ hide-glass ] }
60 : show-active-buttons-popup ( tool -- )
61 world-buttons <model> "Active Buttons" <active-buttons-popup>
62 [ hand-loc get-global point>rect show-glass ] [ request-focus ] bi ; inline