53 lines
		
	
	
		
			1.6 KiB
		
	
	
	
		
			Factor
		
	
	
			
		
		
	
	
			53 lines
		
	
	
		
			1.6 KiB
		
	
	
	
		
			Factor
		
	
	
! Copyright (C) 2009 Slava Pestov.
 | 
						|
! See http://factorcode.org/license.txt for BSD license.
 | 
						|
USING: accessors arrays assocs colors.constants
 | 
						|
definitions.icons fry help help.topics kernel math.rectangles
 | 
						|
models.arrow namespaces sequences tools.crossref ui.gadgets
 | 
						|
ui.gadgets.glass ui.gadgets.labeled ui.gadgets.search-tables
 | 
						|
ui.gadgets.tables ui.gadgets.wrappers ui.gestures ui.images
 | 
						|
ui.operations ui.pens.solid ;
 | 
						|
FROM: ui.gadgets.wrappers => wrapper ;
 | 
						|
IN: ui.tools.browser.popups
 | 
						|
 | 
						|
SINGLETON: link-renderer
 | 
						|
 | 
						|
M: link-renderer row-columns
 | 
						|
    drop first2 [ definition-icon <image-name> ] dip 2array ;
 | 
						|
 | 
						|
M: link-renderer row-value drop first ;
 | 
						|
 | 
						|
TUPLE: links-popup < wrapper ;
 | 
						|
 | 
						|
: <links-table> ( model quot -- table )
 | 
						|
    '[
 | 
						|
        @ sort-articles
 | 
						|
        [ dup article-title ] { } map>assoc
 | 
						|
    ] <arrow> link-renderer [ second ] <search-table>
 | 
						|
        [ invoke-primary-operation ] >>action
 | 
						|
        [ hide-glass ] >>hook
 | 
						|
        t >>selection-required?
 | 
						|
        10 >>min-rows
 | 
						|
        10 >>max-rows
 | 
						|
        30 >>min-cols
 | 
						|
        30 >>max-cols ;
 | 
						|
 | 
						|
: <links-popup> ( model quot title -- gadget )
 | 
						|
    [ <links-table> COLOR: white <solid> >>interior ] dip
 | 
						|
    <labeled-gadget> links-popup new-wrapper ;
 | 
						|
 | 
						|
links-popup H{
 | 
						|
    { T{ key-down f f "ESC" } [ hide-glass ] }
 | 
						|
} set-gestures
 | 
						|
 | 
						|
SLOT: model
 | 
						|
 | 
						|
: show-links-popup ( browser-gadget quot title -- )
 | 
						|
    [ dup model>> ] 2dip <links-popup>
 | 
						|
    [ hand-loc get-global point>rect show-glass ] [ request-focus ] bi ; inline
 | 
						|
 | 
						|
: com-show-outgoing-links ( browser-gadget -- )
 | 
						|
    [ uses ] "Outgoing links" show-links-popup ;
 | 
						|
 | 
						|
: com-show-incoming-links ( browser-gadget -- )
 | 
						|
    [ usage ] "Incoming links" show-links-popup ;
 |