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>
<shelf>
{
[ "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
"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
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 new-gadget
{ 100 100 } over set-rect-dim ;
swap >>model
{ 100 100 } >>dim ;
M: color-preview model-changed
swap model-value over set-gadget-interior relayout-1 ;
@ -26,7 +27,10 @@ M: color-preview model-changed
: <color-sliders> ( -- model gadget )
3 [ 0 0 0 255 <range> ] replicate
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 )
[

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
lsys.tortoise lsys.tortoise.graphics
lsys.strings.rewrite lsys.strings.interpret
combinators.short-circuit ;
combinators.short-circuit accessors ;
! lsys.strings
! lsys.strings.rewrite
@ -99,6 +99,8 @@ DEFER: empty-model
: lsys-controller ( -- )
<pile>
{
[ "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 ]
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 ( -- )
<pile>
{
[ "abop-1" <label> [ drop abop-1 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> ]
[ "spiral-0" <label> [ drop spiral-0 build-model ] closed-quot <bevel-button> ]
[ "koch" <label> [ drop koch build-model ] closed-quot <bevel-button> ]
} make*
[ [ gadget, ] curry ] map concat ! Hack
make-pile 1 over set-pack-fill "L-system models" open-window ;
}
[ call add-gadget ] each
1 >>fill
"L-system models" open-window ;
: scene-chooser ( -- )
<pile>
{
[ "abop-1" <label> [ drop abop-1-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> ]
} make*
[ [ gadget, ] curry ] map concat ! Hack
make-pile 1 over set-pack-fill "L-system scenes" open-window ;
}
[ call add-gadget ] each
1 >>fill
"L-system scenes" open-window ;
: lsys-window* ( -- )
[ lsys-controller lsys-viewer ] with-ui ;

12
extra/nehe/nehe.factor
View File

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

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

@ -1,12 +1,13 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math models namespaces sequences
strings quotations assocs combinators classes colors
classes.tuple opengl math.vectors
ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.labels ui.gadgets.theme
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
ui.render math.geometry.rect ;
strings quotations assocs combinators classes colors
classes.tuple opengl math.vectors
ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.labels ui.gadgets.theme
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
ui.render math.geometry.rect ;
IN: ui.gadgets.buttons
TUPLE: button < border pressed? selected? quot ;
@ -187,9 +188,9 @@ M: radio-control model-changed
over set-button-selected?
relayout-1 ;
: <radio-controls> ( model assoc quot -- )
#! quot has stack effect ( value model label -- )
swapd [ swapd call gadget, ] 2curry assoc-each ; inline
: <radio-controls> ( parent model assoc quot -- parent )
#! quot has stack effect ( value model label -- )
swapd [ swapd call add-gadget ] 2curry assoc-each ; inline
: radio-button-theme ( gadget -- gadget )
{ 5 5 } >>gap
@ -202,14 +203,18 @@ M: radio-control model-changed
{ 5 5 } >>gap drop ;
: <radio-buttons> ( model assoc -- gadget )
[ [ <radio-button> ] <radio-controls> ] make-filled-pile
dup radio-buttons-theme ;
<filled-pile>
-rot
[ <radio-button> ] <radio-controls>
dup radio-buttons-theme ;
: <toggle-button> ( value model label -- gadget )
<radio-control> bevel-button-theme ;
: <toggle-buttons> ( model assoc -- gadget )
[ [ <toggle-button> ] <radio-controls> ] make-shelf ;
<shelf>
-rot
[ <toggle-button> ] <radio-controls> ;
: command-button-quot ( target command -- quot )
[ invoke-command drop ] 2curry ;
@ -221,9 +226,9 @@ M: radio-control model-changed
<bevel-button> ;
: <toolbar> ( target -- toolbar )
[
"toolbar" over class command-map commands>> swap
[ -rot <command-button> gadget, ] curry assoc-each
] make-shelf ;
<shelf>
swap
"toolbar" over class command-map commands>> swap
[ -rot <command-button> add-gadget ] curry assoc-each ;
: 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 } }
{ $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
{ $values { "gadget" gadget } { "quot" quotation } }
{ $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>> ] follow ;
: gadget, ( gadget -- ) gadget get swap add-gadget drop ;
: g ( -- gadget ) gadget get ;
: 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 ;
: <commands-menu> ( hook target commands -- gadget )
[
[ >r 2dup r> <menu-item> gadget, ] each 2drop
] make-filled-pile 5 <border> menu-theme ;
<filled-pile>
-roll
[ <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 ] }
} set-gestures
: <search-model> ( producer -- model )
>r g live-search-field gadget-model
: <search-model> ( live-search producer -- live-search filter )
>r dup field>> model>> ! live-search model :: producer
ui-running? [ 1/5 seconds <delay> ] when
[ "\n" join ] r> append <filter> ;
: <search-list> ( seq limited? presenter -- gadget )
: <search-list> ( live-search seq limited? presenter -- live-search list )
>r
[ limited-completions ] [ completions ] ? curry
<search-model>
@ -60,14 +60,15 @@ search-field H{
swap <list> ;
: <live-search> ( string seq limited? presenter -- gadget )
{ 0 1 } live-search new-track
[
<search-field> g-> set-live-search-field f track,
<search-list> g-> set-live-search-list
<scroller> 1 track,
] make-gadget
[ live-search-field set-editor-string ] keep
[ live-search-field end-of-document ] keep ;
{ 0 1 } live-search new-track
<search-field> >>field
dup field>> f track-add*
-roll <search-list> >>list
dup list>> <scroller> 1 track-add*
swap
over field>> set-editor-string
dup field>> end-of-document ;
M: live-search focusable-child* live-search-field ;