ui
ui.gestures
ui.gadgets
- ui.gadgets.handler
ui.gadgets.slate
ui.gadgets.labels
ui.gadgets.buttons
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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-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 ;
"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
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 ;
} [ 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
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 ;
+
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 ;
-
-: inner ( quadric i -- )
- dup color gl-color dup radius swap center disk ;
+: rim ( i -- ) [ drop black gl-color ] [ radius 1.5 * ] [ center ] tri disk ;
+: inner ( i -- ) [ color gl-color ] [ radius ] [ center ] tri disk ;
-: dot ( quadric i -- ) 2dup rim inner ;
+: dot ( i -- ) [ rim ] [ inner ] bi ;
-: 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
[ ] <slate> >slate
{ 400 400 } clone slate> set-slate-pdim
+slate> <handler>
+
{
{ T{ key-down f f "LEFT" } [ [ 5 turn-left ] camera-action ] }
[ [ 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 <handler> >handler
-
-slate> handler> set-gadget-delegate
+} [ make* ] map >hashtable >>table
-handler> "L-system view" open-window
+"L-system view" open-window
500 sleep
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 ;
-
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: set-gadget-delegate ( tuple gadget -- tuple )
- over ui.gadgets:set-gadget-delegate ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+TUPLE: processing-gadget < frame-buffer button-down button-up key-down key-up ;
-: <processing-gadget> ( -- gadget )
- processing-gadget new
- <frame-buffer> set-gadget-delegate ;
+: <processing-gadget> ( -- gadget ) processing-gadget new-frame-buffer ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
500 sleep
<processing-gadget>
- size-val get >>dim
+ size-val get >>pdim
dup "Processing" open-window
500 sleep
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-TUPLE: frame-buffer action dim last-dim graft ungraft pixels ;
+TUPLE: frame-buffer < gadget action pdim 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 )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-M: frame-buffer pref-dim* dim>> ;
+M: frame-buffer pref-dim* pdim>> ;
M: frame-buffer graft* graft>> call ;
M: frame-buffer ungraft* ungraft>> call ;
{ $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 }
: $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 ;
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"
dup compute-grid
[ rot rect-dim fill-center ] 3keep
grid-layout ;
-
-: frame, ( gadget i j -- )
- gadget get -rot grid-add ;
[ 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
"Creating grids from a fixed set of gadgets:"
{ $subsection <grid> }
"Managing chidren:"
-{ $subsection grid-add }
+{ $subsection grid-add* }
{ $subsection grid-remove }
{ $subsection grid-child } ;
$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." } ;
{ $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" } ;
: 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 ;
-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 ;
\ No newline at end of file
+ table>> at dup [ call f ] [ 2drop t ] if ;
\ No newline at end of file
[ clear-track ]
[
dup ref>> <slot-editor>
- [ swap 1 track-add ]
+ [ 1 track-add* drop ]
[ [ scroll>gadget ] [ request-focus ] bi* ] 2bi
] bi ;
: 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 -- )
"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> } "." } ;
{ $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." } ;
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 ;
{ 0 0 } >>window-loc
swap >>status
swap >>title
- [ 1 track-add ] keep
+ swap 1 track-add*
dup request-focus ;
M: world layout*
! 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 ;
projects / factor.git / commitdiff