Merge branch 'master' of git://factorcode.org/git/factor
commit
939cac65b3
|
@ -19,8 +19,13 @@ load-help? off
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
! Rehash hashtables, since bootstrap.image creates them
|
! Rehash hashtables, since bootstrap.image creates them
|
||||||
! using the host image's hashing algorithms
|
! using the host image's hashing algorithms. We don't
|
||||||
[ hashtable? ] instances [ rehash ] each
|
! use each-object here since the catch stack isn't yet
|
||||||
|
! set up.
|
||||||
|
begin-scan
|
||||||
|
[ hashtable? ] pusher [ (each-object) ] dip
|
||||||
|
end-scan
|
||||||
|
[ rehash ] each
|
||||||
boot
|
boot
|
||||||
] %
|
] %
|
||||||
|
|
||||||
|
|
|
@ -14,13 +14,13 @@ big-endian on
|
||||||
: ds-reg 14 ;
|
: ds-reg 14 ;
|
||||||
: rs-reg 15 ;
|
: rs-reg 15 ;
|
||||||
|
|
||||||
: factor-area-size 4 bootstrap-cells ;
|
: factor-area-size ( -- n ) 4 bootstrap-cells ;
|
||||||
|
|
||||||
: stack-frame
|
: stack-frame ( -- n )
|
||||||
factor-area-size c-area-size + 4 bootstrap-cells align ;
|
factor-area-size c-area-size + 4 bootstrap-cells align ;
|
||||||
|
|
||||||
: next-save stack-frame bootstrap-cell - ;
|
: next-save ( -- n ) stack-frame bootstrap-cell - ;
|
||||||
: xt-save stack-frame 2 bootstrap-cells - ;
|
: xt-save ( -- n ) stack-frame 2 bootstrap-cells - ;
|
||||||
|
|
||||||
[
|
[
|
||||||
0 6 LOAD32
|
0 6 LOAD32
|
||||||
|
|
|
@ -3,8 +3,8 @@
|
||||||
USING: parser layouts system kernel ;
|
USING: parser layouts system kernel ;
|
||||||
IN: bootstrap.ppc
|
IN: bootstrap.ppc
|
||||||
|
|
||||||
: c-area-size 10 bootstrap-cells ;
|
: c-area-size ( -- n ) 10 bootstrap-cells ;
|
||||||
: lr-save bootstrap-cell ;
|
: lr-save ( -- n ) bootstrap-cell ;
|
||||||
|
|
||||||
<< "resource:core/cpu/ppc/bootstrap.factor" parse-file parsed >>
|
<< "resource:core/cpu/ppc/bootstrap.factor" parse-file parsed >>
|
||||||
call
|
call
|
||||||
|
|
|
@ -3,8 +3,8 @@
|
||||||
USING: parser layouts system kernel ;
|
USING: parser layouts system kernel ;
|
||||||
IN: bootstrap.ppc
|
IN: bootstrap.ppc
|
||||||
|
|
||||||
: c-area-size 14 bootstrap-cells ;
|
: c-area-size ( -- n ) 14 bootstrap-cells ;
|
||||||
: lr-save 2 bootstrap-cells ;
|
: lr-save ( -- n ) 2 bootstrap-cells ;
|
||||||
|
|
||||||
<< "resource:core/cpu/ppc/bootstrap.factor" parse-file parsed >>
|
<< "resource:core/cpu/ppc/bootstrap.factor" parse-file parsed >>
|
||||||
call
|
call
|
||||||
|
|
|
@ -23,3 +23,6 @@ TUPLE: testing x y z ;
|
||||||
] when*
|
] when*
|
||||||
] each
|
] each
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
! Erg's bug
|
||||||
|
2 [ [ [ 3 throw ] instances ] must-fail ] times
|
||||||
|
|
|
@ -1,17 +1,15 @@
|
||||||
! Copyright (C) 2005, 2007 Slava Pestov.
|
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: kernel continuations sequences arrays system ;
|
||||||
IN: memory
|
IN: memory
|
||||||
USING: arrays kernel sequences vectors system hashtables
|
|
||||||
kernel.private sbufs growable assocs namespaces quotations
|
|
||||||
math strings combinators ;
|
|
||||||
|
|
||||||
: (each-object) ( quot: ( obj -- ) -- )
|
: (each-object) ( quot: ( obj -- ) -- )
|
||||||
[ next-object dup ] swap [ drop ] while ; inline
|
[ next-object dup ] swap [ drop ] while ; inline
|
||||||
|
|
||||||
: each-object ( quot -- )
|
: each-object ( quot -- )
|
||||||
begin-scan (each-object) end-scan ; inline
|
begin-scan [ (each-object) ] [ end-scan ] [ ] cleanup ; inline
|
||||||
|
|
||||||
: instances ( quot -- seq )
|
: instances ( quot -- seq )
|
||||||
pusher >r each-object r> >array ; inline
|
pusher [ each-object ] dip >array ; inline
|
||||||
|
|
||||||
: save ( -- ) image save-image ;
|
: save ( -- ) image save-image ;
|
||||||
|
|
|
@ -72,13 +72,13 @@ DEFER: automata-window
|
||||||
"5 - Random Rule" [ random-rule ] view-button add-gadget
|
"5 - Random Rule" [ random-rule ] view-button add-gadget
|
||||||
"n - New" [ automata-window ] view-button add-gadget
|
"n - New" [ automata-window ] view-button add-gadget
|
||||||
|
|
||||||
@top grid-add*
|
@top grid-add
|
||||||
|
|
||||||
C[ display ] <slate>
|
C[ display ] <slate>
|
||||||
{ 400 400 } >>pdim
|
{ 400 400 } >>pdim
|
||||||
dup >slate
|
dup >slate
|
||||||
|
|
||||||
@center grid-add*
|
@center grid-add
|
||||||
|
|
||||||
<handler>
|
<handler>
|
||||||
|
|
||||||
|
|
|
@ -100,72 +100,68 @@ VARS: population-label cohesion-label alignment-label separation-label ;
|
||||||
: boids-window* ( -- )
|
: boids-window* ( -- )
|
||||||
init-variables init-world-size init-boids loop on
|
init-variables init-world-size init-boids loop on
|
||||||
|
|
||||||
C[ display ] <slate> >slate
|
|
||||||
t slate> set-gadget-clipped?
|
|
||||||
{ 600 400 } slate> set-slate-pdim
|
|
||||||
C[ [ run ] in-thread ] slate> set-slate-graft
|
|
||||||
C[ loop off ] slate> set-slate-ungraft
|
|
||||||
|
|
||||||
"" <label> reverse-video-theme >population-label update-population-label
|
"" <label> reverse-video-theme >population-label update-population-label
|
||||||
|
|
||||||
"" <label> reverse-video-theme >cohesion-label update-cohesion-label
|
"" <label> reverse-video-theme >cohesion-label update-cohesion-label
|
||||||
"" <label> reverse-video-theme >alignment-label update-alignment-label
|
"" <label> reverse-video-theme >alignment-label update-alignment-label
|
||||||
"" <label> reverse-video-theme >separation-label update-separation-label
|
"" <label> reverse-video-theme >separation-label update-separation-label
|
||||||
|
|
||||||
<frame>
|
<frame>
|
||||||
|
|
||||||
<shelf>
|
<shelf>
|
||||||
|
|
||||||
{
|
1 >>fill
|
||||||
[ "ESC - Pause" [ drop toggle-loop ] button* ]
|
|
||||||
|
|
||||||
[ "1 - Randomize" [ drop randomize ] button* ]
|
"ESC - Pause" [ drop toggle-loop ] button* add-gadget
|
||||||
|
|
||||||
|
"1 - Randomize" [ drop randomize ] button* add-gadget
|
||||||
|
|
||||||
|
<pile> 1 over set-pack-fill
|
||||||
|
population-label> add-gadget
|
||||||
|
"3 - Add 10" [ drop add-10-boids ] button* add-gadget
|
||||||
|
"2 - Sub 10" [ drop sub-10-boids ] button* add-gadget
|
||||||
|
add-gadget
|
||||||
|
|
||||||
|
<pile> 1 over set-pack-fill
|
||||||
|
cohesion-label> add-gadget
|
||||||
|
"q - +0.1" [ drop inc-cohesion-weight ] button* add-gadget
|
||||||
|
"a - -0.1" [ drop dec-cohesion-weight ] button* add-gadget
|
||||||
|
add-gadget
|
||||||
|
|
||||||
[ <pile> 1 over set-pack-fill
|
<pile> 1 over set-pack-fill
|
||||||
population-label> add-gadget
|
alignment-label> add-gadget
|
||||||
"3 - Add 10" [ drop add-10-boids ] button* add-gadget
|
"w - +0.1" [ drop inc-alignment-weight ] button* add-gadget
|
||||||
"2 - Sub 10" [ drop sub-10-boids ] button* add-gadget ]
|
"s - -0.1" [ drop dec-alignment-weight ] button* add-gadget
|
||||||
|
add-gadget
|
||||||
|
|
||||||
[ <pile> 1 over set-pack-fill
|
<pile> 1 over set-pack-fill
|
||||||
cohesion-label> add-gadget
|
separation-label> add-gadget
|
||||||
"q - +0.1" [ drop inc-cohesion-weight ] button* add-gadget
|
"e - +0.1" [ drop inc-separation-weight ] button* add-gadget
|
||||||
"a - -0.1" [ drop dec-cohesion-weight ] button* add-gadget ]
|
"d - -0.1" [ drop dec-separation-weight ] button* add-gadget
|
||||||
|
add-gadget
|
||||||
|
|
||||||
[ <pile> 1 over set-pack-fill
|
@top grid-add
|
||||||
alignment-label> add-gadget
|
|
||||||
"w - +0.1" [ drop inc-alignment-weight ] button* add-gadget
|
|
||||||
"s - -0.1" [ drop dec-alignment-weight ] button* add-gadget ]
|
|
||||||
|
|
||||||
[ <pile> 1 over set-pack-fill
|
C[ display ] <slate>
|
||||||
separation-label> add-gadget
|
dup >slate
|
||||||
"e - +0.1" [ drop inc-separation-weight ] button* add-gadget
|
t >>clipped?
|
||||||
"d - -0.1" [ drop dec-separation-weight ] button* add-gadget ]
|
{ 600 400 } >>pdim
|
||||||
|
C[ [ run ] in-thread ] >>graft
|
||||||
} [ call ] map [ add-gadget ] each
|
C[ loop off ] >>ungraft
|
||||||
1 over set-pack-fill
|
@center grid-add
|
||||||
@top grid-add*
|
|
||||||
|
|
||||||
slate> @center grid-add*
|
|
||||||
|
|
||||||
<handler>
|
<handler>
|
||||||
|
H{ } clone
|
||||||
H{ } clone
|
T{ key-down f f "1" } C[ drop randomize ] is
|
||||||
T{ key-down f f "1" } C[ drop randomize ] is
|
T{ key-down f f "2" } C[ drop sub-10-boids ] is
|
||||||
T{ key-down f f "2" } C[ drop sub-10-boids ] is
|
T{ key-down f f "3" } C[ drop add-10-boids ] is
|
||||||
T{ key-down f f "3" } C[ drop add-10-boids ] is
|
T{ key-down f f "q" } C[ drop inc-cohesion-weight ] is
|
||||||
|
T{ key-down f f "a" } C[ drop dec-cohesion-weight ] is
|
||||||
T{ key-down f f "q" } C[ drop inc-cohesion-weight ] is
|
T{ key-down f f "w" } C[ drop inc-alignment-weight ] is
|
||||||
T{ key-down f f "a" } C[ drop dec-cohesion-weight ] is
|
T{ key-down f f "s" } C[ drop dec-alignment-weight ] is
|
||||||
|
T{ key-down f f "e" } C[ drop inc-separation-weight ] is
|
||||||
T{ key-down f f "w" } C[ drop inc-alignment-weight ] is
|
T{ key-down f f "d" } C[ drop dec-separation-weight ] is
|
||||||
T{ key-down f f "s" } C[ drop dec-alignment-weight ] is
|
T{ key-down f f "ESC" } C[ drop toggle-loop ] is
|
||||||
|
>>table
|
||||||
T{ key-down f f "e" } C[ drop inc-separation-weight ] is
|
|
||||||
T{ key-down f f "d" } C[ drop dec-separation-weight ] is
|
|
||||||
|
|
||||||
T{ key-down f f "ESC" } C[ drop toggle-loop ] is
|
|
||||||
|
|
||||||
>>table
|
|
||||||
|
|
||||||
"Boids" open-window ;
|
"Boids" open-window ;
|
||||||
|
|
||||||
|
|
|
@ -37,11 +37,11 @@ M: color-preview model-changed
|
||||||
<frame>
|
<frame>
|
||||||
<color-sliders>
|
<color-sliders>
|
||||||
swap dup
|
swap dup
|
||||||
[ @top grid-add* ]
|
[ @top grid-add ]
|
||||||
[ <color-model> <color-preview> @center grid-add* ]
|
[ <color-model> <color-preview> @center grid-add ]
|
||||||
[
|
[
|
||||||
[ [ truncate number>string ] map " " join ] <filter> <label-control>
|
[ [ truncate number>string ] map " " join ] <filter> <label-control>
|
||||||
@bottom grid-add*
|
@bottom grid-add
|
||||||
]
|
]
|
||||||
tri* ;
|
tri* ;
|
||||||
|
|
||||||
|
|
|
@ -2,20 +2,27 @@ USING: help.syntax help.markup kernel prettyprint sequences ;
|
||||||
IN: csv
|
IN: csv
|
||||||
|
|
||||||
HELP: csv
|
HELP: csv
|
||||||
{ $values { "stream" "a stream" }
|
{ $values { "stream" "an input stream" }
|
||||||
{ "rows" "an array of arrays of fields" } }
|
{ "rows" "an array of arrays of fields" } }
|
||||||
{ $description "parses a csv stream into an array of row arrays"
|
{ $description "parses a csv stream into an array of row arrays"
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: csv-row
|
HELP: csv-row
|
||||||
{ $values { "stream" "a stream" }
|
{ $values { "stream" "an input stream" }
|
||||||
{ "row" "an array of fields" } }
|
{ "row" "an array of fields" } }
|
||||||
{ $description "parses a row from a csv stream"
|
{ $description "parses a row from a csv stream"
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
|
HELP: write-csv
|
||||||
|
{ $values { "rows" "an sequence of sequences of strings" }
|
||||||
|
{ "stream" "an output stream" } }
|
||||||
|
{ $description "writes csv to the output stream, escaping where necessary"
|
||||||
|
} ;
|
||||||
|
|
||||||
|
|
||||||
HELP: with-delimiter
|
HELP: with-delimiter
|
||||||
{ $values { "char" "field delimiter (e.g. CHAR: \t)" }
|
{ $values { "char" "field delimiter (e.g. CHAR: \t)" }
|
||||||
{ "quot" "a quotation" } }
|
{ "quot" "a quotation" } }
|
||||||
{ $description "Sets the field delimiter for csv or csv-row words "
|
{ $description "Sets the field delimiter for csv or csv-row words "
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
USING: io.streams.string csv tools.test shuffle ;
|
|
||||||
IN: csv.tests
|
IN: csv.tests
|
||||||
|
USING: io.streams.string csv tools.test shuffle kernel strings ;
|
||||||
|
|
||||||
! I like to name my unit tests
|
! I like to name my unit tests
|
||||||
: named-unit-test ( name output input -- )
|
: named-unit-test ( name output input -- )
|
||||||
|
@ -68,3 +68,11 @@ IN: csv.tests
|
||||||
[ { { "foo" "bar" }
|
[ { { "foo" "bar" }
|
||||||
{ "1" "2" } } ]
|
{ "1" "2" } } ]
|
||||||
[ "foo,\"bar\"\n1,2" <string-reader> csv ] named-unit-test
|
[ "foo,\"bar\"\n1,2" <string-reader> csv ] named-unit-test
|
||||||
|
|
||||||
|
"can write csv too!"
|
||||||
|
[ "foo1,bar1\nfoo2,bar2\n" ]
|
||||||
|
[ { { "foo1" "bar1" } { "foo2" "bar2" } } <string-writer> tuck write-csv >string ] named-unit-test
|
||||||
|
|
||||||
|
"escapes quotes commas and newlines when writing"
|
||||||
|
[ "\"fo\"\"o1\",bar1\n\"fo\no2\",\"b,ar2\"\n" ]
|
||||||
|
[ { { "fo\"o1" "bar1" } { "fo\no2" "b,ar2" } } <string-writer> tuck write-csv >string ] named-unit-test ! "
|
||||||
|
|
|
@ -10,7 +10,7 @@ IN: csv
|
||||||
DEFER: quoted-field
|
DEFER: quoted-field
|
||||||
|
|
||||||
VAR: delimiter
|
VAR: delimiter
|
||||||
|
|
||||||
! trims whitespace from either end of string
|
! trims whitespace from either end of string
|
||||||
: trim-whitespace ( str -- str )
|
: trim-whitespace ( str -- str )
|
||||||
[ blank? ] trim ; inline
|
[ blank? ] trim ; inline
|
||||||
|
@ -57,7 +57,7 @@ VAR: delimiter
|
||||||
[ (csv) ] when ;
|
[ (csv) ] when ;
|
||||||
|
|
||||||
: init-vars ( -- )
|
: init-vars ( -- )
|
||||||
delimiter> [ CHAR: , >delimiter ] unless ; inline
|
delimiter> [ CHAR: , >delimiter ] unless ; inline
|
||||||
|
|
||||||
: csv-row ( stream -- row )
|
: csv-row ( stream -- row )
|
||||||
init-vars
|
init-vars
|
||||||
|
@ -69,3 +69,24 @@ VAR: delimiter
|
||||||
|
|
||||||
: with-delimiter ( char quot -- )
|
: with-delimiter ( char quot -- )
|
||||||
delimiter swap with-variable ; inline
|
delimiter swap with-variable ; inline
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
: needs-escaping? ( cell -- ? )
|
||||||
|
[ "\n\"" delimiter> suffix member? ] contains? ; inline ! "
|
||||||
|
|
||||||
|
: escape-quotes ( cell -- cell' )
|
||||||
|
[ [ dup , CHAR: " = [ CHAR: " , ] when ] each ] "" make ; inline
|
||||||
|
|
||||||
|
: enclose-in-quotes ( cell -- cell' )
|
||||||
|
CHAR: " [ prefix ] [ suffix ] bi ; inline ! "
|
||||||
|
|
||||||
|
: escape-if-required ( cell -- cell' )
|
||||||
|
dup needs-escaping? [ escape-quotes enclose-in-quotes ] when ; inline
|
||||||
|
|
||||||
|
: write-row ( row -- )
|
||||||
|
[ delimiter> write1 ] [ escape-if-required write ] interleave nl ; inline
|
||||||
|
|
||||||
|
: write-csv ( rows outstream -- )
|
||||||
|
init-vars
|
||||||
|
[ [ write-row ] each ] with-output-stream ;
|
||||||
|
|
|
@ -155,12 +155,12 @@ irc-editor "general" f {
|
||||||
: <irc-tab> ( listener client -- irc-tab )
|
: <irc-tab> ( listener client -- irc-tab )
|
||||||
irc-tab new-frame
|
irc-tab new-frame
|
||||||
swap client>> >>client swap >>listener
|
swap client>> >>client swap >>listener
|
||||||
<irc-pane> [ <scroller> @center grid-add* ] keep
|
<irc-pane> [ <scroller> @center grid-add ] keep
|
||||||
<irc-editor> <scroller> @bottom grid-add* ;
|
<irc-editor> <scroller> @bottom grid-add ;
|
||||||
|
|
||||||
: <irc-channel-tab> ( listener client -- irc-tab )
|
: <irc-channel-tab> ( listener client -- irc-tab )
|
||||||
<irc-tab>
|
<irc-tab>
|
||||||
<irc-list> [ <scroller> @right grid-add* ] dip >>listmodel
|
<irc-list> [ <scroller> @right grid-add ] dip >>listmodel
|
||||||
[ update-participants ] keep ;
|
[ update-participants ] keep ;
|
||||||
|
|
||||||
: <irc-server-tab> ( listener client -- irc-tab )
|
: <irc-server-tab> ( listener client -- irc-tab )
|
||||||
|
|
|
@ -7,7 +7,7 @@ ARTICLE: "ui-frame-layout" "Frame layouts"
|
||||||
{ $subsection frame }
|
{ $subsection frame }
|
||||||
"Creating empty frames:"
|
"Creating empty frames:"
|
||||||
{ $subsection <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* } ":"
|
"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 } ":"
|
||||||
{ $subsection @center }
|
{ $subsection @center }
|
||||||
{ $subsection @left }
|
{ $subsection @left }
|
||||||
{ $subsection @right }
|
{ $subsection @right }
|
||||||
|
@ -20,7 +20,7 @@ ARTICLE: "ui-frame-layout" "Frame layouts"
|
||||||
|
|
||||||
: $ui-frame-constant ( element -- )
|
: $ui-frame-constant ( element -- )
|
||||||
drop
|
drop
|
||||||
{ $description "Symbolic constant for a common input to " { $link grid-add* } "." } print-element ;
|
{ $description "Symbolic constant for a common input to " { $link grid-add } "." } print-element ;
|
||||||
|
|
||||||
HELP: @center $ui-frame-constant ;
|
HELP: @center $ui-frame-constant ;
|
||||||
HELP: @left $ui-frame-constant ;
|
HELP: @left $ui-frame-constant ;
|
||||||
|
@ -35,7 +35,7 @@ HELP: @bottom-right $ui-frame-constant ;
|
||||||
HELP: frame
|
HELP: frame
|
||||||
{ $class-description "A frame is a gadget which lays out its children in a 3x3 grid. If the frame is enlarged past its preferred size, the center gadget fills up available room."
|
{ $class-description "A frame is a gadget which lays out its children in a 3x3 grid. If the frame is enlarged past its preferred size, the center gadget fills up available room."
|
||||||
$nl
|
$nl
|
||||||
"Frames are constructed by calling " { $link <frame> } " and since they inherit from " { $link grid } ", children can be managed with " { $link grid-add* } " and " { $link grid-remove } "." } ;
|
"Frames are constructed by calling " { $link <frame> } " and since they inherit from " { $link grid } ", children can be managed with " { $link grid-add } " and " { $link grid-remove } "." } ;
|
||||||
|
|
||||||
HELP: <frame>
|
HELP: <frame>
|
||||||
{ $values { "frame" frame } }
|
{ $values { "frame" frame } }
|
||||||
|
|
|
@ -7,7 +7,7 @@ ARTICLE: "ui-grid-layout" "Grid layouts"
|
||||||
"Creating grids from a fixed set of gadgets:"
|
"Creating grids from a fixed set of gadgets:"
|
||||||
{ $subsection <grid> }
|
{ $subsection <grid> }
|
||||||
"Managing chidren:"
|
"Managing chidren:"
|
||||||
{ $subsection grid-add* }
|
{ $subsection grid-add }
|
||||||
{ $subsection grid-remove }
|
{ $subsection grid-remove }
|
||||||
{ $subsection grid-child } ;
|
{ $subsection grid-child } ;
|
||||||
|
|
||||||
|
@ -18,7 +18,7 @@ $nl
|
||||||
$nl
|
$nl
|
||||||
"The " { $link grid-fill? } " slot stores a boolean, indicating if grid cells should assume their preferred size, or if they should fill the dimensions of the cell. The default is " { $link t } "."
|
"The " { $link grid-fill? } " slot stores a boolean, indicating if grid cells should assume their preferred size, or if they should fill the dimensions of the cell. The default is " { $link t } "."
|
||||||
$nl
|
$nl
|
||||||
"Grids are created by calling " { $link <grid> } " and children are managed with " { $link grid-add* } " and " { $link grid-remove } "."
|
"Grids are created by calling " { $link <grid> } " and children are managed with " { $link grid-add } " and " { $link grid-remove } "."
|
||||||
$nl
|
$nl
|
||||||
"The " { $link add-gadget } ", " { $link unparent } " and " { $link clear-gadget } " words should not be used to manage child gadgets of grids." } ;
|
"The " { $link add-gadget } ", " { $link unparent } " and " { $link clear-gadget } " words should not be used to manage child gadgets of grids." } ;
|
||||||
|
|
||||||
|
@ -31,7 +31,7 @@ HELP: grid-child
|
||||||
{ $description "Outputs the child gadget at the " { $snippet "i" } "," { $snippet "j" } "th position of the grid." }
|
{ $description "Outputs the child gadget at the " { $snippet "i" } "," { $snippet "j" } "th position of the grid." }
|
||||||
{ $errors "Throws an error if the indices are out of bounds." } ;
|
{ $errors "Throws an error if the indices are out of bounds." } ;
|
||||||
|
|
||||||
HELP: grid-add*
|
HELP: grid-add
|
||||||
{ $values { "gadget" gadget } { "grid" grid } { "i" "non-negative integer" } { "j" "non-negative integer" } }
|
{ $values { "gadget" gadget } { "grid" grid } { "i" "non-negative integer" } { "j" "non-negative integer" } }
|
||||||
{ $description "Adds a child gadget at the specified location." }
|
{ $description "Adds a child gadget at the specified location." }
|
||||||
{ $side-effects "grid" } ;
|
{ $side-effects "grid" } ;
|
||||||
|
|
|
@ -20,12 +20,12 @@ grid
|
||||||
|
|
||||||
: grid-child ( grid i j -- gadget ) rot grid>> nth nth ;
|
: grid-child ( grid i j -- gadget ) rot grid>> nth nth ;
|
||||||
|
|
||||||
: grid-add* ( grid child i j -- grid )
|
: grid-add ( grid child i j -- grid )
|
||||||
>r >r dupd swap r> r>
|
>r >r dupd swap r> r>
|
||||||
>r >r 2dup swap add-gadget drop r> r>
|
>r >r 2dup swap add-gadget drop r> r>
|
||||||
3dup grid-child unparent rot grid>> nth set-nth ;
|
3dup grid-child unparent rot grid>> nth set-nth ;
|
||||||
|
|
||||||
: grid-remove ( grid i j -- grid ) <gadget> -rot grid-add* ;
|
: grid-remove ( grid i j -- grid ) <gadget> -rot grid-add ;
|
||||||
|
|
||||||
: pref-dim-grid ( grid -- dims )
|
: pref-dim-grid ( grid -- dims )
|
||||||
grid>> [ [ pref-dim ] map ] map ;
|
grid>> [ [ pref-dim ] map ] map ;
|
||||||
|
|
|
@ -39,8 +39,8 @@ M: labelled-gadget focusable-child* labelled-gadget-content ;
|
||||||
|
|
||||||
: <title-bar> ( title quot -- gadget )
|
: <title-bar> ( title quot -- gadget )
|
||||||
<frame>
|
<frame>
|
||||||
swap dup [ <close-box> @left grid-add* ] [ drop ] if
|
swap dup [ <close-box> @left grid-add ] [ drop ] if
|
||||||
swap <title-label> @center grid-add* ;
|
swap <title-label> @center grid-add ;
|
||||||
|
|
||||||
TUPLE: closable-gadget < frame content ;
|
TUPLE: closable-gadget < frame content ;
|
||||||
|
|
||||||
|
@ -49,8 +49,8 @@ TUPLE: closable-gadget < frame content ;
|
||||||
|
|
||||||
: <closable-gadget> ( gadget title quot -- gadget )
|
: <closable-gadget> ( gadget title quot -- gadget )
|
||||||
closable-gadget new-frame
|
closable-gadget new-frame
|
||||||
-rot <title-bar> @top grid-add*
|
-rot <title-bar> @top grid-add
|
||||||
swap >>content
|
swap >>content
|
||||||
dup content>> @center grid-add* ;
|
dup content>> @center grid-add ;
|
||||||
|
|
||||||
M: closable-gadget focusable-child* closable-gadget-content ;
|
M: closable-gadget focusable-child* closable-gadget-content ;
|
||||||
|
|
|
@ -38,11 +38,11 @@ scroller H{
|
||||||
<scroller-model> >>model
|
<scroller-model> >>model
|
||||||
faint-boundary
|
faint-boundary
|
||||||
|
|
||||||
dup model>> dependencies>> first <x-slider> >>x dup x>> @bottom grid-add*
|
dup model>> dependencies>> first <x-slider> >>x dup x>> @bottom grid-add
|
||||||
dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add*
|
dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add
|
||||||
|
|
||||||
swap over model>> <viewport> >>viewport
|
swap over model>> <viewport> >>viewport
|
||||||
dup viewport>> @center grid-add* ;
|
dup viewport>> @center grid-add ;
|
||||||
|
|
||||||
: <scroller> ( gadget -- scroller ) scroller new-scroller ;
|
: <scroller> ( gadget -- scroller ) scroller new-scroller ;
|
||||||
|
|
||||||
|
|
|
@ -130,7 +130,7 @@ M: elevator layout*
|
||||||
tuck <elevator> >>elevator
|
tuck <elevator> >>elevator
|
||||||
swap <thumb> >>thumb
|
swap <thumb> >>thumb
|
||||||
dup elevator>> over thumb>> add-gadget
|
dup elevator>> over thumb>> add-gadget
|
||||||
@center grid-add* ;
|
@center grid-add ;
|
||||||
|
|
||||||
: <left-button> ( -- button ) { 0 1 } arrow-left -1 <slide-button> ;
|
: <left-button> ( -- button ) { 0 1 } arrow-left -1 <slide-button> ;
|
||||||
: <right-button> ( -- button ) { 0 1 } arrow-right 1 <slide-button> ;
|
: <right-button> ( -- button ) { 0 1 } arrow-right 1 <slide-button> ;
|
||||||
|
@ -145,15 +145,15 @@ M: elevator layout*
|
||||||
|
|
||||||
: <x-slider> ( range -- slider )
|
: <x-slider> ( range -- slider )
|
||||||
{ 1 0 } <slider>
|
{ 1 0 } <slider>
|
||||||
<left-button> @left grid-add*
|
<left-button> @left grid-add
|
||||||
{ 0 1 } elevator,
|
{ 0 1 } elevator,
|
||||||
<right-button> @right grid-add* ;
|
<right-button> @right grid-add ;
|
||||||
|
|
||||||
: <y-slider> ( range -- slider )
|
: <y-slider> ( range -- slider )
|
||||||
{ 0 1 } <slider>
|
{ 0 1 } <slider>
|
||||||
<up-button> @top grid-add*
|
<up-button> @top grid-add
|
||||||
{ 1 0 } elevator,
|
{ 1 0 } elevator,
|
||||||
<down-button> @bottom grid-add* ;
|
<down-button> @bottom grid-add ;
|
||||||
|
|
||||||
M: slider pref-dim*
|
M: slider pref-dim*
|
||||||
dup call-next-method
|
dup call-next-method
|
||||||
|
|
|
@ -15,8 +15,8 @@ DEFER: (del-page)
|
||||||
:: add-toggle ( model n name toggler -- )
|
:: add-toggle ( model n name toggler -- )
|
||||||
<frame>
|
<frame>
|
||||||
n name toggler parent>> '[ , , , (del-page) ] "X" swap <bevel-button>
|
n name toggler parent>> '[ , , , (del-page) ] "X" swap <bevel-button>
|
||||||
@right grid-add*
|
@right grid-add
|
||||||
n model name <toggle-button> @center grid-add*
|
n model name <toggle-button> @center grid-add
|
||||||
toggler swap add-gadget drop ;
|
toggler swap add-gadget drop ;
|
||||||
|
|
||||||
: redo-toggler ( tabbed -- )
|
: redo-toggler ( tabbed -- )
|
||||||
|
@ -52,10 +52,10 @@ DEFER: (del-page)
|
||||||
tabbed new-frame
|
tabbed new-frame
|
||||||
0 <model> >>model
|
0 <model> >>model
|
||||||
<pile> 1 >>fill >>toggler
|
<pile> 1 >>fill >>toggler
|
||||||
dup toggler>> @left grid-add*
|
dup toggler>> @left grid-add
|
||||||
swap
|
swap
|
||||||
[ keys >vector >>names ]
|
[ keys >vector >>names ]
|
||||||
[ values over model>> <book> >>content dup content>> @center grid-add* ]
|
[ values over model>> <book> >>content dup content>> @center grid-add ]
|
||||||
bi
|
bi
|
||||||
dup redo-toggler ;
|
dup redo-toggler ;
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue