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

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

db4
Doug Coleman 2008-07-18 20:02:16 -05:00
parent ddf60c1354 6bb23c39f9
commit ee999bee4a
21 changed files with 134 additions and 239 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
extra/automata/ui/ui.factor
View File

@ -6,7 +6,6 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads
ui
ui.gestures
ui.gadgets
ui.gadgets.handler
ui.gadgets.slate
ui.gadgets.labels
ui.gadgets.buttons
@ -14,8 +13,8 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads
ui.gadgets.packs
ui.gadgets.grids
ui.gadgets.theme
ui.gadgets.handler
accessors
qualified
namespaces.lib assocs.lib vars
rewrite-closures automata math.geometry.rect newfx ;
@ -23,13 +22,6 @@ IN: automata.ui
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
QUALIFIED: ui.gadgets.grids
: grid-add ( grid child i j -- grid )
>r >r dupd swap r> r> ui.gadgets.grids:grid-add ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: draw-point ( y x value -- ) 1 = [ swap glVertex2i ] [ 2drop ] if ;
: draw-line ( y line -- ) 0 swap [ >r 2dup r> draw-point 1+ ] each 2drop ;
@ -80,13 +72,15 @@ DEFER: automata-window
"5 - Random Rule" [ random-rule ] view-button add-gadget
"n - New" [ automata-window ] view-button add-gadget
@top grid-add
@top grid-add*
C[ display ] <slate>
{ 400 400 } >>dim
{ 400 400 } >>pdim
dup >slate
@center grid-add
@center grid-add*
<handler>
H{ }
T{ key-down f f "1" } [ start-center ] view-action is
@ -95,9 +89,7 @@ DEFER: automata-window
T{ key-down f f "5" } [ random-rule ] view-action is
T{ key-down f f "n" } [ automata-window ] view-action is
<handler>
tuck set-gadget-delegate
>>table
"Automata" open-window ;

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

@ -102,7 +102,7 @@ VARS: population-label cohesion-label alignment-label separation-label ;
C[ display ] <slate> >slate
t slate> set-gadget-clipped?
{ 600 400 } slate> set-slate-dim
{ 600 400 } slate> set-slate-pdim
C[ [ run ] in-thread ] slate> set-slate-graft
C[ loop off ] slate> set-slate-ungraft
@ -143,9 +143,11 @@ VARS: population-label cohesion-label alignment-label separation-label ;
} [ call ] map [ add-gadget ] each
1 over set-pack-fill
over @top grid-add
@top grid-add*
slate> over @center grid-add
slate> @center grid-add*
<handler>
H{ } clone
T{ key-down f f "1" } C[ drop randomize ] is
@ -162,7 +164,10 @@ VARS: population-label cohesion-label alignment-label separation-label ;
T{ key-down f f "d" } C[ drop dec-separation-weight ] is
T{ key-down f f "ESC" } C[ drop toggle-loop ] is
<handler> tuck set-gadget-delegate "Boids" open-window ;
>>table
"Boids" open-window ;
: boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ;

2
extra/cfdg/cfdg.factor
View File

@ -204,7 +204,7 @@ VAR: start-shape
: cfdg-window* ( -- )
[ display ] closed-quot <slate>
{ 500 500 } over set-slate-dim
{ 500 500 } over set-slate-pdim
dup "CFDG" open-window ;
: cfdg-window ( -- ) [ cfdg-window* ] with-ui ;

8
extra/display-stack/display-stack.factor
View File

@ -10,10 +10,12 @@ SYMBOL: watched-variables
: watch-var ( sym -- ) watched-variables get push ;
: watch-vars ( sym -- ) watched-variables get [ push ] curry each ;
: watch-vars ( seq -- ) watched-variables get [ push ] curry each ;
: unwatch-var ( sym -- ) watched-variables get delete ;
: unwatch-vars ( seq -- ) watched-variables get [ delete ] curry each ;
: print-watched-variables ( -- )
watched-variables get length 0 >
[
@ -33,9 +35,9 @@ SYMBOL: watched-variables
[
print-watched-variables
"----------" print
.s
datastack [ . ] each
"----------" print
retainstack reverse stack.
retainstack reverse [ . ] each
]
listener-hook set ;

68
extra/golden-section/golden-section.factor
View File

@ -1,64 +1,64 @@
USING: kernel namespaces math math.constants math.functions arrays sequences
opengl opengl.gl opengl.glu ui ui.render ui.gadgets ui.gadgets.theme
ui.gadgets.slate colors ;
opengl opengl.gl opengl.glu ui ui.render ui.gadgets ui.gadgets.theme
ui.gadgets.slate colors accessors combinators.cleave ;
IN: golden-section
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! To run:
! "golden-section" run
: disk ( radius center -- )
glPushMatrix
gl-translate
dup 0 glScalef
gluNewQuadric [ 0 1 20 20 gluDisk ] [ gluDeleteQuadric ] bi
glPopMatrix ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: disk ( quadric radius center -- )
glPushMatrix
gl-translate
dup 0 glScalef
0 1 10 10 gluDisk
glPopMatrix ;
! omega(i) = 2*pi*i*(phi-1)
! x(i) = 0.5*i*cos(omega(i))
! y(i) = 0.5*i*sin(omega(i))
! radius(i) = 10*sin((pi*i)/720)
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: omega ( i -- omega ) phi 1- * 2 * pi * ;
: x ( i -- x ) dup omega cos * 0.5 * ;
: x ( i -- x ) [ omega cos ] [ 0.5 * ] bi * ;
: y ( i -- y ) [ omega sin ] [ 0.5 * ] bi * ;
: y ( i -- y ) dup omega sin * 0.5 * ;
: center ( i -- point ) dup x swap y 2array ;
: center ( i -- point ) { x y } 1arr ;
: radius ( i -- radius ) pi * 720 / sin 10 * ;
: color ( i -- color ) 360.0 / dup 0.25 1 4array ;
: rim ( quadric i -- )
black gl-color dup radius 1.5 * swap center disk ;
: rim ( i -- ) [ drop black gl-color ] [ radius 1.5 * ] [ center ] tri disk ;
: inner ( i -- ) [ color gl-color ] [ radius ] [ center ] tri disk ;
: inner ( quadric i -- )
dup color gl-color dup radius swap center disk ;
: dot ( i -- ) [ rim ] [ inner ] bi ;
: dot ( quadric i -- ) 2dup rim inner ;
: golden-section ( quadric -- ) 720 [ dot ] with each ;
: golden-section ( -- ) 720 [ dot ] each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: with-quadric ( quot -- )
gluNewQuadric [ swap call ] keep gluDeleteQuadric ; inline
: display ( -- )
GL_PROJECTION glMatrixMode
glLoadIdentity
-400 400 -400 400 -1 1 glOrtho
GL_MODELVIEW glMatrixMode
glLoadIdentity
[ golden-section ] with-quadric ;
GL_PROJECTION glMatrixMode
glLoadIdentity
-400 400 -400 400 -1 1 glOrtho
GL_MODELVIEW glMatrixMode
glLoadIdentity
golden-section ;
: golden-section-window ( -- )
[
[ display ] <slate>
{ 600 600 } over set-slate-dim
"Golden Section" open-window
] with-ui ;
[ display ] <slate>
{ 600 600 } >>pdim
"Golden Section" open-window
]
with-ui ;
MAIN: golden-section-window

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

@ -158,7 +158,9 @@ DEFER: empty-model
: lsys-viewer ( -- )
[ ] <slate> >slate
{ 400 400 } clone slate> set-slate-dim
{ 400 400 } clone slate> set-slate-pdim
slate> <handler>
{
@ -194,13 +196,9 @@ DEFER: empty-model
[ [ pos> norm reset-turtle 45 turn-left 45 pitch-up step-turtle 180 turn-left ]
camera-action ] }
! } [ make* ] map alist>hash <handler> >handler
} [ make* ] map >hashtable >>table
} [ make* ] map >hashtable <handler> >handler
slate> handler> set-gadget-delegate
handler> "L-system view" open-window
"L-system view" open-window
500 sleep

17
extra/processing/gadget/gadget.factor
View File

@ -1,25 +1,14 @@
USING: kernel namespaces combinators
ui.gestures qualified accessors ui.gadgets.frame-buffer ;
ui.gestures accessors ui.gadgets.frame-buffer ;
IN: processing.gadget
QUALIFIED: ui.gadgets
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: processing-gadget button-down button-up key-down key-up ;
TUPLE: processing-gadget < frame-buffer button-down button-up key-down key-up ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: set-gadget-delegate ( tuple gadget -- tuple )
over ui.gadgets:set-gadget-delegate ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: <processing-gadget> ( -- gadget )
processing-gadget new
<frame-buffer> set-gadget-delegate ;
: <processing-gadget> ( -- gadget ) processing-gadget new-frame-buffer ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

2
extra/processing/processing.factor Executable file → Normal file
View File

@ -374,7 +374,7 @@ SYMBOL: setup-called
500 sleep
<processing-gadget>
size-val get >>dim
size-val get >>pdim
dup "Processing" open-window
500 sleep

27
extra/self/slots/slots.factor Normal file
View File

@ -0,0 +1,27 @@
USING: kernel words lexer parser sequences accessors self ;
IN: self.slots
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: define-self-slot-reader ( slot -- )
[ "->" append current-vocab create dup set-word ]
[ ">>" append search [ self> ] swap suffix ] bi
(( -- value )) define-declared ;
: define-self-slot-writer ( slot -- )
[ "->" prepend current-vocab create dup set-word ]
[ ">>" prepend search [ self> swap ] swap suffix [ drop ] append ] bi
(( value -- )) define-declared ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: define-self-slot-accessors ( class -- )
"slots" word-prop
[ name>> ] map
[ [ define-self-slot-reader ] [ define-self-slot-writer ] bi ] each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: SELF-SLOTS: scan-word define-self-slot-accessors ; parsing

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

@ -51,7 +51,7 @@ DEFER: maybe-loop
: springies-window* ( -- )
C[ display ] <slate> >slate
{ 800 600 } slate> set-slate-dim
{ 800 600 } slate> set-slate-pdim
C[ { 500 500 } >world-size loop on [ run ] in-thread ]
slate> set-slate-graft
C[ loop off ] slate> set-slate-ungraft

12
extra/ui/gadgets/frame-buffer/frame-buffer.factor
View File

@ -7,7 +7,7 @@ IN: ui.gadgets.frame-buffer
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: frame-buffer action dim last-dim graft ungraft pixels ;
TUPLE: frame-buffer < gadget action pdim last-dim graft ungraft pixels ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -18,13 +18,15 @@ TUPLE: frame-buffer action dim last-dim graft ungraft pixels ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: <frame-buffer> ( -- frame-buffer )
frame-buffer construct-gadget
: new-frame-buffer ( class -- gadget )
new-gadget
[ ] >>action
{ 100 100 } >>dim
{ 100 100 } >>pdim
[ ] >>graft
[ ] >>ungraft ;
: <frame-buffer> ( -- frame-buffer ) frame-buffer new-frame-buffer ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: draw-pixels ( fb -- fb )
@ -44,7 +46,7 @@ TUPLE: frame-buffer action dim last-dim graft ungraft pixels ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
M: frame-buffer pref-dim* dim>> ;
M: frame-buffer pref-dim* pdim>> ;
M: frame-buffer graft* graft>> call ;
M: frame-buffer ungraft* ungraft>> call ;

12
extra/ui/gadgets/frames/frames-docs.factor
View File

@ -7,9 +7,7 @@ ARTICLE: "ui-frame-layout" "Frame layouts"
{ $subsection frame }
"Creating empty frames:"
{ $subsection <frame> }
"Creating new frames using a combinator:"
{ $subsection frame, }
"A set of mnemonic words for the positions on a frame's 3x3 grid; these words push values which may be passed to " { $link grid-add } " or " { $link frame, } ":"
"A set of mnemonic words for the positions on a frame's 3x3 grid; these words push values which may be passed to " { $link grid-add* } ":"
{ $subsection @center }
{ $subsection @left }
{ $subsection @right }
@ -22,7 +20,7 @@ ARTICLE: "ui-frame-layout" "Frame layouts"
: $ui-frame-constant ( element -- )
drop
{ $description "Symbolic constant for a common input to " { $link grid-add } " and " { $link frame, } "." } print-element ;
{ $description "Symbolic constant for a common input to " { $link grid-add* } "." } print-element ;
HELP: @center $ui-frame-constant ;
HELP: @left $ui-frame-constant ;
@ -37,16 +35,12 @@ HELP: @bottom-right $ui-frame-constant ;
HELP: frame
{ $class-description "A frame is a gadget which lays out its children in a 3x3 grid. If the frame is enlarged past its preferred size, the center gadget fills up available room."
$nl
"Frames are constructed by calling " { $link <frame> } " and since they inherit from " { $link grid } ", children can be managed with " { $link grid-add } " and " { $link grid-remove } "." } ;
"Frames are constructed by calling " { $link <frame> } " and since they inherit from " { $link grid } ", children can be managed with " { $link grid-add* } " and " { $link grid-remove } "." } ;
HELP: <frame>
{ $values { "frame" frame } }
{ $description "Creates a new " { $link frame } " for laying out gadgets in a 3x3 grid." } ;
HELP: frame,
{ $values { "gadget" gadget } { "i" "non-negative integer" } { "j" "non-negative integer" } }
{ $description "Adds a child gadget at the specified location. This word can only be called inside the quotation passed to make-frame." } ;
{ grid frame } related-words
ABOUT: "ui-frame-layout"

3
extra/ui/gadgets/frames/frames.factor
View File

@ -38,6 +38,3 @@ M: frame layout*
dup compute-grid
[ rot rect-dim fill-center ] 3keep
grid-layout ;
: frame, ( gadget i j -- )
gadget get -rot grid-add ;

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

@ -361,10 +361,6 @@ M: f request-focus-on 2drop ;
[ focus>> ] follow ;
! Deprecated
: set-gadget-delegate ( gadget tuple -- )
over [
dup pick [ (>>parent) ] with each-child
] when set-delegate ;
: construct-gadget ( class -- tuple )
>r <gadget> { set-delegate } r> construct ; inline

6
extra/ui/gadgets/grids/grids-docs.factor
View File

@ -7,7 +7,7 @@ ARTICLE: "ui-grid-layout" "Grid layouts"
"Creating grids from a fixed set of gadgets:"
{ $subsection <grid> }
"Managing chidren:"
{ $subsection grid-add }
{ $subsection grid-add* }
{ $subsection grid-remove }
{ $subsection grid-child } ;
@ -18,7 +18,7 @@ $nl
$nl
"The " { $link grid-fill? } " slot stores a boolean, indicating if grid cells should assume their preferred size, or if they should fill the dimensions of the cell. The default is " { $link t } "."
$nl
"Grids are created by calling " { $link <grid> } " and children are managed with " { $link grid-add } " and " { $link grid-remove } "."
"Grids are created by calling " { $link <grid> } " and children are managed with " { $link grid-add* } " and " { $link grid-remove } "."
$nl
"The " { $link add-gadget } ", " { $link unparent } " and " { $link clear-gadget } " words should not be used to manage child gadgets of grids." } ;
@ -31,7 +31,7 @@ HELP: grid-child
{ $description "Outputs the child gadget at the " { $snippet "i" } "," { $snippet "j" } "th position of the grid." }
{ $errors "Throws an error if the indices are out of bounds." } ;
HELP: grid-add
HELP: grid-add*
{ $values { "gadget" gadget } { "grid" grid } { "i" "non-negative integer" } { "j" "non-negative integer" } }
{ $description "Adds a child gadget at the specified location." }
{ $side-effects "grid" } ;

12
extra/ui/gadgets/grids/grids.factor
View File

@ -20,14 +20,12 @@ grid
: grid-child ( grid i j -- gadget ) rot grid>> nth nth ;
: grid-add ( gadget grid i j -- )
>r >r 2dup swap add-gadget drop r> r>
3dup grid-child unparent rot grid>> nth set-nth ;
: grid-add* ( grid child i j -- grid )
>r >r dupd swap r> r>
>r >r 2dup swap add-gadget drop r> r>
3dup grid-child unparent rot grid>> nth set-nth ;
: grid-add* ( grid child i j -- grid ) >r >r dupd swap r> r> grid-add ;
: grid-remove ( grid i j -- )
>r >r >r <gadget> r> r> r> grid-add ;
: grid-remove ( grid i j -- grid ) <gadget> -rot grid-add* ;
: pref-dim-grid ( grid -- dims )
grid>> [ [ pref-dim ] map ] map ;

8
extra/ui/gadgets/handler/handler.factor
View File

@ -1,11 +1,11 @@
USING: kernel assocs ui.gestures ;
USING: kernel assocs ui.gestures ui.gadgets.wrappers accessors ;
IN: ui.gadgets.handler
TUPLE: handler table ;
TUPLE: handler < wrapper table ;
C: <handler> handler
: <handler> ( child -- handler ) handler new-wrapper ;
M: handler handle-gesture* ( gadget gesture delegate -- ? )
handler-table at dup [ call f ] [ 2drop t ] if ;
table>> at dup [ call f ] [ 2drop t ] if ;

123
extra/ui/gadgets/slate/slate.factor
View File

@ -1,122 +1,21 @@
USING: kernel namespaces opengl ui.render ui.gadgets ;
USING: kernel namespaces opengl ui.render ui.gadgets accessors ;
IN: ui.gadgets.slate
TUPLE: slate action dim graft ungraft
button-down
button-up
key-down
key-up ;
TUPLE: slate < gadget action pdim graft ungraft ;
: <slate> ( action -- slate )
slate construct-gadget
tuck set-slate-action
{ 100 100 } over set-slate-dim
[ ] over set-slate-graft
[ ] over set-slate-ungraft ;
slate new-gadget
swap >>action
{ 100 100 } >>pdim
[ ] >>graft
[ ] >>ungraft ;
M: slate pref-dim* ( slate -- dim ) slate-dim ;
M: slate pref-dim* ( slate -- dim ) pdim>> ;
M: slate draw-gadget* ( slate -- )
origin get swap slate-action with-translation ;
M: slate draw-gadget* ( slate -- ) origin get swap action>> with-translation ;
M: slate graft* ( slate -- ) slate-graft call ;
M: slate graft* ( slate -- ) graft>> call ;
M: slate ungraft* ( slate -- ) ungraft>> call ;
M: slate ungraft* ( slate -- ) slate-ungraft call ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: key-pressed-value
: key-pressed? ( -- ? ) key-pressed-value get ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: mouse-pressed-value
: mouse-pressed? ( -- ? ) mouse-pressed-value get ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: key-value
: key ( -- key ) key-value get ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: button-value
: button ( -- val ) button-value get ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: combinators ui.gestures accessors ;
! M: slate handle-gesture* ( gadget gesture delegate -- ? )
! drop nip
! {
! {
! [ dup key-down? ]
! [
! key-down-sym key-value set
! key-pressed-value on
! t
! ]
! }
! { [ dup key-up? ] [ drop key-pressed-value off t ] }
! {
! [ dup button-down? ]
! [
! button-down-# mouse-button-value set
! mouse-pressed-value on
! t
! ]
! }
! { [ dup button-up? ] [ drop mouse-pressed-value off t ] }
! { [ t ] [ drop t ] }
! }
! cond ;
M: slate handle-gesture* ( gadget gesture delegate -- ? )
rot drop swap ! delegate gesture
{
{
[ dup key-down? ]
[
key-down-sym key-value set
key-pressed-value on
key-down>> dup [ call ] [ drop ] if
t
]
}
{
[ dup key-up? ]
[
key-pressed-value off
drop
key-up>> dup [ call ] [ drop ] if
t
] }
{
[ dup button-down? ]
[
button-down-# button-value set
mouse-pressed-value on
button-down>> dup [ call ] [ drop ] if
t
]
}
{
[ dup button-up? ]
[
mouse-pressed-value off
drop
button-up>> dup [ call ] [ drop ] if
t
]
}
{ [ t ] [ 2drop t ] }
}
cond ;

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

@ -109,7 +109,7 @@ TUPLE: editable-slot < track printer ref ;
[ clear-track ]
[
dup ref>> <slot-editor>
[ swap 1 track-add ]
[ 1 track-add* drop ]
[ [ scroll>gadget ] [ request-focus ] bi* ] 2bi
] bi ;

2
extra/ui/gadgets/status-bar/status-bar.factor
View File

@ -12,7 +12,7 @@ IN: ui.gadgets.status-bar
: open-status-window ( gadget title -- )
f <model> [ <world> ] keep
<status-bar> over f track-add
<status-bar> f track-add*
open-world-window ;
: show-summary ( object gadget -- )

16
extra/ui/gadgets/wrappers/wrappers.factor
View File

@ -1,22 +1,18 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors ui.gadgets kernel ;
IN: ui.gadgets.wrappers
TUPLE: wrapper < gadget ;
: new-wrapper ( child class -- wrapper )
new-gadget
[ swap add-gadget drop ] keep ; inline
: new-wrapper ( child class -- wrapper ) new-gadget swap add-gadget ;
: <wrapper> ( child -- border )
wrapper new-wrapper ;
: <wrapper> ( child -- border ) wrapper new-wrapper ;
M: wrapper pref-dim*
gadget-child pref-dim ;
M: wrapper pref-dim* ( wrapper -- dim ) gadget-child pref-dim ;
M: wrapper layout*
M: wrapper layout* ( wrapper -- )
[ dim>> ] [ gadget-child ] bi set-layout-dim ;
M: wrapper focusable-child*
gadget-child ;
M: wrapper focusable-child* ( wrapper -- child/t ) gadget-child ;