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-20 04:19:16 -05:00
parent 35bd2abc71 541cff7dca
commit bac6929898
19 changed files with 90 additions and 126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
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 } >>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 ;

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

@ -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 ;

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-pdim
"Golden Section" open-window
] with-ui ;
[ display ] <slate>
{ 600 600 } >>pdim
"Golden Section" open-window
]
with-ui ;
MAIN: golden-section-window

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

@ -160,6 +160,8 @@ DEFER: empty-model
[ ] <slate> >slate
{ 400 400 } clone slate> set-slate-pdim
slate> <handler>
{
{ T{ key-down f f "LEFT" } [ [ 5 turn-left ] camera-action ] }
@ -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

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 ;

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

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

@ -8,7 +8,7 @@ ARTICLE: "ui-track-layout" "Track layouts"
"Creating empty tracks:"
{ $subsection <track> }
"Adding children:"
{ $subsection track-add } ;
{ $subsection track-add* } ;
HELP: track
{ $class-description "A track is like a " { $link pack } " except each child is resized to a fixed multiple of the track's dimension in the direction of " { $link gadget-orientation } ". Tracks are created by calling " { $link <track> } "." } ;
@ -17,7 +17,7 @@ HELP: <track>
{ $values { "orientation" "an orientation specifier" } { "track" "a new " { $link track } } }
{ $description "Creates a new track which lays out children along the given axis. Children are laid out vertically if the orientation is " { $snippet "{ 0 1 }" } " and horizontally if the orientation is " { $snippet "{ 1 0 }" } "." } ;
HELP: track-add
HELP: track-add*
{ $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } }
{ $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child." } ;

5
extra/ui/gadgets/tracks/tracks.factor
View File

@ -41,14 +41,11 @@ M: track layout* ( track -- ) dup track-layout pack-layout ;
M: track pref-dim* ( gadget -- dim )
[ track-pref-dims-1 ]
[ [ alloted-dim ] [ track-pref-dims-1 ] bi v+ ]
[ [ alloted-dim ] [ track-pref-dims-2 ] bi v+ ]
[ orientation>> ]
tri
set-axis ;
: track-add ( gadget track constraint -- )
over track-sizes push swap add-gadget drop ;
: track-add* ( track gadget constraint -- track )
pick sizes>> push add-gadget ;

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

@ -40,7 +40,7 @@ M: world request-focus-on ( child gadget -- )
{ 0 0 } >>window-loc
swap >>status
swap >>title
[ 1 track-add ] keep
swap 1 track-add*
dup request-focus ;
M: world layout*

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 ;