working on presentation outliner to replace mindmap
Slava Pestov
parent
b6e1569ef5
commit
8af730f791
|
|
@ -74,8 +74,3 @@ M: gadget children-on ( rect/point gadget -- list )
|
|||
[ nip pick-up ] [ rot 2drop ] if
|
||||
] with-scope
|
||||
] [ 2drop f ] if ;
|
||||
|
||||
! Mind-map/outliner node protocol
|
||||
GENERIC: node-gadget ( node -- gadget )
|
||||
GENERIC: node-left ( node -- seq )
|
||||
GENERIC: node-right ( node -- seq )
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ C: display ( -- display )
|
|||
: present-stack ( seq title display -- )
|
||||
[ display-title set-label-text ] keep
|
||||
[ display-title relayout ] keep
|
||||
display-pane dup pane-clear [ stack. ] with-stream* ;
|
||||
display-pane [ stack. ] with-pane ;
|
||||
|
||||
: ui-listener-hook ( -- )
|
||||
datastack-hook get call datastack-display get present-stack
|
||||
|
|
|
|||
|
|
@ -25,7 +25,6 @@ USING: kernel parser sequences io ;
|
|||
"/library/ui/presentations.factor"
|
||||
"/library/ui/books.factor"
|
||||
"/library/ui/outliner.factor"
|
||||
"/library/ui/mindmap.factor"
|
||||
"/library/ui/listener.factor"
|
||||
"/library/ui/ui.factor"
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -1,101 +0,0 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: gadgets-mindmap
|
||||
USING: arrays gadgets gadgets-buttons gadgets-labels
|
||||
gadgets-layouts generic kernel math sequences styles ;
|
||||
|
||||
! Mind-map tree-view gadget, like http://freemind.sf.net.
|
||||
|
||||
TUPLE: mindmap left node gadget right expanded? left? right? ;
|
||||
|
||||
DEFER: <expand-button>
|
||||
|
||||
: add-mindmap-node ( mindmap -- )
|
||||
dup mindmap-node node-gadget <expand-button> 2array
|
||||
<shelf> [ add-gadgets ] keep 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> ] if ;
|
||||
|
||||
: 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 ] if ;
|
||||
|
||||
: if-left ( mindmap quot -- | quot: mindmap -- )
|
||||
>r dup mindmap-left? r> [ drop ] if ; 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 ] if ; 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-mindmap ( mindmap -- )
|
||||
dup mindmap-expanded?
|
||||
[ collapse-mindmap ] [ expand-mindmap ] if ;
|
||||
|
||||
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-mindmap ] <roll-button> ;
|
||||
|
|
@ -30,7 +30,8 @@ TUPLE: pane output active current input continuation scrolls? ;
|
|||
dup pane-continuation f rot set-pane-continuation ;
|
||||
|
||||
: pane-eval ( string pane -- )
|
||||
pop-continuation [ continue-with ] in-thread 2drop ;
|
||||
pop-continuation dup
|
||||
[ [ continue-with ] in-thread ] when 2drop ;
|
||||
|
||||
SYMBOL: structured-input
|
||||
|
||||
|
|
@ -133,3 +134,8 @@ M: pane stream-close ( pane -- ) drop ;
|
|||
#! Execute the quotation with output to an output-only pane.
|
||||
f f <pane> world-theme over set-gadget-paint
|
||||
[ swap with-stream ] keep ; inline
|
||||
|
||||
: with-pane ( pane quot -- )
|
||||
#! Clear the pane and run the quotation in a scope with
|
||||
#! stdio set to the pane.
|
||||
>r dup pane-clear r> with-stream* ; inline
|
||||
|
|
|
|||
|
|
@ -5,19 +5,6 @@ USING: gadgets-layouts gadgets-listener generic help io kernel
|
|||
listener lists math memory namespaces prettyprint sdl sequences
|
||||
shells styles threads words ;
|
||||
|
||||
: world-theme
|
||||
{{
|
||||
[[ background @{ 255 255 255 }@ ]]
|
||||
[[ rollover-bg @{ 236 230 232 }@ ]]
|
||||
[[ bevel-1 { 160 160 160 }@ ]]
|
||||
[[ bevel-2 @{ 232 232 232 }@ ]]
|
||||
[[ foreground @{ 0 0 0 }@ ]]
|
||||
[[ reverse-video f ]]
|
||||
[[ font "Monospaced" ]]
|
||||
[[ font-size 12 ]]
|
||||
[[ font-style plain ]]
|
||||
}} ;
|
||||
|
||||
: init-world
|
||||
ttf-init
|
||||
global [
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
IN: gadgets
|
||||
USING: alien arrays errors gadgets-layouts generic io kernel
|
||||
lists math memory namespaces prettyprint sdl sequences sequences
|
||||
strings threads ;
|
||||
strings styles threads ;
|
||||
|
||||
! The world gadget is the top level gadget that all (visible)
|
||||
! gadgets are contained in. The current world is stored in the
|
||||
|
|
@ -67,3 +67,16 @@ DEFER: handle-event
|
|||
|
||||
: start-world ( -- )
|
||||
world get t over set-world-running? relayout ;
|
||||
|
||||
: world-theme
|
||||
{{
|
||||
[[ background @{ 255 255 255 }@ ]]
|
||||
[[ rollover-bg @{ 236 230 232 }@ ]]
|
||||
[[ bevel-1 { 160 160 160 }@ ]]
|
||||
[[ bevel-2 @{ 232 232 232 }@ ]]
|
||||
[[ foreground @{ 0 0 0 }@ ]]
|
||||
[[ reverse-video f ]]
|
||||
[[ font "Monospaced" ]]
|
||||
[[ font-size 12 ]]
|
||||
[[ font-style plain ]]
|
||||
}} ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue