Merge git://repo.or.cz/factor/jcg
Joe Groff
commit
ec593ad4c2
|
|
@ -3,7 +3,8 @@
|
|||
USING: kernel math math.functions math.parser models
|
||||
models.filter models.range models.compose sequences ui
|
||||
ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs
|
||||
ui.gadgets.sliders ui.render math.geometry.rect accessors ;
|
||||
ui.gadgets.sliders ui.render math.geometry.rect accessors
|
||||
ui.gadgets.grids ;
|
||||
IN: color-picker
|
||||
|
||||
! Simple example demonstrating the use of models.
|
||||
|
|
@ -33,12 +34,16 @@ M: color-preview model-changed
|
|||
[ <color-slider> add-gadget ] each ;
|
||||
|
||||
: <color-picker> ( -- gadget )
|
||||
[
|
||||
<color-sliders> @top frame,
|
||||
dup <color-model> <color-preview> @center frame,
|
||||
[ [ truncate number>string ] map " " join ] <filter>
|
||||
<label-control> @bottom frame,
|
||||
] make-frame ;
|
||||
<frame>
|
||||
<color-sliders>
|
||||
swap dup
|
||||
[ @top grid-add* ]
|
||||
[ <color-model> <color-preview> @center grid-add* ]
|
||||
[
|
||||
[ [ truncate number>string ] map " " join ] <filter> <label-control>
|
||||
@bottom grid-add*
|
||||
]
|
||||
tri* ;
|
||||
|
||||
: color-picker-window ( -- )
|
||||
[ <color-picker> "Color Picker" open-window ] with-ui ;
|
||||
|
|
|
|||
|
|
@ -31,4 +31,4 @@ M: float-complex-blas-matrix pprint-delims drop \ cmatrix{ \ } ;
|
|||
M: double-complex-blas-matrix pprint-delims drop \ zmatrix{ \ } ;
|
||||
|
||||
M: blas-vector-base >pprint-sequence ;
|
||||
M: blas-matrix-base >pprint-sequence Mrows [ >array ] map ;
|
||||
M: blas-matrix-base >pprint-sequence Mrows ;
|
||||
|
|
|
|||
|
|
@ -104,12 +104,12 @@ unit-test
|
|||
[ svector{ 1.0 2.0 } ] [ svector{ 4.0 8.0 } 4.0 V/n ] unit-test
|
||||
[ dvector{ 1.0 2.0 } ] [ dvector{ 4.0 8.0 } 4.0 V/n ] unit-test
|
||||
|
||||
[ cvector{ 2.0 1.0 } ]
|
||||
[ cvector{ C{ 16.0 4.0 } C{ 8.0 2.0 } } C{ 8.0 2.0 } V/n ]
|
||||
[ cvector{ C{ 0.0 -4.0 } 1.0 } ]
|
||||
[ cvector{ C{ 4.0 -4.0 } C{ 1.0 1.0 } } C{ 1.0 1.0 } V/n ]
|
||||
unit-test
|
||||
|
||||
[ cvector{ 2.0 1.0 } ]
|
||||
[ cvector{ C{ 16.0 4.0 } C{ 8.0 2.0 } } C{ 8.0 2.0 } V/n ]
|
||||
[ zvector{ C{ 0.0 -4.0 } 1.0 } ]
|
||||
[ zvector{ C{ 4.0 -4.0 } C{ 1.0 1.0 } } C{ 1.0 1.0 } V/n ]
|
||||
unit-test
|
||||
|
||||
! V.
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ HELP: 1token
|
|||
} { $description
|
||||
"Calls 1string on a character and returns a parser that matches that character."
|
||||
} { $examples
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"a\" CHAR: a 1token parse parse-result-ast ." "\"a\"" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"a\" CHAR: a 1token parse ." "\"a\"" }
|
||||
} { $see-also 'string' } ;
|
||||
|
||||
HELP: (list-of)
|
||||
|
|
@ -33,8 +33,8 @@ HELP: list-of
|
|||
"Returns a parser that returns a list of items separated by the separator parser. Hides the separators and matches a list of one or more items."
|
||||
} { $notes "Use " { $link list-of-many } " to ensure a list contains two or more items." }
|
||||
{ $examples
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"a\" \"a\" token \",\" token list-of parse parse-result-ast ." "V{ \"a\" }" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"a,a,a,a\" \"a\" token \",\" token list-of parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"a\" \"a\" token \",\" token list-of parse ." "V{ \"a\" }" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"a,a,a,a\" \"a\" token \",\" token list-of parse ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
} { $see-also list-of-many } ;
|
||||
|
||||
HELP: list-of-many
|
||||
|
|
@ -46,8 +46,8 @@ HELP: list-of-many
|
|||
"Returns a parser that returns a list of items separated by the separator parser. Hides the separators and matches a list of two or more items."
|
||||
} { $notes "Use " { $link list-of } " to return a list of only one item."
|
||||
} { $examples
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"a\" \"a\" token \",\" token list-of-many parse ." "f" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"a,a,a,a\" \"a\" token \",\" token list-of-many parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
{ $code "USING: peg peg.parsers prettyprint ;" "\"a\" \"a\" token \",\" token list-of-many parse => exception" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"a,a,a,a\" \"a\" token \",\" token list-of-many parse ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
} { $see-also list-of } ;
|
||||
|
||||
HELP: epsilon
|
||||
|
|
@ -72,8 +72,8 @@ HELP: exactly-n
|
|||
} { $description
|
||||
"Returns a parser that matches an exact repetition of the input parser."
|
||||
} { $examples
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaa\" \"a\" token 4 exactly-n parse ." "f" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaaa\" \"a\" token 4 exactly-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
{ $code "USING: peg peg.parsers prettyprint ;" "\"aaa\" \"a\" token 4 exactly-n parse => exception" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaaa\" \"a\" token 4 exactly-n parse ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
} { $see-also at-least-n at-most-n from-m-to-n } ;
|
||||
|
||||
HELP: at-least-n
|
||||
|
|
@ -84,9 +84,9 @@ HELP: at-least-n
|
|||
} { $description
|
||||
"Returns a parser that matches n or more repetitions of the input parser."
|
||||
} { $examples
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaa\" \"a\" token 4 at-least-n parse ." "f" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaaa\" \"a\" token 4 at-least-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaaaa\" \"a\" token 4 at-least-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" \"a\" }" }
|
||||
{ $code "USING: peg peg.parsers prettyprint ;" "\"aaa\" \"a\" token 4 at-least-n parse => exception"}
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaaa\" \"a\" token 4 at-least-n parse ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaaaa\" \"a\" token 4 at-least-n parse ." "V{ \"a\" \"a\" \"a\" \"a\" \"a\" }" }
|
||||
} { $see-also exactly-n at-most-n from-m-to-n } ;
|
||||
|
||||
HELP: at-most-n
|
||||
|
|
@ -97,8 +97,8 @@ HELP: at-most-n
|
|||
} { $description
|
||||
"Returns a parser that matches n or fewer repetitions of the input parser."
|
||||
} { $examples
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaaa\" \"a\" token 4 at-most-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaaaa\" \"a\" token 4 at-most-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaaa\" \"a\" token 4 at-most-n parse ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaaaa\" \"a\" token 4 at-most-n parse ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
} { $see-also exactly-n at-least-n from-m-to-n } ;
|
||||
|
||||
HELP: from-m-to-n
|
||||
|
|
@ -110,9 +110,9 @@ HELP: from-m-to-n
|
|||
} { $description
|
||||
"Returns a parser that matches between and including m to n repetitions of the input parser."
|
||||
} { $examples
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" }" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaaaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaa\" \"a\" token 3 4 from-m-to-n parse ." "V{ \"a\" \"a\" \"a\" }" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaaa\" \"a\" token 3 4 from-m-to-n parse ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaaaa\" \"a\" token 3 4 from-m-to-n parse ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
} { $see-also exactly-n at-most-n at-least-n } ;
|
||||
|
||||
HELP: pack
|
||||
|
|
@ -124,7 +124,7 @@ HELP: pack
|
|||
} { $description
|
||||
"Returns a parser that parses the begin, body, and end parsers in order. The begin and end parsers are hidden."
|
||||
} { $examples
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"hi123bye\" \"hi\" token 'integer' \"bye\" token pack parse parse-result-ast ." "123" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"hi123bye\" \"hi\" token 'integer' \"bye\" token pack parse ." "123" }
|
||||
} { $see-also surrounded-by } ;
|
||||
|
||||
HELP: surrounded-by
|
||||
|
|
@ -136,7 +136,7 @@ HELP: surrounded-by
|
|||
} { $description
|
||||
"Calls token on begin and end to make them into string parsers. Returns a parser that parses the begin, body, and end parsers in order. The begin and end parsers are hidden."
|
||||
} { $examples
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"hi123bye\" 'integer' \"hi\" \"bye\" surrounded-by parse parse-result-ast ." "123" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"hi123bye\" 'integer' \"hi\" \"bye\" surrounded-by parse ." "123" }
|
||||
} { $see-also pack } ;
|
||||
|
||||
HELP: 'digit'
|
||||
|
|
@ -173,7 +173,7 @@ HELP: range-pattern
|
|||
"of characters separated with a dash (-) represents the "
|
||||
"range of characters from the first to the second, inclusive."
|
||||
{ $examples
|
||||
{ $example "USING: peg peg.parsers prettyprint strings ;" "\"a\" \"_a-zA-Z\" range-pattern parse parse-result-ast 1string ." "\"a\"" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;\n\"0\" \"^0-9\" range-pattern parse ." "f" }
|
||||
{ $example "USING: peg peg.parsers prettyprint strings ;" "\"a\" \"_a-zA-Z\" range-pattern parse 1string ." "\"a\"" }
|
||||
{ $code "USING: peg peg.parsers prettyprint ;\n\"0\" \"^0-9\" range-pattern parse => exception"}
|
||||
}
|
||||
} ;
|
||||
|
|
|
|||
|
|
@ -7,11 +7,11 @@ HELP: parse
|
|||
{ $values
|
||||
{ "input" "a string" }
|
||||
{ "parser" "a parser" }
|
||||
{ "result" "a parse-result or f" }
|
||||
{ "ast" "an object" }
|
||||
}
|
||||
{ $description
|
||||
"Given the input string, parse it using the given parser. The result is a <parse-result> object if "
|
||||
"the parse was successful, otherwise it is f." }
|
||||
"Given the input string, parse it using the given parser. The result is the abstract "
|
||||
"syntax tree returned by the parser." }
|
||||
{ $see-also compile } ;
|
||||
|
||||
HELP: compile
|
||||
|
|
@ -20,7 +20,7 @@ HELP: compile
|
|||
{ "word" "a word" }
|
||||
}
|
||||
{ $description
|
||||
"Compile the parser to a word. The word will have stack effect ( -- result )."
|
||||
"Compile the parser to a word. The word will have stack effect ( -- ast )."
|
||||
}
|
||||
{ $see-also parse } ;
|
||||
|
||||
|
|
@ -104,8 +104,7 @@ HELP: semantic
|
|||
"Returns a parser that succeeds if the 'p1' parser succeeds and the quotation called with "
|
||||
"the AST produced by 'p1' on the stack returns true." }
|
||||
{ $examples
|
||||
{ $example "USING: kernel math peg prettyprint ;" "\"A\" [ drop t ] satisfy [ 66 > ] semantic parse ." "f" }
|
||||
{ $example "USING: kernel math peg prettyprint ;" "\"C\" [ drop t ] satisfy [ 66 > ] semantic parse parse-result-ast ." "67" }
|
||||
{ $example "USING: kernel math peg prettyprint ;" "\"C\" [ drop t ] satisfy [ 66 > ] semantic parse ." "67" }
|
||||
} ;
|
||||
|
||||
HELP: ensure
|
||||
|
|
|
|||
|
|
@ -8,7 +8,6 @@ ARTICLE: "ui-frame-layout" "Frame layouts"
|
|||
"Creating empty frames:"
|
||||
{ $subsection <frame> }
|
||||
"Creating new frames using a combinator:"
|
||||
{ $subsection make-frame }
|
||||
{ $subsection frame, }
|
||||
"A set of mnemonic words for the positions on a frame's 3x3 grid; these words push values which may be passed to " { $link grid-add } " or " { $link frame, } ":"
|
||||
{ $subsection @center }
|
||||
|
|
@ -44,15 +43,9 @@ HELP: <frame>
|
|||
{ $values { "frame" frame } }
|
||||
{ $description "Creates a new " { $link frame } " for laying out gadgets in a 3x3 grid." } ;
|
||||
|
||||
{ <frame> make-frame } related-words
|
||||
|
||||
HELP: make-frame
|
||||
{ $values { "quot" quotation } { "frame" frame } }
|
||||
{ $description "Creates a new frame. The quotation can add children by calling the " { $link frame, } " word." } ;
|
||||
|
||||
HELP: frame,
|
||||
{ $values { "gadget" gadget } { "i" "non-negative integer" } { "j" "non-negative integer" } }
|
||||
{ $description "Adds a child gadget at the specified location. This word can only be called inside the quotation passed to " { $link make-frame } "." } ;
|
||||
{ $description "Adds a child gadget at the specified location. This word can only be called inside the quotation passed to make-frame." } ;
|
||||
|
||||
{ grid frame } related-words
|
||||
|
||||
|
|
|
|||
|
|
@ -39,8 +39,5 @@ M: frame layout*
|
|||
[ rot rect-dim fill-center ] 3keep
|
||||
grid-layout ;
|
||||
|
||||
: make-frame ( quot -- frame )
|
||||
<frame> swap make-gadget ; inline
|
||||
|
||||
: frame, ( gadget i j -- )
|
||||
gadget get -rot grid-add ;
|
||||
|
|
|
|||
|
|
@ -180,14 +180,6 @@ HELP: focusable-child
|
|||
{ $values { "gadget" gadget } { "child" gadget } }
|
||||
{ $description "Outputs the child of the gadget which would prefer to receive keyboard focus." } ;
|
||||
|
||||
HELP: make-gadget
|
||||
{ $values { "gadget" gadget } { "quot" quotation } }
|
||||
{ $description "Calls the quotation in a new scope with the gadget stored in the " { $link gadget } " variable." } ;
|
||||
|
||||
HELP: with-gadget
|
||||
{ $values { "gadget" gadget } { "quot" quotation } }
|
||||
{ $description "Calls the quotation in a new scope with the " { $link gadget } " and " { $link make-gadget } " variables set to " { $snippet "gadget" } } ;
|
||||
|
||||
{ control-value set-control-value gadget-model } related-words
|
||||
|
||||
HELP: control-value
|
||||
|
|
|
|||
|
|
@ -357,12 +357,6 @@ M: f request-focus-on 2drop ;
|
|||
: focus-path ( world -- seq )
|
||||
[ focus>> ] follow ;
|
||||
|
||||
: with-gadget ( gadget quot -- )
|
||||
gadget swap with-variable ; inline
|
||||
|
||||
: make-gadget ( gadget quot -- gadget )
|
||||
[ with-gadget ] [ drop ] 2bi ; inline
|
||||
|
||||
! Deprecated
|
||||
: set-gadget-delegate ( gadget tuple -- )
|
||||
over [
|
||||
|
|
|
|||
|
|
@ -38,10 +38,9 @@ M: labelled-gadget focusable-child* labelled-gadget-content ;
|
|||
: <title-label> ( text -- label ) <label> dup title-theme ;
|
||||
|
||||
: <title-bar> ( title quot -- gadget )
|
||||
[
|
||||
[ <close-box> @left frame, ] when*
|
||||
<title-label> @center frame,
|
||||
] make-frame ;
|
||||
<frame>
|
||||
swap dup [ <close-box> @left grid-add* ] [ drop ] if
|
||||
swap <title-label> @center grid-add* ;
|
||||
|
||||
TUPLE: closable-gadget < frame content ;
|
||||
|
||||
|
|
|
|||
|
|
@ -96,8 +96,10 @@ TUPLE: editable-slot < track printer ref ;
|
|||
<roll-button> ;
|
||||
|
||||
: display-slot ( gadget editable-slot -- )
|
||||
dup clear-track
|
||||
[ 1 track, <edit-button> f track, ] with-gadget ;
|
||||
dup clear-track
|
||||
swap 1 track-add*
|
||||
<edit-button> f track-add*
|
||||
drop ;
|
||||
|
||||
: update-slot ( editable-slot -- )
|
||||
[ [ ref>> get-ref ] [ printer>> ] bi call ] keep
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
USING: accessors kernel fry math math.vectors sequences arrays vectors assocs
|
||||
hashtables models models.range models.compose combinators
|
||||
ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs
|
||||
ui.gadgets.grids ui.gadgets.viewports ui.gadgets.books ;
|
||||
ui.gadgets.grids ui.gadgets.viewports ui.gadgets.books locals ;
|
||||
|
||||
IN: ui.gadgets.tabs
|
||||
|
||||
|
|
@ -12,11 +12,12 @@ TUPLE: tabbed < frame names toggler content ;
|
|||
|
||||
DEFER: (del-page)
|
||||
|
||||
: add-toggle ( model n name toggler -- )
|
||||
[ [ gadget-parent '[ , , , (del-page) ] "X" swap
|
||||
<bevel-button> @right frame, ] 3keep
|
||||
[ swapd <toggle-button> @center frame, ] dip ] make-frame
|
||||
add-gadget drop ;
|
||||
:: add-toggle ( model n name toggler -- )
|
||||
<frame>
|
||||
n name toggler parent>> '[ , , , (del-page) ] "X" swap <bevel-button>
|
||||
@right grid-add*
|
||||
n model name <toggle-button> @center grid-add*
|
||||
toggler swap add-gadget drop ;
|
||||
|
||||
: redo-toggler ( tabbed -- )
|
||||
[ names>> ] [ model>> ] [ toggler>> ] tri
|
||||
|
|
|
|||
|
|
@ -8,9 +8,7 @@ ARTICLE: "ui-track-layout" "Track layouts"
|
|||
"Creating empty tracks:"
|
||||
{ $subsection <track> }
|
||||
"Adding children:"
|
||||
{ $subsection track-add }
|
||||
"Creating new tracks using a combinator:"
|
||||
{ $subsection track, } ;
|
||||
{ $subsection track-add } ;
|
||||
|
||||
HELP: track
|
||||
{ $class-description "A track is like a " { $link pack } " except each child is resized to a fixed multiple of the track's dimension in the direction of " { $link gadget-orientation } ". Tracks are created by calling " { $link <track> } "." } ;
|
||||
|
|
@ -23,8 +21,4 @@ HELP: track-add
|
|||
{ $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } }
|
||||
{ $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child." } ;
|
||||
|
||||
HELP: track,
|
||||
{ $values { "gadget" gadget } { "constraint" "a number between 0 and 1, or " { $link f } } }
|
||||
{ $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child." } ;
|
||||
|
||||
ABOUT: "ui-track-layout"
|
||||
|
|
|
|||
|
|
@ -1,68 +1,65 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors io kernel math namespaces
|
||||
sequences words math.vectors ui.gadgets ui.gadgets.packs math.geometry.rect ;
|
||||
sequences words math.vectors ui.gadgets ui.gadgets.packs
|
||||
math.geometry.rect fry ;
|
||||
|
||||
IN: ui.gadgets.tracks
|
||||
|
||||
TUPLE: track < pack sizes ;
|
||||
|
||||
: normalized-sizes ( track -- seq )
|
||||
track-sizes
|
||||
[ sift sum ] keep [ dup [ over / ] when ] map nip ;
|
||||
sizes>> dup sift sum '[ dup [ , / ] when ] map ;
|
||||
|
||||
: new-track ( orientation class -- track )
|
||||
new-gadget
|
||||
swap >>orientation
|
||||
V{ } clone >>sizes
|
||||
1 >>fill ; inline
|
||||
new-gadget
|
||||
swap >>orientation
|
||||
V{ } clone >>sizes
|
||||
1 >>fill ; inline
|
||||
|
||||
: <track> ( orientation -- track )
|
||||
track new-track ;
|
||||
: <track> ( orientation -- track ) track new-track ;
|
||||
|
||||
: alloted-dim ( track -- dim )
|
||||
dup gadget-children swap track-sizes { 0 0 }
|
||||
[ [ drop { 0 0 } ] [ pref-dim ] if v+ ] 2reduce ;
|
||||
[ children>> ] [ sizes>> ] bi { 0 0 }
|
||||
[ [ drop { 0 0 } ] [ pref-dim ] if v+ ] 2reduce ;
|
||||
|
||||
: available-dim ( track -- dim )
|
||||
dup rect-dim swap alloted-dim v- ;
|
||||
: available-dim ( track -- dim ) [ dim>> ] [ alloted-dim ] bi v- ;
|
||||
|
||||
: track-layout ( track -- sizes )
|
||||
dup available-dim over gadget-children rot normalized-sizes
|
||||
[ available-dim ] [ children>> ] [ normalized-sizes ] tri
|
||||
[ [ over n*v ] [ pref-dim ] ?if ] 2map nip ;
|
||||
|
||||
M: track layout*
|
||||
dup track-layout pack-layout ;
|
||||
M: track layout* ( track -- ) dup track-layout pack-layout ;
|
||||
|
||||
: track-pref-dims-1 ( track -- dim )
|
||||
gadget-children pref-dims max-dim ;
|
||||
: track-pref-dims-1 ( track -- dim ) children>> pref-dims max-dim ;
|
||||
|
||||
: track-pref-dims-2 ( track -- dim )
|
||||
dup gadget-children pref-dims swap normalized-sizes
|
||||
[ [ v/n ] when* ] 2map max-dim [ >fixnum ] map ;
|
||||
[ children>> pref-dims ] [ normalized-sizes ] bi
|
||||
[ [ v/n ] when* ] 2map
|
||||
max-dim
|
||||
[ >fixnum ] map ;
|
||||
|
||||
M: track pref-dim*
|
||||
dup track-pref-dims-1
|
||||
over alloted-dim
|
||||
pick track-pref-dims-2 v+
|
||||
rot gadget-orientation set-axis ;
|
||||
M: track pref-dim* ( gadget -- dim )
|
||||
[ track-pref-dims-1 ]
|
||||
[ [ alloted-dim ] [ track-pref-dims-1 ] bi v+ ]
|
||||
[ orientation>> ]
|
||||
tri
|
||||
set-axis ;
|
||||
|
||||
: track-add ( gadget track constraint -- )
|
||||
over track-sizes push swap add-gadget drop ;
|
||||
|
||||
: track-add* ( track gadget constraint -- track )
|
||||
pick sizes>> push
|
||||
add-gadget ;
|
||||
pick sizes>> push add-gadget ;
|
||||
|
||||
: track, ( gadget constraint -- )
|
||||
gadget get swap track-add ;
|
||||
: track-remove ( track gadget -- track )
|
||||
dupd dup
|
||||
[
|
||||
[ swap children>> index ]
|
||||
[ unparent sizes>> ] 2bi
|
||||
delete-nth
|
||||
]
|
||||
[ 2drop ]
|
||||
if ;
|
||||
|
||||
: track-remove ( gadget track -- )
|
||||
over [
|
||||
[ gadget-children index ] 2keep
|
||||
swap unparent track-sizes delete-nth
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
: clear-track ( track -- )
|
||||
V{ } clone over set-track-sizes clear-gadget ;
|
||||
: clear-track ( track -- ) V{ } clone >>sizes clear-gadget ;
|
||||
|
|
|
|||
|
|
@ -31,7 +31,7 @@ TUPLE: listener-gadget < track input output stack ;
|
|||
|
||||
: welcome. ( -- )
|
||||
"If this is your first time with Factor, please read the " print
|
||||
"cookbook" ($link) "." print nl ;
|
||||
"handbook" ($link) "." print nl ;
|
||||
|
||||
M: listener-gadget focusable-child*
|
||||
input>> ;
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ IN: ui.tools.search.tests
|
|||
T{ key-down f { C+ } "x" } swap search-gesture
|
||||
] unit-test
|
||||
|
||||
: assert-non-empty empty? f assert= ;
|
||||
: assert-non-empty ( obj -- ) empty? f assert= ;
|
||||
|
||||
: update-live-search ( search -- seq )
|
||||
dup [
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: ui.tools ui.tools.interactor ui.tools.listener
|
|||
ui.tools.search ui.tools.workspace kernel models namespaces
|
||||
sequences tools.test ui.gadgets ui.gadgets.buttons
|
||||
ui.gadgets.labelled ui.gadgets.presentations
|
||||
ui.gadgets.scrollers vocabs tools.test.ui ui ;
|
||||
ui.gadgets.scrollers vocabs tools.test.ui ui accessors ;
|
||||
IN: ui.tools.tests
|
||||
|
||||
[ f ]
|
||||
|
|
|
|||
|
|
@ -1,25 +1,23 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: classes continuations help help.topics kernel models
|
||||
sequences ui ui.backend ui.tools.debugger ui.gadgets
|
||||
ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
|
||||
ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks
|
||||
ui.gadgets.worlds ui.gadgets.presentations ui.gadgets.status-bar
|
||||
ui.commands ui.gestures assocs arrays namespaces accessors ;
|
||||
sequences ui ui.backend ui.tools.debugger ui.gadgets
|
||||
ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
|
||||
ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks
|
||||
ui.gadgets.worlds ui.gadgets.presentations ui.gadgets.status-bar
|
||||
ui.commands ui.gestures assocs arrays namespaces accessors ;
|
||||
|
||||
IN: ui.tools.workspace
|
||||
|
||||
TUPLE: workspace < track book listener popup ;
|
||||
|
||||
: find-workspace ( gadget -- workspace )
|
||||
[ workspace? ] find-parent ;
|
||||
: find-workspace ( gadget -- workspace ) [ workspace? ] find-parent ;
|
||||
|
||||
SYMBOL: workspace-window-hook
|
||||
|
||||
: workspace-window* ( -- workspace )
|
||||
workspace-window-hook get call ;
|
||||
: workspace-window* ( -- workspace ) workspace-window-hook get call ;
|
||||
|
||||
: workspace-window ( -- )
|
||||
workspace-window* drop ;
|
||||
: workspace-window ( -- ) workspace-window* drop ;
|
||||
|
||||
GENERIC: call-tool* ( arg tool -- )
|
||||
|
||||
|
|
@ -28,7 +26,7 @@ GENERIC: tool-scroller ( tool -- scroller )
|
|||
M: gadget tool-scroller drop f ;
|
||||
|
||||
: find-tool ( class workspace -- index tool )
|
||||
workspace-book gadget-children [ class eq? ] with find ;
|
||||
book>> children>> [ class eq? ] with find ;
|
||||
|
||||
: show-tool ( class workspace -- tool )
|
||||
[ find-tool swap ] keep workspace-book gadget-model
|
||||
|
|
@ -57,9 +55,9 @@ M: gadget tool-scroller drop f ;
|
|||
article-title open-window ;
|
||||
|
||||
: hide-popup ( workspace -- )
|
||||
dup workspace-popup over track-remove
|
||||
f over set-workspace-popup
|
||||
request-focus ;
|
||||
dup popup>> track-remove
|
||||
f >>popup
|
||||
request-focus ;
|
||||
|
||||
: show-popup ( gadget workspace -- )
|
||||
dup hide-popup
|
||||
|
|
|
|||
|
|
@ -232,13 +232,7 @@ ARTICLE: "ui-layout-combinators" "Creating layouts using combinators"
|
|||
"The " { $link make } " combinator provides a convenient way of constructing sequences by keeping the intermediate sequence off the stack until construction is done. The " { $link , } " and " { $link % } " words operate on this implicit sequence, reducing stack noise."
|
||||
$nl
|
||||
"Similar tools exist for constructing complex gadget hierarchies. Different words are used for different types of gadgets; see " { $link "ui-pack-layout" } ", " { $link "ui-track-layout" } " and " { $link "ui-frame-layout" } " for specifics. This section documents their common factors."
|
||||
$nl
|
||||
"Gadget construction combinators whose names are prefixed with " { $snippet "make-" } " construct new gadgets and push them on the stack. The primitive combinator used to define all combinators of this form:"
|
||||
{ $subsection make-gadget }
|
||||
"Words such as " { $link track, } " access the gadget through the " { $link gadget } " variable."
|
||||
$nl
|
||||
"A combinator which stores a gadget in the " { $link gadget } " variable:"
|
||||
{ $subsection with-gadget } ;
|
||||
;
|
||||
|
||||
ARTICLE: "ui-null-layout" "Manual layouts"
|
||||
"When automatic layout is not appropriate, gadgets can be added to a parent with no layout policy, and then positioned and sized manually:"
|
||||
|
|
|
|||
Loading…
Reference in New Issue