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

extra/automata/ui/ui.factor

@@ -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>
+  >>table
-
-    tuck set-gadget-delegate
 
   "Automata" open-window ;
 

extra/boids/ui/ui.factor

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

extra/golden-section/golden-section.factor

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

extra/lsys/ui/ui.factor

@@ -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
+"L-system view" open-window
-
-slate> handler> set-gadget-delegate
-
-handler> "L-system view" open-window
 
 500 sleep
 

extra/processing/gadget/gadget.factor

@@ -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 ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: <processing-gadget> ( -- gadget ) processing-gadget new-frame-buffer ;
-
-: set-gadget-delegate ( tuple gadget -- tuple )
-  over ui.gadgets:set-gadget-delegate ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: <processing-gadget> ( -- gadget )
-  processing-gadget new
-    <frame-buffer> set-gadget-delegate ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

extra/processing/processing.factor

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

extra/ui/gadgets/frame-buffer/frame-buffer.factor

@@ -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 )
+: new-frame-buffer ( class -- gadget )
-  frame-buffer construct-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 ;
 

extra/ui/gadgets/frames/frames-docs.factor

@@ -7,9 +7,7 @@ ARTICLE: "ui-frame-layout" "Frame layouts"
 { $subsection frame }
 "Creating empty frames:"
 { $subsection <frame> }
-"Creating new frames using a combinator:"
+"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 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, } ":"
 { $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"

extra/ui/gadgets/frames/frames.factor

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

extra/ui/gadgets/gadgets.factor

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

extra/ui/gadgets/grids/grids-docs.factor

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

extra/ui/gadgets/grids/grids.factor

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

extra/ui/gadgets/handler/handler.factor

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

extra/ui/gadgets/slots/slots.factor

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

extra/ui/gadgets/status-bar/status-bar.factor

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

extra/ui/gadgets/tracks/tracks-docs.factor

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

extra/ui/gadgets/tracks/tracks.factor

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

extra/ui/gadgets/worlds/worlds.factor

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

extra/ui/gadgets/wrappers/wrappers.factor

@@ -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-wrapper ( child class -- wrapper ) new-gadget swap add-gadget ;
-    new-gadget
-        [ swap add-gadget drop ] keep ; inline
 
-: <wrapper> ( child -- border )
+: <wrapper> ( child -- border ) wrapper new-wrapper ;
-    wrapper new-wrapper ;
 
-M: wrapper pref-dim*
+M: wrapper pref-dim* ( wrapper -- dim ) gadget-child pref-dim ;
-    gadget-child pref-dim ;
 
-M: wrapper layout*
+M: wrapper layout* ( wrapper -- )
     [ dim>> ] [ gadget-child ] bi set-layout-dim ;
 
-M: wrapper focusable-child*
+M: wrapper focusable-child* ( wrapper -- child/t ) gadget-child ;
-    gadget-child ;