104 lines
2.9 KiB
Factor
104 lines
2.9 KiB
Factor
|
! Copyright (C) 2005 Slava Pestov.
|
||
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
||
|
|
IN: gadgets-mindmap
|
||
|
|
USING: gadgets gadgets-buttons gadgets-labels gadgets-layouts
|
||
|
|
generic kernel math sequences styles ;
|
||
|
|
|
||
|
|
! Mind-map tree-view gadget, like http://freemind.sf.net.
|
||
|
|
|
||
|
|
! Mind-map node protocol
|
||
|
|
GENERIC: node-gadget ( node -- gadget )
|
||
|
|
GENERIC: node-left ( node -- seq )
|
||
|
|
GENERIC: node-right ( node -- seq )
|
||
|
|
|
||
|
|
TUPLE: mindmap left node gadget right expanded? left? right? ;
|
||
|
|
|
||
|
|
: add-mindmap-node ( mindmap -- )
|
||
|
|
dup mindmap-node node-gadget swap
|
||
|
|
2dup add-gadget set-mindmap-gadget ;
|
||
|
|
|
||
|
|
: collapse-mindmap ( mindmap -- )
|
||
|
|
f over set-mindmap-expanded?
|
||
|
|
f over set-mindmap-left
|
||
|
|
f over set-mindmap-right
|
||
|
|
dup clear-gadget
|
||
|
|
add-mindmap-node ;
|
||
|
|
|
||
|
|
: mindmap-child ( left? right? obj -- gadget )
|
||
|
|
dup [ gadget? ] is? [ 2nip ] [ <mindmap> ] ifte ;
|
||
|
|
|
||
|
|
: mindmap-children ( seq left? right? -- gadget )
|
||
|
|
rot [ >r 2dup r> mindmap-child ] map 2nip
|
||
|
|
<pile> { 0 5 0 } over set-pack-gap [ add-gadgets ] keep ;
|
||
|
|
|
||
|
|
: (expand-left) ( node -- gadget )
|
||
|
|
mindmap-node node-left t f mindmap-children
|
||
|
|
1 over set-pack-align ;
|
||
|
|
|
||
|
|
: (expand-right) ( node -- gadget )
|
||
|
|
mindmap-node node-right f t mindmap-children
|
||
|
|
0 over set-pack-align ;
|
||
|
|
|
||
|
|
: add-nonempty ( child gadget -- )
|
||
|
|
over gadget-children empty? [ 2drop ] [ add-gadget ] ifte ;
|
||
|
|
|
||
|
|
: if-left ( mindmap quot -- | quot: mindmap -- )
|
||
|
|
>r dup mindmap-left? r> [ drop ] ifte ; inline
|
||
|
|
|
||
|
|
: expand-left ( mindmap -- )
|
||
|
|
[
|
||
|
|
dup (expand-left) swap 2dup
|
||
|
|
add-nonempty set-mindmap-left
|
||
|
|
] if-left ;
|
||
|
|
|
||
|
|
: if-right ( mindmap quot -- | quot: mindmap -- )
|
||
|
|
>r dup mindmap-right? r> [ drop ] ifte ; inline
|
||
|
|
|
||
|
|
: expand-right ( mindmap -- )
|
||
|
|
[
|
||
|
|
dup (expand-right) swap 2dup
|
||
|
|
add-nonempty set-mindmap-right
|
||
|
|
] if-right ;
|
||
|
|
|
||
|
|
: expand-mindmap ( mindmap -- )
|
||
|
|
t over set-mindmap-expanded?
|
||
|
|
dup clear-gadget
|
||
|
|
dup expand-left
|
||
|
|
dup add-mindmap-node
|
||
|
|
expand-right ;
|
||
|
|
|
||
|
|
: toggle-expanded ( mindmap -- )
|
||
|
|
dup mindmap-expanded?
|
||
|
|
[ collapse-mindmap ] [ expand-mindmap ] ifte ;
|
||
|
|
|
||
|
|
C: mindmap ( left? right? node -- gadget )
|
||
|
|
<shelf> over set-delegate
|
||
|
|
1/2 over set-pack-align
|
||
|
|
{ 50 0 0 } over set-pack-gap
|
||
|
|
[ set-mindmap-node ] keep
|
||
|
|
[ set-mindmap-right? ] keep
|
||
|
|
[ set-mindmap-left? ] keep
|
||
|
|
dup collapse-mindmap ;
|
||
|
|
|
||
|
|
: draw-arrows ( mindmap child point -- )
|
||
|
|
tuck >r >r >r mindmap-gadget r> { 1 1 1 } swap v-
|
||
|
|
gadget-point r> gadget-children r> swap
|
||
|
|
[ swap gadget-point ] map-with gray draw-fanout ;
|
||
|
|
|
||
|
|
: draw-left-arrows ( mindmap -- )
|
||
|
|
[ dup mindmap-left { 1 1/2 1/2 } draw-arrows ] if-left ;
|
||
|
|
|
||
|
|
: draw-right-arrows ( mindmap -- )
|
||
|
|
[ dup mindmap-right { 0 1/2 1/2 } draw-arrows ] if-right ;
|
||
|
|
|
||
|
|
M: mindmap draw-gadget* ( mindmap -- )
|
||
|
|
dup delegate draw-gadget*
|
||
|
|
dup mindmap-expanded? [
|
||
|
|
dup draw-left-arrows dup draw-right-arrows
|
||
|
|
] when drop ;
|
||
|
|
|
||
|
|
: find-mindmap [ mindmap? ] find-parent ;
|
||
|
|
|
||
|
|
: <expand-button> ( label -- gadget )
|
||
|
|
<label> [ find-mindmap toggle-expanded ] <roll-button> ;
|