Mindmap gadget

library/collections/slicing.factor

@@ -91,3 +91,5 @@ M: object tail ( index seq -- seq ) [ tail-slice ] keep like ;
     tuck (split1) >r , r> dup [ swap (split) ] [ 2drop ] ifte ;
 
 : split ( seq subseq -- seq ) [ (split) ] [ ] make ; flushable
+
+: cut ( n seq -- ) [ head ] 2keep tail ; flushable

library/help/tutorial.factor

@@ -1,5 +1,7 @@
 IN: help
-USING: gadgets generic kernel lists math matrices namespaces sdl
+USING: gadgets gadgets-books gadgets-borders gadgets-buttons
+gadgets-editors gadgets-labels gadgets-layouts gadgets-panes
+gadgets-presentations generic kernel lists math namespaces sdl
 sequences strings styles ;
 
 : <slide-title> ( text -- gadget )
@@ -7,7 +9,8 @@ sequences strings styles ;
 
 : <underline> ( -- gadget )
     <gadget>
-    dup << gradient f { 1 0 0 } { 64 64 64 } { 255 255 255 } >> interior set-paint-prop
+    dup << gradient f { 1 0 0 } { 64 64 64 } { 255 255 255 } >>
+    interior set-paint-prop
     { 0 10 0 } over set-gadget-dim ;
 
 GENERIC: tutorial-line ( object -- gadget )

library/syntax/prettyprint.factor

@@ -70,7 +70,7 @@ C: text ( string style -- section )
     [ set-text-string ] keep ;
 
 M: text pprint-section*
-    dup text-string swap text-style format " " write ;
+    dup text-string swap text-style format ;
 
 TUPLE: block sections ;
 
@@ -118,7 +118,9 @@ M: newline pprint-section* ( newline -- )
     section-start fresh-line ;
 
 M: block pprint-section* ( block -- )
-    block-sections [ pprint-section ] each ;
+    f swap block-sections [
+        over [ " " write ] when pprint-section drop t
+    ] each drop ;
 
 : <block ( -- ) <block> pprinter get pprinter-stack push ;
 
@@ -278,7 +280,12 @@ M: hashtable pprint* ( hashtable -- )
     [ hash>alist \ {{ \ }} pprint-sequence ] check-recursion ;
 
 M: tuple pprint* ( tuple -- )
-    [ <mirror> \ << \ >> pprint-sequence ] check-recursion ;
+    [
+        \ << pprint*
+        <mirror> dup first pprint*
+        <block 1 swap tail-slice pprint-elements block>
+        \ >> pprint*
+    ] check-recursion ;
 
 M: alien pprint* ( alien -- )
     dup expired? [
@@ -331,21 +338,20 @@ M: wrapper pprint* ( wrapper -- )
 : .o >oct print ;
 : .h >hex print ;
 
-: define-close ( word -- )
-    #! The word will be pretty-printed as a block closer.
-    #! Examples are ] } }} ]] and so on.
-    [ block> ] "pprint-before-hook" set-word-prop ;
-
 : define-open
     #! The word will be pretty-printed as a block opener.
     #! Examples are [ { {{ << and so on.
     [ <block ] "pprint-after-hook" set-word-prop ;
 
+: define-close ( word -- )
+    #! The word will be pretty-printed as a block closer.
+    #! Examples are ] } }} ]] and so on.
+    [ block> ] "pprint-before-hook" set-word-prop ;
+
 {
     { POSTPONE: [ POSTPONE: ] }
     { POSTPONE: { POSTPONE: } }
     { POSTPONE: {{ POSTPONE: }} }
     { POSTPONE: [[ POSTPONE: ]] }
     { POSTPONE: [[ POSTPONE: ]] }
-    { POSTPONE: << POSTPONE: >> }
 } [ 2unseq define-close define-open ] each

library/syntax/see.factor

@@ -73,9 +73,7 @@ M: compound (see)
     block; newline ;
 
 M: generic (see)
-    <block
+    dup dup "combination" word-prop swap see-body newline
-    dup dup "combination" word-prop
-    swap see-body block; newline
     dup methods [ method. ] each-with ;
 
 GENERIC: class. ( word -- )

library/ui/hierarchy.factor

@@ -61,6 +61,12 @@ sequences vectors ;
     #! The position of the gadget on the screen.
     parents-up { 0 0 0 } [ rect-loc v+ ] reduce ;
 
+: gadget-point ( gadget vector -- point )
+    #! { 0 0 0 } - top left corner
+    #! { 1/2 1/2 0 } - middle
+    #! { 1 1 0 } - bottom right corner
+    >r dup screen-loc swap rect-dim r> v* v+ ;
+
 : relative ( g1 g2 -- g2-g1 ) screen-loc swap screen-loc v- ;
 
 : child? ( parent child -- ? ) parents-down memq? ;

library/ui/layouts.factor

@@ -17,7 +17,7 @@ matrices namespaces sdl sequences ;
         drop
     ] ifte ;
 
-TUPLE: pack align fill vector ;
+TUPLE: pack align fill gap vector ;
 
 : pref-dims ( gadget -- list )
     gadget-children [ pref-dim ] map ;
@@ -31,27 +31,29 @@ TUPLE: pack align fill vector ;
 : packed-dims ( gadget sizes -- seq )
     2dup packed-dim-2 swap orient ;
 
-: packed-loc-1 ( sizes -- seq )
+: packed-loc-1 ( gadget sizes -- seq )
-    { 0 0 0 } [ v+ ] accumulate ;
+    { 0 0 0 } [ v+ over pack-gap v+ ] accumulate nip ;
 
 : packed-loc-2 ( gadget sizes -- seq )
     [ >r dup pack-align swap rect-dim r> v- n*v ] map-with ;
 
 : packed-locs ( gadget sizes -- seq )
-    dup packed-loc-1 >r dupd packed-loc-2 r> orient ;
+    2dup packed-loc-1 >r dupd packed-loc-2 r> orient ;
 
 : packed-layout ( gadget sizes -- )
     over gadget-children
     >r dupd packed-dims r> 2dup [ set-gadget-dim ] 2each
     >r packed-locs r> [ set-rect-loc ] 2each ;
 
-C: pack ( fill vector -- pack )
+C: pack ( vector -- pack )
     #! gap: between each child.
     #! fill: 0 leaves default width, 1 fills to pack width.
-    [ <gadget> swap set-delegate ] keep
+    #! align: 0 left, 1/2 center, 1 right.
     [ set-pack-vector ] keep
-    [ set-pack-fill ] keep
+    <gadget> over set-delegate
-    0 over set-pack-align ;
+    0 over set-pack-align
+    0 over set-pack-fill
+    { 0 0 0 } over set-pack-gap ;
 
 : <pile> ( -- pack ) { 0 1 0 } <pack> ;
 
@@ -59,9 +61,11 @@ C: pack ( fill vector -- pack )
 
 M: pack pref-dim ( pack -- dim )
     [
-        pref-dims
+        [
-        [ { 0 0 0 } [ vmax ] reduce ] keep
+            pref-dims
-        { 0 0 0 } [ v+ ] reduce
+            [ { 0 0 0 } [ vmax ] reduce ] keep
+            [ { 0 0 0 } [ v+ ] reduce ] keep length 1 - 0 max
+        ] keep pack-gap n*v v+
     ] keep pack-vector set-axis ;
 
 M: pack layout* ( pack -- ) dup pref-dims packed-layout ;

library/ui/load.factor

@@ -24,6 +24,7 @@ USING: kernel parser sequences io ;
     "/library/ui/panes.factor"
     "/library/ui/presentations.factor"
     "/library/ui/books.factor"
+    "/library/ui/mindmap.factor"
     "/library/ui/listener.factor"
     "/library/ui/ui.factor"
 ] [

library/ui/mindmap.factor

@@ -0,0 +1,103 @@
+! 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> ;

library/ui/paint.factor

@@ -171,3 +171,9 @@ M: gadget draw-gadget* ( gadget -- )
 
 : <bevel-gadget> ( -- gadget )
     <plain-gadget> dup << bevel f 2 >> boundary set-paint-prop ;
+
+: draw-line ( from to color -- )
+    >r >r >r surface get r> 2unseq r> 2unseq r> rgb lineColor ;
+
+: draw-fanout ( from tos color -- )
+    -rot [ >r 2dup r> rot draw-line ] each 2drop ;

library/ui/panes.factor

@@ -1,13 +1,14 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
+IN: gadgets-presentations
+DEFER: <presentation>
+
 IN: gadgets-panes
 USING: gadgets gadgets-editors gadgets-labels gadgets-layouts
 gadgets-scrolling generic hashtables io kernel line-editor lists
 math namespaces prettyprint sequences strings styles threads
 vectors ;
 
-DEFER: <presentation>
-
 ! A pane is an area that can display text.
 
 ! output: pile

library/ui/ui.factor

@@ -5,22 +5,25 @@ USING: gadgets-listener generic help io kernel listener lists
 math 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
     global [
         <world> world set
         { 600 800 0 } world get set-gadget-dim
         
-        {{
+        world-theme world get set-gadget-paint
-            [[ 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 ]]
-        }} world get set-gadget-paint
 
         <plain-gadget> add-layer