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
|
||||
! using the host image's hashing algorithms
|
||||
[ hashtable? ] instances [ rehash ] each
|
||||
! using the host image's hashing algorithms. We don't
|
||||
! 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
|
||||
] %
|
||||
|
||||
|
|
|
@ -14,13 +14,13 @@ big-endian on
|
|||
: ds-reg 14 ;
|
||||
: 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 ;
|
||||
|
||||
: next-save stack-frame bootstrap-cell - ;
|
||||
: xt-save stack-frame 2 bootstrap-cells - ;
|
||||
: next-save ( -- n ) stack-frame bootstrap-cell - ;
|
||||
: xt-save ( -- n ) stack-frame 2 bootstrap-cells - ;
|
||||
|
||||
[
|
||||
0 6 LOAD32
|
||||
|
|
|
@ -3,8 +3,8 @@
|
|||
USING: parser layouts system kernel ;
|
||||
IN: bootstrap.ppc
|
||||
|
||||
: c-area-size 10 bootstrap-cells ;
|
||||
: lr-save bootstrap-cell ;
|
||||
: c-area-size ( -- n ) 10 bootstrap-cells ;
|
||||
: lr-save ( -- n ) bootstrap-cell ;
|
||||
|
||||
<< "resource:core/cpu/ppc/bootstrap.factor" parse-file parsed >>
|
||||
call
|
||||
|
|
|
@ -3,8 +3,8 @@
|
|||
USING: parser layouts system kernel ;
|
||||
IN: bootstrap.ppc
|
||||
|
||||
: c-area-size 14 bootstrap-cells ;
|
||||
: lr-save 2 bootstrap-cells ;
|
||||
: c-area-size ( -- n ) 14 bootstrap-cells ;
|
||||
: lr-save ( -- n ) 2 bootstrap-cells ;
|
||||
|
||||
<< "resource:core/cpu/ppc/bootstrap.factor" parse-file parsed >>
|
||||
call
|
||||
|
|
|
@ -23,3 +23,6 @@ TUPLE: testing x y z ;
|
|||
] when*
|
||||
] each
|
||||
] 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.
|
||||
USING: kernel continuations sequences arrays system ;
|
||||
IN: memory
|
||||
USING: arrays kernel sequences vectors system hashtables
|
||||
kernel.private sbufs growable assocs namespaces quotations
|
||||
math strings combinators ;
|
||||
|
||||
: (each-object) ( quot: ( obj -- ) -- )
|
||||
[ next-object dup ] swap [ drop ] while ; inline
|
||||
|
||||
: each-object ( quot -- )
|
||||
begin-scan (each-object) end-scan ; inline
|
||||
begin-scan [ (each-object) ] [ end-scan ] [ ] cleanup ; inline
|
||||
|
||||
: instances ( quot -- seq )
|
||||
pusher >r each-object r> >array ; inline
|
||||
pusher [ each-object ] dip >array ; inline
|
||||
|
||||
: save ( -- ) image save-image ;
|
||||
|
|
|
@ -72,13 +72,13 @@ DEFER: automata-window
|
|||
"5 - Random Rule" [ random-rule ] view-button add-gadget
|
||||
"n - New" [ automata-window ] view-button add-gadget
|
||||
|
||||
@top grid-add*
|
||||
@top grid-add
|
||||
|
||||
C[ display ] <slate>
|
||||
{ 400 400 } >>pdim
|
||||
dup >slate
|
||||
|
||||
@center grid-add*
|
||||
@center grid-add
|
||||
|
||||
<handler>
|
||||
|
||||
|
|
|
@ -100,14 +100,7 @@ VARS: population-label cohesion-label alignment-label separation-label ;
|
|||
: boids-window* ( -- )
|
||||
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 >cohesion-label update-cohesion-label
|
||||
"" <label> reverse-video-theme >alignment-label update-alignment-label
|
||||
"" <label> reverse-video-theme >separation-label update-separation-label
|
||||
|
@ -116,55 +109,58 @@ VARS: population-label cohesion-label alignment-label separation-label ;
|
|||
|
||||
<shelf>
|
||||
|
||||
{
|
||||
[ "ESC - Pause" [ drop toggle-loop ] button* ]
|
||||
1 >>fill
|
||||
|
||||
[ "1 - Randomize" [ drop randomize ] button* ]
|
||||
"ESC - Pause" [ drop toggle-loop ] button* add-gadget
|
||||
|
||||
[ <pile> 1 over set-pack-fill
|
||||
"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 ]
|
||||
"2 - Sub 10" [ drop sub-10-boids ] button* add-gadget
|
||||
add-gadget
|
||||
|
||||
[ <pile> 1 over set-pack-fill
|
||||
<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 ]
|
||||
"a - -0.1" [ drop dec-cohesion-weight ] button* add-gadget
|
||||
add-gadget
|
||||
|
||||
[ <pile> 1 over set-pack-fill
|
||||
<pile> 1 over set-pack-fill
|
||||
alignment-label> add-gadget
|
||||
"w - +0.1" [ drop inc-alignment-weight ] button* add-gadget
|
||||
"s - -0.1" [ drop dec-alignment-weight ] 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
|
||||
separation-label> add-gadget
|
||||
"e - +0.1" [ drop inc-separation-weight ] button* add-gadget
|
||||
"d - -0.1" [ drop dec-separation-weight ] button* add-gadget ]
|
||||
"d - -0.1" [ drop dec-separation-weight ] button* add-gadget
|
||||
add-gadget
|
||||
|
||||
} [ call ] map [ add-gadget ] each
|
||||
1 over set-pack-fill
|
||||
@top grid-add*
|
||||
@top grid-add
|
||||
|
||||
slate> @center grid-add*
|
||||
C[ display ] <slate>
|
||||
dup >slate
|
||||
t >>clipped?
|
||||
{ 600 400 } >>pdim
|
||||
C[ [ run ] in-thread ] >>graft
|
||||
C[ loop off ] >>ungraft
|
||||
@center grid-add
|
||||
|
||||
<handler>
|
||||
|
||||
H{ } clone
|
||||
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 "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 "w" } C[ drop inc-alignment-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 "d" } C[ drop dec-separation-weight ] is
|
||||
|
||||
T{ key-down f f "ESC" } C[ drop toggle-loop ] is
|
||||
|
||||
>>table
|
||||
|
||||
"Boids" open-window ;
|
||||
|
|
|
@ -37,11 +37,11 @@ M: color-preview model-changed
|
|||
<frame>
|
||||
<color-sliders>
|
||||
swap dup
|
||||
[ @top grid-add* ]
|
||||
[ <color-model> <color-preview> @center grid-add* ]
|
||||
[ @top grid-add ]
|
||||
[ <color-model> <color-preview> @center grid-add ]
|
||||
[
|
||||
[ [ truncate number>string ] map " " join ] <filter> <label-control>
|
||||
@bottom grid-add*
|
||||
@bottom grid-add
|
||||
]
|
||||
tri* ;
|
||||
|
||||
|
|
|
@ -2,20 +2,27 @@ USING: help.syntax help.markup kernel prettyprint sequences ;
|
|||
IN: csv
|
||||
|
||||
HELP: csv
|
||||
{ $values { "stream" "a stream" }
|
||||
{ $values { "stream" "an input stream" }
|
||||
{ "rows" "an array of arrays of fields" } }
|
||||
{ $description "parses a csv stream into an array of row arrays"
|
||||
} ;
|
||||
|
||||
HELP: csv-row
|
||||
{ $values { "stream" "a stream" }
|
||||
{ $values { "stream" "an input stream" }
|
||||
{ "row" "an array of fields" } }
|
||||
{ $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
|
||||
{ $values { "char" "field delimiter (e.g. CHAR: \t)" }
|
||||
{ "quot" "a quotation" } }
|
||||
{ $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
|
||||
USING: io.streams.string csv tools.test shuffle kernel strings ;
|
||||
|
||||
! I like to name my unit tests
|
||||
: named-unit-test ( name output input -- )
|
||||
|
@ -68,3 +68,11 @@ IN: csv.tests
|
|||
[ { { "foo" "bar" }
|
||||
{ "1" "2" } } ]
|
||||
[ "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 ! "
|
||||
|
|
|
@ -69,3 +69,24 @@ VAR: delimiter
|
|||
|
||||
: with-delimiter ( char quot -- )
|
||||
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 new-frame
|
||||
swap client>> >>client swap >>listener
|
||||
<irc-pane> [ <scroller> @center grid-add* ] keep
|
||||
<irc-editor> <scroller> @bottom grid-add* ;
|
||||
<irc-pane> [ <scroller> @center grid-add ] keep
|
||||
<irc-editor> <scroller> @bottom grid-add ;
|
||||
|
||||
: <irc-channel-tab> ( listener client -- irc-tab )
|
||||
<irc-tab>
|
||||
<irc-list> [ <scroller> @right grid-add* ] dip >>listmodel
|
||||
<irc-list> [ <scroller> @right grid-add ] dip >>listmodel
|
||||
[ update-participants ] keep ;
|
||||
|
||||
: <irc-server-tab> ( listener client -- irc-tab )
|
||||
|
|
|
@ -7,7 +7,7 @@ ARTICLE: "ui-frame-layout" "Frame layouts"
|
|||
{ $subsection frame }
|
||||
"Creating empty frames:"
|
||||
{ $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 @left }
|
||||
{ $subsection @right }
|
||||
|
@ -20,7 +20,7 @@ ARTICLE: "ui-frame-layout" "Frame layouts"
|
|||
|
||||
: $ui-frame-constant ( element -- )
|
||||
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: @left $ui-frame-constant ;
|
||||
|
@ -35,7 +35,7 @@ HELP: @bottom-right $ui-frame-constant ;
|
|||
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."
|
||||
$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>
|
||||
{ $values { "frame" frame } }
|
||||
|
|
|
@ -7,7 +7,7 @@ ARTICLE: "ui-grid-layout" "Grid layouts"
|
|||
"Creating grids from a fixed set of gadgets:"
|
||||
{ $subsection <grid> }
|
||||
"Managing chidren:"
|
||||
{ $subsection grid-add* }
|
||||
{ $subsection grid-add }
|
||||
{ $subsection grid-remove }
|
||||
{ $subsection grid-child } ;
|
||||
|
||||
|
@ -18,7 +18,7 @@ $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 } "."
|
||||
$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
|
||||
"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." }
|
||||
{ $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" } }
|
||||
{ $description "Adds a child gadget at the specified location." }
|
||||
{ $side-effects "grid" } ;
|
||||
|
|
|
@ -20,12 +20,12 @@ grid
|
|||
|
||||
: 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 2dup swap add-gadget drop r> r>
|
||||
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 )
|
||||
grid>> [ [ pref-dim ] map ] map ;
|
||||
|
|
|
@ -39,8 +39,8 @@ M: labelled-gadget focusable-child* labelled-gadget-content ;
|
|||
|
||||
: <title-bar> ( title quot -- gadget )
|
||||
<frame>
|
||||
swap dup [ <close-box> @left grid-add* ] [ drop ] if
|
||||
swap <title-label> @center grid-add* ;
|
||||
swap dup [ <close-box> @left grid-add ] [ drop ] if
|
||||
swap <title-label> @center grid-add ;
|
||||
|
||||
TUPLE: closable-gadget < frame content ;
|
||||
|
||||
|
@ -49,8 +49,8 @@ TUPLE: closable-gadget < frame content ;
|
|||
|
||||
: <closable-gadget> ( gadget title quot -- gadget )
|
||||
closable-gadget new-frame
|
||||
-rot <title-bar> @top grid-add*
|
||||
-rot <title-bar> @top grid-add
|
||||
swap >>content
|
||||
dup content>> @center grid-add* ;
|
||||
dup content>> @center grid-add ;
|
||||
|
||||
M: closable-gadget focusable-child* closable-gadget-content ;
|
||||
|
|
|
@ -38,11 +38,11 @@ scroller H{
|
|||
<scroller-model> >>model
|
||||
faint-boundary
|
||||
|
||||
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>> first <x-slider> >>x dup x>> @bottom grid-add
|
||||
dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add
|
||||
|
||||
swap over model>> <viewport> >>viewport
|
||||
dup viewport>> @center grid-add* ;
|
||||
dup viewport>> @center grid-add ;
|
||||
|
||||
: <scroller> ( gadget -- scroller ) scroller new-scroller ;
|
||||
|
||||
|
|
|
@ -130,7 +130,7 @@ M: elevator layout*
|
|||
tuck <elevator> >>elevator
|
||||
swap <thumb> >>thumb
|
||||
dup elevator>> over thumb>> add-gadget
|
||||
@center grid-add* ;
|
||||
@center grid-add ;
|
||||
|
||||
: <left-button> ( -- button ) { 0 1 } arrow-left -1 <slide-button> ;
|
||||
: <right-button> ( -- button ) { 0 1 } arrow-right 1 <slide-button> ;
|
||||
|
@ -145,15 +145,15 @@ M: elevator layout*
|
|||
|
||||
: <x-slider> ( range -- slider )
|
||||
{ 1 0 } <slider>
|
||||
<left-button> @left grid-add*
|
||||
<left-button> @left grid-add
|
||||
{ 0 1 } elevator,
|
||||
<right-button> @right grid-add* ;
|
||||
<right-button> @right grid-add ;
|
||||
|
||||
: <y-slider> ( range -- slider )
|
||||
{ 0 1 } <slider>
|
||||
<up-button> @top grid-add*
|
||||
<up-button> @top grid-add
|
||||
{ 1 0 } elevator,
|
||||
<down-button> @bottom grid-add* ;
|
||||
<down-button> @bottom grid-add ;
|
||||
|
||||
M: slider pref-dim*
|
||||
dup call-next-method
|
||||
|
|
|
@ -15,8 +15,8 @@ DEFER: (del-page)
|
|||
:: 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*
|
||||
@right grid-add
|
||||
n model name <toggle-button> @center grid-add
|
||||
toggler swap add-gadget drop ;
|
||||
|
||||
: redo-toggler ( tabbed -- )
|
||||
|
@ -52,10 +52,10 @@ DEFER: (del-page)
|
|||
tabbed new-frame
|
||||
0 <model> >>model
|
||||
<pile> 1 >>fill >>toggler
|
||||
dup toggler>> @left grid-add*
|
||||
dup toggler>> @left grid-add
|
||||
swap
|
||||
[ keys >vector >>names ]
|
||||
[ values over model>> <book> >>content dup content>> @center grid-add* ]
|
||||
[ values over model>> <book> >>content dup content>> @center grid-add ]
|
||||
bi
|
||||
dup redo-toggler ;
|
||||
|
||||
|
|
Loading…
Reference in New Issue