diff --git a/library/collections/slicing.factor b/library/collections/slicing.factor index bb83e45515..40fdc337af 100644 --- a/library/collections/slicing.factor +++ b/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 diff --git a/library/help/tutorial.factor b/library/help/tutorial.factor index 4f68495533..c3c4dab42f 100644 --- a/library/help/tutorial.factor +++ b/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 ; : ( text -- gadget ) @@ -7,7 +9,8 @@ sequences strings styles ; : ( -- 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 ) diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index 9e766b20b6..cc2b6b48ce 100644 --- a/library/syntax/prettyprint.factor +++ b/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 ; : pprinter get pprinter-stack push ; @@ -278,7 +280,12 @@ M: hashtable pprint* ( hashtable -- ) [ hash>alist \ {{ \ }} pprint-sequence ] check-recursion ; M: tuple pprint* ( tuple -- ) - [ \ << \ >> pprint-sequence ] check-recursion ; + [ + \ << pprint* + dup first pprint* + + \ >> 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. [ ] "pprint-before-hook" set-word-prop ; + { { POSTPONE: [ POSTPONE: ] } { POSTPONE: { POSTPONE: } } { POSTPONE: {{ POSTPONE: }} } { POSTPONE: [[ POSTPONE: ]] } { POSTPONE: [[ POSTPONE: ]] } - { POSTPONE: << POSTPONE: >> } } [ 2unseq define-close define-open ] each diff --git a/library/syntax/see.factor b/library/syntax/see.factor index fc1dbb645b..dc2f19a0c5 100644 --- a/library/syntax/see.factor +++ b/library/syntax/see.factor @@ -73,9 +73,7 @@ M: compound (see) block; newline ; M: generic (see) - 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? ; diff --git a/library/ui/layouts.factor b/library/ui/layouts.factor index e402a7c1dc..596e81c648 100644 --- a/library/ui/layouts.factor +++ b/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 ) - { 0 0 0 } [ v+ ] accumulate ; +: packed-loc-1 ( gadget sizes -- seq ) + { 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. - [ swap set-delegate ] keep + #! align: 0 left, 1/2 center, 1 right. [ set-pack-vector ] keep - [ set-pack-fill ] keep - 0 over set-pack-align ; + over set-delegate + 0 over set-pack-align + 0 over set-pack-fill + { 0 0 0 } over set-pack-gap ; : ( -- pack ) { 0 1 0 } ; @@ -59,9 +61,11 @@ C: pack ( fill vector -- pack ) M: pack pref-dim ( pack -- dim ) [ - pref-dims - [ { 0 0 0 } [ vmax ] reduce ] keep - { 0 0 0 } [ v+ ] reduce + [ + pref-dims + [ { 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 ; diff --git a/library/ui/load.factor b/library/ui/load.factor index 1bd46c6d5a..3eae74475c 100644 --- a/library/ui/load.factor +++ b/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" ] [ diff --git a/library/ui/mindmap.factor b/library/ui/mindmap.factor new file mode 100644 index 0000000000..71eabe2a2b --- /dev/null +++ b/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 ] [ ] ifte ; + +: mindmap-children ( seq left? right? -- gadget ) + rot [ >r 2dup r> mindmap-child ] map 2nip + { 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 ) + 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 ; + +: ( label -- gadget ) +