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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2008-07-13 19:10:53 -05:00
parent 9df1363d5b cd6a559258
commit 7f32b1f93f
9 changed files with 70 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
extra/boids/ui/ui.factor
View File

@ -114,6 +114,8 @@ VARS: population-label cohesion-label alignment-label separation-label ;
<frame> <frame>
<shelf>
{ {
[ "ESC - Pause" [ drop toggle-loop ] button* ] [ "ESC - Pause" [ drop toggle-loop ] button* ]
@ -139,7 +141,7 @@ VARS: population-label cohesion-label alignment-label separation-label ;
"e - +0.1" [ drop inc-separation-weight ] button* 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 ]
} [ call ] map [ [ gadget, ] each ] make-shelf } [ call ] map [ add-gadget ] each
1 over set-pack-fill 1 over set-pack-fill
over @top grid-add over @top grid-add

8
extra/color-picker/color-picker.factor
View File

@ -15,7 +15,8 @@ TUPLE: color-preview < gadget ;
: <color-preview> ( model -- gadget ) : <color-preview> ( model -- gadget )
color-preview new-gadget color-preview new-gadget
{ 100 100 } over set-rect-dim ; swap >>model
{ 100 100 } >>dim ;
M: color-preview model-changed M: color-preview model-changed
swap model-value over set-gadget-interior relayout-1 ; swap model-value over set-gadget-interior relayout-1 ;
@ -26,7 +27,10 @@ M: color-preview model-changed
: <color-sliders> ( -- model gadget ) : <color-sliders> ( -- model gadget )
3 [ 0 0 0 255 <range> ] replicate 3 [ 0 0 0 255 <range> ] replicate
dup [ range-model ] map <compose> dup [ range-model ] map <compose>
swap [ [ <color-slider> gadget, ] each ] make-filled-pile ; swap
<filled-pile>
swap
[ <color-slider> add-gadget ] each ;
: <color-picker> ( -- gadget ) : <color-picker> ( -- gadget )
[ [

29
extra/lsys/ui/ui.factor
View File

@ -17,7 +17,7 @@ USING: kernel namespaces threads math math.order math.vectors
self pos ori turtle opengl.camera self pos ori turtle opengl.camera
lsys.tortoise lsys.tortoise.graphics lsys.tortoise lsys.tortoise.graphics
lsys.strings.rewrite lsys.strings.interpret lsys.strings.rewrite lsys.strings.interpret
combinators.short-circuit ; combinators.short-circuit accessors ;
! lsys.strings ! lsys.strings
! lsys.strings.rewrite ! lsys.strings.rewrite
@ -99,6 +99,8 @@ DEFER: empty-model
: lsys-controller ( -- ) : lsys-controller ( -- )
<pile>
{ {
[ "Load" <label> reverse-video-theme ] [ "Load" <label> reverse-video-theme ]
@ -145,9 +147,11 @@ DEFER: empty-model
[ pos> norm reset-turtle 45 turn-left 45 pitch-up step-turtle 180 turn-left ] [ pos> norm reset-turtle 45 turn-left 45 pitch-up step-turtle 180 turn-left ]
camera-action <bevel-button> ] camera-action <bevel-button> ]
} make* }
[ [ gadget, ] curry ] map concat ! Hack
make-pile 1 over set-pack-fill "L-system control" open-window ; [ call add-gadget ] each
1 >>fill
"L-system control" open-window ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -469,7 +473,7 @@ H{ } >rules ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: model-chooser ( -- ) : model-chooser ( -- )
<pile>
{ {
[ "abop-1" <label> [ drop abop-1 build-model ] closed-quot <bevel-button> ] [ "abop-1" <label> [ drop abop-1 build-model ] closed-quot <bevel-button> ]
[ "abop-2" <label> [ drop abop-2 build-model ] closed-quot <bevel-button> ] [ "abop-2" <label> [ drop abop-2 build-model ] closed-quot <bevel-button> ]
@ -481,18 +485,21 @@ H{ } >rules ;
[ "airhorse" <label> [ drop airhorse build-model ] closed-quot <bevel-button> ] [ "airhorse" <label> [ drop airhorse build-model ] closed-quot <bevel-button> ]
[ "spiral-0" <label> [ drop spiral-0 build-model ] closed-quot <bevel-button> ] [ "spiral-0" <label> [ drop spiral-0 build-model ] closed-quot <bevel-button> ]
[ "koch" <label> [ drop koch build-model ] closed-quot <bevel-button> ] [ "koch" <label> [ drop koch build-model ] closed-quot <bevel-button> ]
} make* }
[ [ gadget, ] curry ] map concat ! Hack [ call add-gadget ] each
make-pile 1 over set-pack-fill "L-system models" open-window ; 1 >>fill
"L-system models" open-window ;
: scene-chooser ( -- ) : scene-chooser ( -- )
<pile>
{ {
[ "abop-1" <label> [ drop abop-1-scene ] closed-quot <bevel-button> ] [ "abop-1" <label> [ drop abop-1-scene ] closed-quot <bevel-button> ]
[ "abop-2" <label> [ drop abop-2-scene ] closed-quot <bevel-button> ] [ "abop-2" <label> [ drop abop-2-scene ] closed-quot <bevel-button> ]
[ "tree-5" <label> [ drop tree-5-scene ] closed-quot <bevel-button> ] [ "tree-5" <label> [ drop tree-5-scene ] closed-quot <bevel-button> ]
} make* }
[ [ gadget, ] curry ] map concat ! Hack [ call add-gadget ] each
make-pile 1 over set-pack-fill "L-system scenes" open-window ; 1 >>fill
"L-system scenes" open-window ;
: lsys-window* ( -- ) : lsys-window* ( -- )
[ lsys-controller lsys-viewer ] with-ui ; [ lsys-controller lsys-viewer ] with-ui ;

12
extra/nehe/nehe.factor
View File

@ -4,12 +4,12 @@ IN: nehe
: nehe-window ( -- ) : nehe-window ( -- )
[ [
[ <filled-pile>
"Nehe 2" [ drop run2 ] <bevel-button> gadget, "Nehe 2" [ drop run2 ] <bevel-button> add-gadget
"Nehe 3" [ drop run3 ] <bevel-button> gadget, "Nehe 3" [ drop run3 ] <bevel-button> add-gadget
"Nehe 4" [ drop run4 ] <bevel-button> gadget, "Nehe 4" [ drop run4 ] <bevel-button> add-gadget
"Nehe 5" [ drop run5 ] <bevel-button> gadget, "Nehe 5" [ drop run5 ] <bevel-button> add-gadget
] make-filled-pile "Nehe examples" open-window "Nehe examples" open-window
] with-ui ; ] with-ui ;
MAIN: nehe-window MAIN: nehe-window

37
extra/ui/gadgets/buttons/buttons.factor
View File

@ -1,12 +1,13 @@
! Copyright (C) 2005, 2008 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: accessors arrays kernel math models namespaces sequences USING: accessors arrays kernel math models namespaces sequences
strings quotations assocs combinators classes colors strings quotations assocs combinators classes colors
classes.tuple opengl math.vectors classes.tuple opengl math.vectors
ui.commands ui.gadgets ui.gadgets.borders ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.labels ui.gadgets.theme ui.gadgets.labels ui.gadgets.theme
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
ui.render math.geometry.rect ; ui.render math.geometry.rect ;
IN: ui.gadgets.buttons IN: ui.gadgets.buttons
TUPLE: button < border pressed? selected? quot ; TUPLE: button < border pressed? selected? quot ;
@ -187,9 +188,9 @@ M: radio-control model-changed
over set-button-selected? over set-button-selected?
relayout-1 ; relayout-1 ;
: <radio-controls> ( model assoc quot -- ) : <radio-controls> ( parent model assoc quot -- parent )
#! quot has stack effect ( value model label -- ) #! quot has stack effect ( value model label -- )
swapd [ swapd call gadget, ] 2curry assoc-each ; inline swapd [ swapd call add-gadget ] 2curry assoc-each ; inline
: radio-button-theme ( gadget -- gadget ) : radio-button-theme ( gadget -- gadget )
{ 5 5 } >>gap { 5 5 } >>gap
@ -202,14 +203,18 @@ M: radio-control model-changed
{ 5 5 } >>gap drop ; { 5 5 } >>gap drop ;
: <radio-buttons> ( model assoc -- gadget ) : <radio-buttons> ( model assoc -- gadget )
[ [ <radio-button> ] <radio-controls> ] make-filled-pile <filled-pile>
dup radio-buttons-theme ; -rot
[ <radio-button> ] <radio-controls>
dup radio-buttons-theme ;
: <toggle-button> ( value model label -- gadget ) : <toggle-button> ( value model label -- gadget )
<radio-control> bevel-button-theme ; <radio-control> bevel-button-theme ;
: <toggle-buttons> ( model assoc -- gadget ) : <toggle-buttons> ( model assoc -- gadget )
[ [ <toggle-button> ] <radio-controls> ] make-shelf ; <shelf>
-rot
[ <toggle-button> ] <radio-controls> ;
: command-button-quot ( target command -- quot ) : command-button-quot ( target command -- quot )
[ invoke-command drop ] 2curry ; [ invoke-command drop ] 2curry ;
@ -221,9 +226,9 @@ M: radio-control model-changed
<bevel-button> ; <bevel-button> ;
: <toolbar> ( target -- toolbar ) : <toolbar> ( target -- toolbar )
[ <shelf>
"toolbar" over class command-map commands>> swap swap
[ -rot <command-button> gadget, ] curry assoc-each "toolbar" over class command-map commands>> swap
] make-shelf ; [ -rot <command-button> add-gadget ] curry assoc-each ;
: toolbar, ( -- ) g <toolbar> f track, ; : toolbar, ( -- ) g <toolbar> f track, ;

4
extra/ui/gadgets/gadgets-docs.factor
View File

@ -180,10 +180,6 @@ HELP: focusable-child
{ $values { "gadget" gadget } { "child" gadget } } { $values { "gadget" gadget } { "child" gadget } }
{ $description "Outputs the child of the gadget which would prefer to receive keyboard focus." } ; { $description "Outputs the child of the gadget which would prefer to receive keyboard focus." } ;
HELP: gadget,
{ $values { "gadget" gadget } }
{ $description "Adds a new child to the gadget being constructed. This word can only be used from a quotation passed to " { $link make-gadget } "." } ;
HELP: make-gadget HELP: make-gadget
{ $values { "gadget" gadget } { "quot" quotation } } { $values { "gadget" gadget } { "quot" quotation } }
{ $description "Calls the quotation in a new scope with the gadget stored in the " { $link gadget } " variable." } ; { $description "Calls the quotation in a new scope with the gadget stored in the " { $link gadget } " variable." } ;

2
extra/ui/gadgets/gadgets.factor
View File

@ -357,8 +357,6 @@ M: f request-focus-on 2drop ;
: focus-path ( world -- seq ) : focus-path ( world -- seq )
[ focus>> ] follow ; [ focus>> ] follow ;
: gadget, ( gadget -- ) gadget get swap add-gadget drop ;
: g ( -- gadget ) gadget get ; : g ( -- gadget ) gadget get ;
: g-> ( x -- x x gadget ) dup g ; : g-> ( x -- x x gadget ) dup g ;

7
extra/ui/gadgets/menus/menus.factor
View File

@ -48,6 +48,7 @@ M: menu-glass layout* gadget-child prefer ;
faint-boundary ; faint-boundary ;
: <commands-menu> ( hook target commands -- gadget ) : <commands-menu> ( hook target commands -- gadget )
[ <filled-pile>
[ >r 2dup r> <menu-item> gadget, ] each 2drop -roll
] make-filled-pile 5 <border> menu-theme ; [ <menu-item> add-gadget ] with with each
5 <border> menu-theme ;

23
extra/ui/tools/search/search.factor
View File

@ -47,12 +47,12 @@ search-field H{
{ T{ key-down f f "RET" } [ find-search-list invoke-value-action ] } { T{ key-down f f "RET" } [ find-search-list invoke-value-action ] }
} set-gestures } set-gestures
: <search-model> ( producer -- model ) : <search-model> ( live-search producer -- live-search filter )
>r g live-search-field gadget-model >r dup field>> model>> ! live-search model :: producer
ui-running? [ 1/5 seconds <delay> ] when ui-running? [ 1/5 seconds <delay> ] when
[ "\n" join ] r> append <filter> ; [ "\n" join ] r> append <filter> ;
: <search-list> ( seq limited? presenter -- gadget ) : <search-list> ( live-search seq limited? presenter -- live-search list )
>r >r
[ limited-completions ] [ completions ] ? curry [ limited-completions ] [ completions ] ? curry
<search-model> <search-model>
@ -60,14 +60,15 @@ search-field H{
swap <list> ; swap <list> ;
: <live-search> ( string seq limited? presenter -- gadget ) : <live-search> ( string seq limited? presenter -- gadget )
{ 0 1 } live-search new-track { 0 1 } live-search new-track
[ <search-field> >>field
<search-field> g-> set-live-search-field f track, dup field>> f track-add*
<search-list> g-> set-live-search-list -roll <search-list> >>list
<scroller> 1 track, dup list>> <scroller> 1 track-add*
] make-gadget
[ live-search-field set-editor-string ] keep swap
[ live-search-field end-of-document ] keep ; over field>> set-editor-string
dup field>> end-of-document ;
M: live-search focusable-child* live-search-field ; M: live-search focusable-child* live-search-field ;