steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://github.com/bogiebro/factor

db4
Doug Coleman 2009-05-03 12:57:16 -05:00
parent fa524ce213 0ca6a6c63f
commit c8dd655934
4 changed files with 41 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
extra/file-trees/file-trees.factor
View File

@ -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>> ;
: <tree> ( start -- tree ) V{ } clone
[ tree boa dup children>> ] [ ".." swap tree boa ] bi swap push ;
@ -21,3 +21,8 @@ DEFER: (tree-insert)
] if* ;
: create-tree ( file-list -- tree ) [ path-components ] map
t <tree> [ [ tree-insert ] curry each ] keep ;
: <dir-table> ( tree-model -- table )
<frp-list*> [ node>> 1array ] >>quot
[ selected-value>> <switch> ]
[ swap >>model ] bi ;

7
extra/str-fry/str-fry.factor
View File

@ -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 <effect> [ call-effect ] 2curry ] bi ;
SYNTAX: I" parse-string rest str-fry over push-all ;

2
extra/ui/frp/frp-docs.factor
View File

@ -36,7 +36,7 @@ HELP: <fold>
{ $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: <switch>
{ $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" } ;

36
extra/ui/frp/frp.factor
View File

@ -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 <model> >>selected-value sans-serif-font >>font
focus-border-color >>focus-border-color
transparent >>column-line-color ;
transparent >>column-line-color [ ] >>val-quot ;
: <frp-table*> ( -- table ) f <model> <frp-table> ;
: <frp-list> ( model -- table ) <frp-table> [ 1array ] >>quot ;
: <frp-list*> ( -- table ) f <model> <frp-list> ;
: <frp-field> ( -- field ) f <model> <model-field> ;
! 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 <track> swap [ f track-add ] each ; inline
: <box*> ( gadgets type -- track ) [ <box> ] [ [ model>> ] map <product> ] bi >>model ; inline
: <hbox> ( gadgets -- track ) horizontal <box> ; inline
: <hbox*> ( gadgets -- track ) horizontal <box*> ; inline
: <vbox> ( gadgets -- track ) vertical <box> ; inline
: <vbox*> ( gadgets -- track ) vertical <box*> ; inline
! Model utilities
! !!! Model utilities
TUPLE: multi-model < model ;
! M: multi-model model-activated dup model-changed ;
: <multi-model> ( 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 ;
: <merge> ( models -- model ) merge-model <multi-model> ;
@ -57,15 +65,21 @@ M: filter-model model-changed [ value>> ] dip [ quot>> call( val -- bool ) ] 2ke
[ set-model ] [ 2drop ] if ;
: <filter> ( model quot -- filter-model ) [ 1array filter-model <multi-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 ;
: <fold> ( oldval quot model -- model' ) 1array fold-model <multi-model> swap >>quot swap >>oldval ;
: <fold> ( oldval quot model -- model' ) 1array fold-model <multi-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 <multi-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 ;
: <switch> ( signal1 signal2 -- signal' ) [ 2array switch-model <multi-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 <gadget> swap >>model ;
M: gadget >>= model>> '[ _ swap call( x -- y ) ] ;
M: gadget >>= output-model [ swap call( x -- y ) ] curry ;