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

db4
Doug Coleman 2008-07-13 23:10:50 -05:00
commit 40e901b8f2
14 changed files with 139 additions and 122 deletions

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

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 )
[ [

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 ;

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

View File

@ -7,6 +7,7 @@ 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>
-rot
[ <radio-button> ] <radio-controls>
dup radio-buttons-theme ; 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>
swap
"toolbar" over class command-map commands>> swap "toolbar" over class command-map commands>> swap
[ -rot <command-button> gadget, ] curry assoc-each [ -rot <command-button> add-gadget ] curry assoc-each ;
] make-shelf ;
: toolbar, ( -- ) g <toolbar> f track, ; : toolbar, ( -- ) g <toolbar> f track, ;

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." } ;

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 ;

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 ;

View File

@ -13,7 +13,7 @@ ARTICLE: "ui-pack-layout" "Pack layouts"
{ $subsection make-pile } { $subsection make-pile }
{ $subsection make-filled-pile } { $subsection make-filled-pile }
{ $subsection make-shelf } { $subsection make-shelf }
{ $subsection gadget, }
"For more control, custom layouts can reuse portions of pack layout logic:" "For more control, custom layouts can reuse portions of pack layout logic:"
{ $subsection pack-pref-dim } { $subsection pack-pref-dim }
{ $subsection pack-layout } ; { $subsection pack-layout } ;
@ -66,14 +66,14 @@ HELP: pack-pref-dim
HELP: make-pile HELP: make-pile
{ $values { "quot" quotation } { "pack" "a new " { $link pack } } } { $values { "quot" quotation } { "pack" "a new " { $link pack } } }
{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets vertically. The quotation can add children by calling the " { $link gadget, } " word." } ; { $description "Creates a new " { $link pack } " which lays out a sequence of gadgets vertically. The quotation can add children by calling the gadget, word." } ;
HELP: make-filled-pile HELP: make-filled-pile
{ $values { "quot" quotation } { "pack" "a new " { $link pack } } } { $values { "quot" quotation } { "pack" "a new " { $link pack } } }
{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets vertically, such that all gadgets have the same width. The quotation can add children by calling the " { $link gadget, } " word." } ; { $description "Creates a new " { $link pack } " which lays out a sequence of gadgets vertically, such that all gadgets have the same width. The quotation can add children by calling the gadget, word." } ;
HELP: make-shelf HELP: make-shelf
{ $values { "quot" quotation } { "pack" "a new " { $link pack } } } { $values { "quot" quotation } { "pack" "a new " { $link pack } } }
{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets horizontally. The quotation can add children by calling the " { $link gadget, } " word." } ; { $description "Creates a new " { $link pack } " which lays out a sequence of gadgets horizontally. The quotation can add children by calling the gadget, word." } ;
ABOUT: "ui-pack-layout" ABOUT: "ui-pack-layout"

View File

@ -49,6 +49,10 @@ M: track pref-dim*
: track-add ( gadget track constraint -- ) : track-add ( gadget track constraint -- )
over track-sizes push swap add-gadget drop ; over track-sizes push swap add-gadget drop ;
: track-add* ( track gadget constraint -- track )
pick sizes>> push
add-gadget ;
: track, ( gadget constraint -- ) : track, ( gadget constraint -- )
gadget get swap track-add ; gadget get swap track-add ;

View File

@ -7,6 +7,7 @@ ui.gadgets.viewports ui.gadgets.lists ui.gadgets.tracks
ui.gadgets.scrollers ui.gadgets.panes hashtables io kernel math ui.gadgets.scrollers ui.gadgets.panes hashtables io kernel math
models namespaces sequences sequences words continuations models namespaces sequences sequences words continuations
debugger prettyprint ui.tools.traceback help editors ; debugger prettyprint ui.tools.traceback help editors ;
IN: ui.tools.debugger IN: ui.tools.debugger
: <restart-list> ( restarts restart-hook -- gadget ) : <restart-list> ( restarts restart-hook -- gadget )
@ -15,18 +16,18 @@ IN: ui.tools.debugger
TUPLE: debugger < track restarts ; TUPLE: debugger < track restarts ;
: <debugger-display> ( restart-list error -- gadget ) : <debugger-display> ( restart-list error -- gadget )
[ <filled-pile>
<pane> [ [ print-error ] with-pane ] keep gadget, <pane>
gadget, swapd tuck [ print-error ] with-pane
] make-filled-pile ; add-gadget
swap add-gadget ;
: <debugger> ( error restarts restart-hook -- gadget ) : <debugger> ( error restarts restart-hook -- gadget )
{ 0 1 } debugger new-track { 0 1 } debugger new-track
[ dup <toolbar> f track-add*
toolbar, -rot <restart-list> >>restarts
<restart-list> g-> set-debugger-restarts dup restarts>> rot <debugger-display> <scroller> 1 track-add* ;
swap <debugger-display> <scroller> 1 track,
] make-gadget ;
M: debugger focusable-child* debugger-restarts ; M: debugger focusable-child* debugger-restarts ;

View File

@ -6,57 +6,60 @@ ui.gadgets.packs ui.gadgets.labels tools.deploy.config
namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
ui.commands assocs ui.gadgets.tracks ui ui.tools.listener ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
tools.deploy vocabs ui.tools.workspace system accessors ; tools.deploy vocabs ui.tools.workspace system accessors ;
IN: ui.tools.deploy IN: ui.tools.deploy
TUPLE: deploy-gadget < pack vocab settings ; TUPLE: deploy-gadget < pack vocab settings ;
: bundle-name ( -- ) : bundle-name ( parent -- parent )
deploy-name get <field> deploy-name get <field>
"Executable name:" label-on-left gadget, ; "Executable name:" label-on-left add-gadget ;
: deploy-ui ( -- ) : deploy-ui ( parent -- parent )
deploy-ui? get deploy-ui? get
"Include user interface framework" <checkbox> gadget, ; "Include user interface framework" <checkbox> add-gadget ;
: exit-when-windows-closed ( -- ) : exit-when-windows-closed ( parent -- parent )
"stop-after-last-window?" get "stop-after-last-window?" get
"Exit when last UI window closed" <checkbox> gadget, ; "Exit when last UI window closed" <checkbox> add-gadget ;
: io-settings ( -- ) : io-settings ( parent -- parent )
"Input/output support:" <label> gadget, "Input/output support:" <label> add-gadget
deploy-io get deploy-io-options <radio-buttons> gadget, ; deploy-io get deploy-io-options <radio-buttons> add-gadget ;
: reflection-settings ( -- ) : reflection-settings ( parent -- parent )
"Reflection support:" <label> gadget, "Reflection support:" <label> add-gadget
deploy-reflection get deploy-reflection-options <radio-buttons> gadget, ; deploy-reflection get deploy-reflection-options <radio-buttons> add-gadget ;
: advanced-settings ( -- ) : advanced-settings ( parent -- parent )
"Advanced:" <label> gadget, "Advanced:" <label> add-gadget
deploy-compiler? get "Use optimizing compiler" <checkbox> gadget, deploy-compiler? get "Use optimizing compiler" <checkbox> add-gadget
deploy-math? get "Rational and complex number support" <checkbox> gadget, deploy-math? get "Rational and complex number support" <checkbox> add-gadget
deploy-threads? get "Threading support" <checkbox> gadget, deploy-threads? get "Threading support" <checkbox> add-gadget
deploy-random? get "Random number generator support" <checkbox> gadget, deploy-random? get "Random number generator support" <checkbox> add-gadget
deploy-word-props? get "Retain all word properties" <checkbox> gadget, deploy-word-props? get "Retain all word properties" <checkbox> add-gadget
deploy-word-defs? get "Retain all word definitions" <checkbox> gadget, deploy-word-defs? get "Retain all word definitions" <checkbox> add-gadget
deploy-c-types? get "Retain all C types" <checkbox> gadget, ; deploy-c-types? get "Retain all C types" <checkbox> add-gadget ;
: deploy-settings-theme ( gadget -- ) : deploy-settings-theme ( gadget -- gadget )
{ 10 10 } >>gap { 10 10 } >>gap
1 >>fill 1 >>fill ;
drop ;
: <deploy-settings> ( vocab -- control ) : <deploy-settings> ( vocab -- control )
default-config [ <model> ] assoc-map [ default-config [ <model> ] assoc-map
[ [
<pile>
bundle-name bundle-name
deploy-ui deploy-ui
os macosx? [ exit-when-windows-closed ] when os macosx? [ exit-when-windows-closed ] when
io-settings io-settings
reflection-settings reflection-settings
advanced-settings advanced-settings
] make-pile dup deploy-settings-theme
deploy-settings-theme
namespace <mapping> over set-gadget-model namespace <mapping> over set-gadget-model
] bind ; ]
bind ;
: find-deploy-gadget ( gadget -- deploy-gadget ) : find-deploy-gadget ( gadget -- deploy-gadget )
[ deploy-gadget? ] find-parent ; [ deploy-gadget? ] find-parent ;
@ -101,19 +104,14 @@ deploy-gadget "toolbar" f {
{ T{ key-down f f "RET" } com-deploy } { T{ key-down f f "RET" } com-deploy }
} define-command-map } define-command-map
: buttons, ( -- )
g <toolbar> { 10 10 } over set-pack-gap gadget, ;
: <deploy-gadget> ( vocab -- gadget ) : <deploy-gadget> ( vocab -- gadget )
deploy-gadget new-gadget deploy-gadget new-gadget
swap >>vocab over >>vocab
{ 0 1 } >>orientation { 0 1 } >>orientation
[ swap <deploy-settings> >>settings
g vocab>> <deploy-settings> dup settings>> add-gadget
g-> set-deploy-gadget-settings gadget, dup <toolbar> { 10 10 } >>gap add-gadget
buttons, deploy-settings-theme
] make-gadget
dup deploy-settings-theme
dup com-revert ; dup com-revert ;
: deploy-tool ( vocab -- ) : deploy-tool ( vocab -- )

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>
@ -61,13 +61,14 @@ search-field H{
: <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 ;

View File

@ -235,7 +235,7 @@ $nl
$nl $nl
"Gadget construction combinators whose names are prefixed with " { $snippet "make-" } " construct new gadgets and push them on the stack. The primitive combinator used to define all combinators of this form:" "Gadget construction combinators whose names are prefixed with " { $snippet "make-" } " construct new gadgets and push them on the stack. The primitive combinator used to define all combinators of this form:"
{ $subsection make-gadget } { $subsection make-gadget }
"Words such as " { $link gadget, } " and " { $link track, } " access the gadget through the " { $link gadget } " variable." "Words such as " { $link track, } " access the gadget through the " { $link gadget } " variable."
$nl $nl
"A combinator which stores a gadget in the " { $link gadget } " variable:" "A combinator which stores a gadget in the " { $link gadget } " variable:"
{ $subsection with-gadget } { $subsection with-gadget }