tuck (split1) >r , r> dup [ swap (split) ] [ 2drop ] ifte ;
: split ( seq subseq -- seq ) [ (split) ] [ ] make ; flushable
+
+: cut ( n seq -- ) [ head ] 2keep tail ; flushable
IN: help\r
-USING: gadgets generic kernel lists math matrices namespaces sdl\r
+USING: gadgets gadgets-books gadgets-borders gadgets-buttons\r
+gadgets-editors gadgets-labels gadgets-layouts gadgets-panes\r
+gadgets-presentations generic kernel lists math namespaces sdl\r
sequences strings styles ;\r
\r
: <slide-title> ( text -- gadget )\r
\r
: <underline> ( -- gadget )\r
<gadget>\r
- dup << gradient f { 1 0 0 } { 64 64 64 } { 255 255 255 } >> interior set-paint-prop\r
+ dup << gradient f { 1 0 0 } { 64 64 64 } { 255 255 255 } >>\r
+ interior set-paint-prop\r
{ 0 10 0 } over set-gadget-dim ;\r
\r
GENERIC: tutorial-line ( object -- gadget )\r
[ 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 ;
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 ;
[ 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? [
: .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
block; newline ;
M: generic (see)
- <block
- dup dup "combination" word-prop
- swap see-body block; newline
+ dup dup "combination" word-prop swap see-body newline
dup methods [ method. ] each-with ;
GENERIC: class. ( word -- )
#! 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? ;
drop
] ifte ;
-TUPLE: pack align fill vector ;
+TUPLE: pack align fill gap vector ;
: pref-dims ( gadget -- list )
gadget-children [ pref-dim ] map ;
: 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.
- [ <gadget> 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 ;
+ <gadget> over set-delegate
+ 0 over set-pack-align
+ 0 over set-pack-fill
+ { 0 0 0 } over set-pack-gap ;
: <pile> ( -- pack ) { 0 1 0 } <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 ;
"/library/ui/panes.factor"
"/library/ui/presentations.factor"
"/library/ui/books.factor"
+ "/library/ui/mindmap.factor"
"/library/ui/listener.factor"
"/library/ui/ui.factor"
] [
--- /dev/null
+! 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> ;
: <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 ;
! 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
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
- {{
- [[ 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
+ world-theme world get set-gadget-paint
<plain-gadget> add-layer