From bc07c075e72bddfcf69cec4739ec54537c6408be Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 3 May 2009 17:23:14 -0500 Subject: [PATCH] Merge branch 'master' of git://factorcode.org/git/factor Conflicts: extra/spheres/spheres.factor --- basis/formatting/formatting.factor | 20 ++++++++-------- basis/literals/literals-tests.factor | 6 +++++ basis/literals/literals.factor | 4 +++- basis/windows/errors/errors.factor | 14 ++++++----- extra/file-trees/file-trees.factor | 15 ++++++++---- extra/spheres/spheres.factor | 14 +++++------ extra/str-fry/str-fry.factor | 7 ++++-- extra/ui/frp/frp-docs.factor | 2 +- extra/ui/frp/frp.factor | 36 +++++++++++++++++++--------- 9 files changed, 75 insertions(+), 43 deletions(-) diff --git a/basis/formatting/formatting.factor b/basis/formatting/formatting.factor index ac0b0850b4..5a517e4ac4 100644 --- a/basis/formatting/formatting.factor +++ b/basis/formatting/formatting.factor @@ -4,7 +4,7 @@ USING: accessors arrays ascii assocs calendar combinators fry kernel generalizations io io.encodings.ascii io.files io.streams.string macros math math.functions math.parser peg.ebnf quotations -sequences splitting strings unicode.case vectors ; +sequences splitting strings unicode.case vectors combinators.smart ; IN: formatting @@ -113,7 +113,6 @@ MACRO: printf ( format-string -- ) : sprintf ( format-string -- result ) [ printf ] with-string-writer ; inline - string 2 CHAR: 0 pad-head ; inline @@ -129,12 +128,15 @@ MACRO: printf ( format-string -- ) [ pad-00 ] map "/" join ; inline : >datetime ( timestamp -- string ) - { [ day-of-week day-abbreviation3 ] - [ month>> month-abbreviation ] - [ day>> pad-00 ] - [ >time ] - [ year>> number>string ] - } cleave 5 narray " " join ; inline + [ + { + [ day-of-week day-abbreviation3 ] + [ month>> month-abbreviation ] + [ day>> pad-00 ] + [ >time ] + [ year>> number>string ] + } cleave + ] output>array " " join ; inline : (week-of-year) ( timestamp day -- n ) [ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when @@ -187,5 +189,3 @@ PRIVATE> MACRO: strftime ( format-string -- ) parse-strftime [ length ] keep [ ] join '[ _ @ reverse concat nip ] ; - - diff --git a/basis/literals/literals-tests.factor b/basis/literals/literals-tests.factor index 024c94e4f2..29072f1299 100644 --- a/basis/literals/literals-tests.factor +++ b/basis/literals/literals-tests.factor @@ -19,3 +19,9 @@ IN: literals.tests [ { 0.5 2.0 } ] [ { $[ 1.0 2.0 / ] 2.0 } ] unit-test [ { 1.0 { 0.5 1.5 } 4.0 } ] [ { 1.0 { $[ 1.0 2.0 / ] 1.5 } $[ 2.0 2.0 * ] } ] unit-test + +<< +CONSTANT: constant-a 3 +>> + +[ { 3 10 "ftw" } ] [ ${ constant-a 10 "ftw" } ] unit-test diff --git a/basis/literals/literals.factor b/basis/literals/literals.factor index e55d78ab6e..7c7592dda8 100644 --- a/basis/literals/literals.factor +++ b/basis/literals/literals.factor @@ -1,6 +1,8 @@ ! (c) Joe Groff, see license for details -USING: accessors continuations kernel parser words quotations vectors ; +USING: accessors continuations kernel parser words quotations +combinators.smart vectors sequences ; IN: literals SYNTAX: $ scan-word [ def>> call ] curry with-datastack >vector ; SYNTAX: $[ parse-quotation with-datastack >vector ; +SYNTAX: ${ \ } [ [ ?execute ] { } map-as ] parse-literal ; diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor index e08704d469..d180cb20e7 100644 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -1,7 +1,7 @@ USING: alien.c-types kernel locals math math.bitwise windows.kernel32 sequences byte-arrays unicode.categories io.encodings.string io.encodings.utf16n alien.strings -arrays ; +arrays literals ; IN: windows.errors CONSTANT: ERROR_SUCCESS 0 @@ -732,11 +732,13 @@ ERROR: error-message-failed id ; win32-error-string throw ] when ; -: expected-io-errors ( -- seq ) - ERROR_SUCCESS - ERROR_IO_INCOMPLETE - ERROR_IO_PENDING - WAIT_TIMEOUT 4array ; foldable +CONSTANT: expected-io-errors + ${ + ERROR_SUCCESS + ERROR_IO_INCOMPLETE + ERROR_IO_PENDING + WAIT_TIMEOUT + } : expected-io-error? ( error-code -- ? ) expected-io-errors member? ; diff --git a/extra/file-trees/file-trees.factor b/extra/file-trees/file-trees.factor index 788291c0a2..eadfccdc4c 100644 --- a/extra/file-trees/file-trees.factor +++ b/extra/file-trees/file-trees.factor @@ -1,10 +1,10 @@ -USING: accessors delegate delegate.protocols io.pathnames -kernel locals namespaces sequences vectors -tools.annotations prettyprint ; +USING: accessors arrays delegate delegate.protocols +io.pathnames kernel locals namespaces prettyprint sequences +ui.frp vectors ; IN: file-trees TUPLE: tree node children ; -CONSULT: sequence-protocol tree children>> [ node>> ] map ; +CONSULT: sequence-protocol tree children>> ; : ( start -- tree ) V{ } clone [ tree boa dup children>> ] [ ".." swap tree boa ] bi swap push ; @@ -20,4 +20,9 @@ DEFER: (tree-insert) path-rest [ path-head tree-insert ] unless-empty ] if* ; : create-tree ( file-list -- tree ) [ path-components ] map - t [ [ tree-insert ] curry each ] keep ; \ No newline at end of file + t [ [ tree-insert ] curry each ] keep ; + +: ( tree-model -- table ) + [ node>> 1array ] >>quot + [ selected-value>> ] + [ swap >>model ] bi ; \ No newline at end of file diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor index 708d6c68dd..671edf38ce 100755 --- a/extra/spheres/spheres.factor +++ b/extra/spheres/spheres.factor @@ -134,13 +134,13 @@ M: spheres-world distance-step ( gadget -- dz ) GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_R GL_CLAMP glTexParameteri - { - $ GL_TEXTURE_CUBE_MAP_POSITIVE_X - $ GL_TEXTURE_CUBE_MAP_POSITIVE_Y - $ GL_TEXTURE_CUBE_MAP_POSITIVE_Z - $ GL_TEXTURE_CUBE_MAP_NEGATIVE_X - $ GL_TEXTURE_CUBE_MAP_NEGATIVE_Y - $ GL_TEXTURE_CUBE_MAP_NEGATIVE_Z + ${ + GL_TEXTURE_CUBE_MAP_POSITIVE_X + GL_TEXTURE_CUBE_MAP_POSITIVE_Y + GL_TEXTURE_CUBE_MAP_POSITIVE_Z + GL_TEXTURE_CUBE_MAP_NEGATIVE_X + GL_TEXTURE_CUBE_MAP_NEGATIVE_Y + GL_TEXTURE_CUBE_MAP_NEGATIVE_Z } [ 0 GL_RGBA8 (reflection-dim) 0 GL_RGBA GL_UNSIGNED_BYTE f glTexImage2D ] each diff --git a/extra/str-fry/str-fry.factor b/extra/str-fry/str-fry.factor index aafdaa95d9..bfe74f37eb 100644 --- a/extra/str-fry/str-fry.factor +++ b/extra/str-fry/str-fry.factor @@ -1,4 +1,7 @@ -USING: kernel sequences splitting strings.parser ; +USING: combinators effects kernel math sequences splitting +strings.parser ; IN: str-fry -: str-fry ( str -- quot ) "_" split unclip [ [ rot glue ] reduce ] 2curry ; +: str-fry ( str -- quot ) "_" split + [ unclip [ [ rot glue ] reduce ] 2curry ] + [ length 1 - 1 [ call-effect ] 2curry ] bi ; SYNTAX: I" parse-string rest str-fry over push-all ; \ No newline at end of file diff --git a/extra/ui/frp/frp-docs.factor b/extra/ui/frp/frp-docs.factor index af44567e46..479a56e513 100644 --- a/extra/ui/frp/frp-docs.factor +++ b/extra/ui/frp/frp-docs.factor @@ -36,7 +36,7 @@ HELP: { $values { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } { "model'" model } } { $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ; -HELP: switch +HELP: { $values { "signal1" model } { "signal2" model } { "signal'" model } } { $description "Creates a model that starts with the behavior of model1 and switches to the behavior of model2 on its update" } ; diff --git a/extra/ui/frp/frp.factor b/extra/ui/frp/frp.factor index aa7c44ee03..699d034c72 100644 --- a/extra/ui/frp/frp.factor +++ b/extra/ui/frp/frp.factor @@ -1,7 +1,7 @@ -USING: accessors arrays colors fonts fry kernel models +USING: accessors arrays colors fonts kernel models models.product monads sequences ui.gadgets ui.gadgets.buttons ui.gadgets.editors ui.gadgets.line-support ui.gadgets.tables -ui.gadgets.tracks ui.render ; +ui.gadgets.tracks ui.render ui.gadgets.scrollers ; QUALIFIED: make IN: ui.frp @@ -18,8 +18,11 @@ M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ; frp-table new-line-gadget dup >>renderer [ ] >>quot swap >>model f >>selected-value sans-serif-font >>font focus-border-color >>focus-border-color - transparent >>column-line-color ; + transparent >>column-line-color [ ] >>val-quot ; +: ( -- table ) f ; : ( model -- table ) [ 1array ] >>quot ; +: ( -- table ) f ; + : ( -- field ) f ; ! Layout utilities @@ -27,6 +30,8 @@ M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ; GENERIC: output-model ( gadget -- model ) M: gadget output-model model>> ; M: frp-table output-model selected-value>> ; +M: model-field output-model field-model>> ; +M: scroller output-model children>> first model>> ; GENERIC: , ( uiitem -- ) M: gadget , make:, ; @@ -41,13 +46,16 @@ M: table -> dup , selected-value>> ; [ { } make:make ] dip swap [ f track-add ] each ; inline : ( gadgets type -- track ) [ ] [ [ model>> ] map ] bi >>model ; inline : ( gadgets -- track ) horizontal ; inline +: ( gadgets -- track ) horizontal ; inline : ( gadgets -- track ) vertical ; inline +: ( gadgets -- track ) vertical ; inline -! Model utilities +! !!! Model utilities TUPLE: multi-model < model ; -! M: multi-model model-activated dup model-changed ; : ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ; +! Events- discrete model utilities + TUPLE: merge-model < multi-model ; M: merge-model model-changed [ value>> ] dip set-model ; : ( models -- model ) merge-model ; @@ -57,15 +65,21 @@ M: filter-model model-changed [ value>> ] dip [ quot>> call( val -- bool ) ] 2ke [ set-model ] [ 2drop ] if ; : ( model quot -- filter-model ) [ 1array filter-model ] dip >>quot ; +! Behaviors - continuous model utilities + TUPLE: fold-model < multi-model oldval quot ; M: fold-model model-changed [ [ value>> ] [ [ oldval>> ] [ quot>> ] bi ] bi* call( val oldval -- newval ) ] keep set-model ; -: ( oldval quot model -- model' ) 1array fold-model swap >>quot swap >>oldval ; +: ( oldval quot model -- model' ) 1array fold-model swap >>quot + swap [ >>oldval ] [ >>value ] bi ; -TUPLE: switch-model < multi-model switcher on ; -M: switch-model model-changed tuck [ switcher>> = ] 2keep - '[ on>> [ _ value>> _ set-model ] when ] [ t swap (>>on) ] if ; -: switch ( signal1 signal2 -- signal' ) [ 2array switch-model ] keep >>switcher ; +TUPLE: switch-model < multi-model original switcher on ; +M: switch-model model-changed 2dup switcher>> = + [ over value>> [ [ value>> ] [ t >>on ] bi* set-model ] [ 2drop ] if ] + [ dup on>> [ 2drop ] [ [ value>> ] dip set-model ] if ] if ; +M: switch-model model-activated [ original>> ] keep model-changed ; +: ( signal1 signal2 -- signal' ) [ 2array switch-model ] 2keep + [ >>original ] [ >>switcher ] bi* ; TUPLE: mapped < model model quot ; @@ -87,4 +101,4 @@ INSTANCE: gadget-monad monad INSTANCE: gadget monad M: gadget monad-of drop gadget-monad ; M: gadget-monad return drop swap >>model ; -M: gadget >>= model>> '[ _ swap call( x -- y ) ] ; \ No newline at end of file +M: gadget >>= output-model [ swap call( x -- y ) ] curry ; \ No newline at end of file