basis/ui/tools/browser/popups/popups.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs definitions fry help.topics kernel
   4 colors.constants math.rectangles models.arrow namespaces sequences
   5 sorting definitions.icons ui.gadgets ui.gadgets.glass
   6 ui.gadgets.labeled ui.gadgets.scrollers ui.gadgets.tables
   7 ui.gadgets.search-tables ui.gadgets.wrappers ui.gestures ui.operations
   8 ui.pens.solid ui.images ;
   9 IN: ui.tools.browser.popups
  10
  11 SINGLETON: link-renderer
  12
  13 M: link-renderer row-columns
  14     drop first2 [ definition-icon <image-name> ] dip 2array ;
  15
  16 M: link-renderer row-value drop first ;
  17
  18 TUPLE: links-popup < wrapper ;
  19
  20 : sorted-links ( links -- alist )
  21     [ dup article-title ] { } map>assoc sort-values ;
  22
  23 : match? ( value str -- ? )
  24     swap second subseq? ;
  25
  26 : <links-table> ( model quot -- table )
  27     '[ @ sorted-links ] <arrow>
  28     link-renderer [ second ] <search-table>
  29         [ invoke-primary-operation ] >>action
  30         [ hide-glass ] >>hook
  31         t >>selection-required?
  32         10 >>min-rows
  33         10 >>max-rows
  34         30 >>min-cols
  35         30 >>max-cols ;
  36
  37 : <links-popup> ( model quot title -- gadget )
  38     [ <links-table> COLOR: white <solid> >>interior ] dip
  39     <labeled-gadget> links-popup new-wrapper ;
  40
  41 links-popup H{
  42     { T{ key-down f f "ESC" } [ hide-glass ] }
  43 } set-gestures
  44
  45 SLOT: model
  46
  47 : show-links-popup ( browser-gadget quot title -- )
  48     [ dup model>> ] 2dip <links-popup>
  49     [ hand-loc get { 0 0 } <rect> show-glass ] [ request-focus ] bi ;
  50
  51 : com-show-outgoing-links ( browser-gadget -- )
  52     [ uses ] "Outgoing links" show-links-popup ;
  53
  54 : com-show-incoming-links ( browser-gadget -- )
  55     [ usage ] "Incoming links" show-links-popup ;