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

core/sets/sets-docs.factor

@@ -38,6 +38,18 @@ HELP: adjoin
 }
 { $side-effects "seq" } ;
 
+HELP: conjoin
+{ $values { "elt" object } { "assoc" "an assoc" } }
+{ $description "Stores a key/value pair, both equal to " { $snippet "elt" } ", into the assoc." }
+{ $examples
+    { $example
+        "USING: kernel prettyprint sets ;"
+        "H{ } clone 1 over conjoin ."
+        "H{ { 1 1 } }"
+    }
+}
+{ $side-effects "assoc" } ;
+
 HELP: unique
 { $values { "seq" "a sequence" } { "assoc" "an assoc" } }
 { $description "Outputs a new assoc where the keys and values are equal." }

extra/assocs/lib/lib.factor

@@ -1,13 +1,8 @@
 USING: arrays assocs kernel vectors sequences namespaces
-random math.parser math fry ;
+       random math.parser math fry ;
+
 IN: assocs.lib
 
-: ref-at ( table key -- value ) swap at ;
-
-: put-at* ( table key value -- ) swap rot set-at ;
-
-: put-at ( table key value -- table ) swap pick set-at ;
-
 : set-assoc-stack ( value key seq -- )
     dupd [ key? ] with find-last nip set-at ;
 

extra/automata/automata.factor

@@ -32,7 +32,7 @@ dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ;
 ! step-wrapped-line
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: pattern>state ( {_a_b_c_} -- state ) >array rule> at ;
+: pattern>state ( {_a_b_c_} -- state ) rule> at ;
 
 : cap-line ( line -- 0-line-0 ) { 0 } prepend { 0 } append ;
 

extra/automata/ui/ui.factor

@@ -14,13 +14,25 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads
        ui.gadgets.packs
        ui.gadgets.grids
        ui.gadgets.theme
+       accessors
+       qualified
        namespaces.lib assocs.lib vars
-       rewrite-closures automata math.geometry.rect ;
+       rewrite-closures automata math.geometry.rect newfx ;
 
 IN: automata.ui
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+QUALIFIED: ui.gadgets
+QUALIFIED: ui.gadgets.grids
+
+: add-gadget ( parent child -- parent ) over ui.gadgets:add-gadget ;
+
+: 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 ;
@@ -57,29 +69,40 @@ slate> relayout-1 ;
 
 DEFER: automata-window
 
-: automata-window* ( -- ) init-rule set-interesting <frame>
+: automata-window* ( -- )
+  init-rule
+  set-interesting
 
-{
+  <frame>
-[ "1 - Center"      [ start-center    ] view-button ]
-[ "2 - Random"      [ start-random    ] view-button ]
-[ "3 - Continue"    [ run-rule        ] view-button ]
-[ "5 - Random Rule" [ random-rule     ] view-button ]
-[ "n - New"         [ automata-window ] view-button ]
-} make*
-[ [ gadget, ] curry ] map concat ! Hack
-make-shelf over @top grid-add
 
-[ display ] closed-quot <slate> { 400 400 } over set-slate-dim dup >slate
+    <shelf>
-over @center grid-add
 
-{
+      "1 - Center"      [ start-center    ] view-button add-gadget
-{ T{ key-down f f "1" } [ [ start-center    ] view-action ] }
+      "2 - Random"      [ start-random    ] view-button add-gadget
-{ T{ key-down f f "2" } [ [ start-random    ] view-action ] }
+      "3 - Continue"    [ run-rule        ] view-button add-gadget
-{ T{ key-down f f "3" } [ [ run-rule        ] view-action ] }
+      "5 - Random Rule" [ random-rule     ] view-button add-gadget
-{ T{ key-down f f "5" } [ [ random-rule     ] view-action ] }
+      "n - New"         [ automata-window ] view-button add-gadget
-{ T{ key-down f f "n" } [ [ automata-window ] view-action ] }
+
-} [ make* ] map >hashtable <handler> tuck set-gadget-delegate
+    @top grid-add
-"Automata" open-window ;
+
+    C[ display ] <slate>
+      { 400 400 } >>dim
+    dup >slate
+
+    @center grid-add
+
+  H{ }
+    T{ key-down f f "1" } [ start-center    ] view-action is
+    T{ key-down f f "2" } [ start-random    ] view-action is
+    T{ key-down f f "3" } [ run-rule        ] 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
+
+  "Automata" open-window ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

extra/boids/ui/ui.factor

@@ -20,7 +20,8 @@ USING: combinators.short-circuit kernel namespaces
        ui.gadgets.grids
        ui.gestures
        assocs.lib vars rewrite-closures boids accessors
-       math.geometry.rect ;
+       math.geometry.rect
+       newfx ;
 
 IN: boids.ui
 
@@ -145,20 +146,20 @@ VARS: population-label cohesion-label alignment-label separation-label ;
   slate> over @center grid-add
 
   H{ } clone
-    T{ key-down f f "1" } C[ drop randomize    ] put-at
+    T{ key-down f f "1" } C[ drop randomize    ] is
-    T{ key-down f f "2" } C[ drop sub-10-boids ] put-at
+    T{ key-down f f "2" } C[ drop sub-10-boids ] is
-    T{ key-down f f "3" } C[ drop add-10-boids ] put-at
+    T{ key-down f f "3" } C[ drop add-10-boids ] is
 
-    T{ key-down f f "q" } C[ drop inc-cohesion-weight ] put-at
+    T{ key-down f f "q" } C[ drop inc-cohesion-weight ] is
-    T{ key-down f f "a" } C[ drop dec-cohesion-weight ] put-at
+    T{ key-down f f "a" } C[ drop dec-cohesion-weight ] is
 
-    T{ key-down f f "w" } C[ drop inc-alignment-weight ] put-at
+    T{ key-down f f "w" } C[ drop inc-alignment-weight ] is
-    T{ key-down f f "s" } C[ drop dec-alignment-weight ] put-at
+    T{ key-down f f "s" } C[ drop dec-alignment-weight ] is
 
-    T{ key-down f f "e" } C[ drop inc-separation-weight ] put-at
+    T{ key-down f f "e" } C[ drop inc-separation-weight ] is
-    T{ key-down f f "d" } C[ drop dec-separation-weight ] put-at
+    T{ key-down f f "d" } C[ drop dec-separation-weight ] is
 
-    T{ key-down f f "ESC" } C[ drop toggle-loop ] put-at
+    T{ key-down f f "ESC" } C[ drop toggle-loop ] is
   <handler> tuck set-gadget-delegate "Boids" open-window ;
 
 : boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ;

extra/ui/gadgets/gadgets.factor

@@ -12,10 +12,10 @@ SYMBOL: ui-notify-flag
 : notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
 
 TUPLE: gadget < rect
-pref-dim parent children orientation focus
+       pref-dim parent children orientation focus
-visible? root? clipped? layout-state graft-state graft-node
+       visible? root? clipped? layout-state graft-state graft-node
-interior boundary
+       interior boundary
-model ;
+       model ;
 
 M: gadget equal? 2drop f ;
 
@@ -23,9 +23,9 @@ M: gadget hashcode* drop gadget hashcode* ;
 
 M: gadget model-changed 2drop ;
 
-: gadget-child ( gadget -- child ) gadget-children first ;
+: gadget-child ( gadget -- child ) children>> first ;
 
-: nth-gadget ( n gadget -- child ) gadget-children nth ;
+: nth-gadget ( n gadget -- child ) children>> nth ;
 
 : new-gadget ( class -- gadget )
     new
@@ -37,7 +37,7 @@ M: gadget model-changed 2drop ;
     gadget new-gadget ;
 
 : activate-control ( gadget -- )
-    dup gadget-model dup [
+    dup model>> dup [
         2dup add-connection
         swap model-changed
     ] [
@@ -45,20 +45,20 @@ M: gadget model-changed 2drop ;
     ] if ;
 
 : deactivate-control ( gadget -- )
-    dup gadget-model dup [ 2dup remove-connection ] when 2drop ;
+    dup model>> dup [ 2dup remove-connection ] when 2drop ;
 
 : control-value ( control -- value )
-    gadget-model model-value ;
+    model>> model-value ;
 
 : set-control-value ( value control -- )
-    gadget-model set-model ;
+    model>> set-model ;
 
 : relative-loc ( fromgadget togadget -- loc )
     2dup eq? [
         2drop { 0 0 }
     ] [
         over rect-loc >r
-        >r gadget-parent r> relative-loc
+        >r parent>> r> relative-loc
         r> v+
     ] if ;
 
@@ -68,22 +68,18 @@ M: gadget user-input* 2drop t ;
 
 GENERIC: children-on ( rect/point gadget -- seq )
 
-M: gadget children-on nip gadget-children ;
+M: gadget children-on nip children>> ;
 
 : (fast-children-on) ( dim axis gadgets -- i )
     swapd [ rect-loc v- over v. 0 <=> ] binsearch nip ;
 
 : fast-children-on ( rect axis children -- from to )
-    3dup
+    [ >r >r rect-loc r> r> (fast-children-on) 0 or ]
-    >r >r dup rect-loc swap rect-dim v+
+    [ >r >r dup rect-loc swap rect-dim v+ r> r> (fast-children-on) ?1+ ]
-    r> r> (fast-children-on) ?1+
+    3bi ;
-    >r
-    >r >r rect-loc
-    r> r> (fast-children-on) 0 or
-    r> ;
 
 : inside? ( bounds gadget -- ? )
-    dup gadget-visible? [ intersects? ] [ 2drop f ] if ;
+    dup visible?>> [ intersects? ] [ 2drop f ] if ;
 
 : (pick-up) ( point gadget -- gadget )
     dupd children-on [ inside? ] with find-last nip ;
@@ -97,10 +93,10 @@ M: gadget children-on nip gadget-children ;
 : dim-sum ( seq -- dim ) { 0 0 } [ v+ ] reduce ;
 
 : orient ( gadget seq1 seq2 -- seq )
-    >r >r gadget-orientation r> r> [ pick set-axis ] 2map nip ;
+    >r >r orientation>> r> r> [ pick set-axis ] 2map nip ;
 
 : each-child ( gadget quot -- )
-    >r gadget-children r> each ; inline
+    >r children>> r> each ; inline
 
 ! Selection protocol
 GENERIC: gadget-selection? ( gadget -- ? )
@@ -117,14 +113,14 @@ GENERIC: gadget-text* ( gadget -- )
 GENERIC: gadget-text-separator ( gadget -- str )
 
 M: gadget gadget-text-separator
-    gadget-orientation { 0 1 } = "\n" "" ? ;
+    orientation>> { 0 1 } = "\n" "" ? ;
 
 : gadget-seq-text ( seq gadget -- )
     gadget-text-separator swap
     [ dup % ] [ gadget-text* ] interleave drop ;
 
 M: gadget gadget-text*
-    dup gadget-children swap gadget-seq-text ;
+    dup children>> swap gadget-seq-text ;
 
 M: array gadget-text*
     [ gadget-text* ] each ;
@@ -132,9 +128,9 @@ M: array gadget-text*
 : gadget-text ( gadget -- string ) [ gadget-text* ] "" make ;
 
 : invalidate ( gadget -- )
-    \ invalidate swap set-gadget-layout-state ;
+    \ invalidate swap (>>layout-state) ;
 
-: forget-pref-dim ( gadget -- ) f swap set-gadget-pref-dim ;
+: forget-pref-dim ( gadget -- ) f swap (>>pref-dim) ;
 
 : layout-queue ( -- queue ) \ layout-queue get ;
 
@@ -147,22 +143,22 @@ M: array gadget-text*
 DEFER: relayout
 
 : invalidate* ( gadget -- )
-    \ invalidate* over set-gadget-layout-state
+    \ invalidate* over (>>layout-state)
     dup forget-pref-dim
     dup gadget-root?
-    [ layout-later ] [ gadget-parent [ relayout ] when* ] if ;
+    [ layout-later ] [ parent>> [ relayout ] when* ] if ;
 
 : relayout ( gadget -- )
-    dup gadget-layout-state \ invalidate* eq?
+    dup layout-state>> \ invalidate* eq?
     [ drop ] [ invalidate* ] if ;
 
 : relayout-1 ( gadget -- )
-    dup gadget-layout-state
+    dup layout-state>>
     [ drop ] [ dup invalidate layout-later ] if ;
 
-: show-gadget ( gadget -- ) t swap set-gadget-visible? ;
+: show-gadget ( gadget -- ) t swap (>>visible?) ;
 
-: hide-gadget ( gadget -- ) f swap set-gadget-visible? ;
+: hide-gadget ( gadget -- ) f swap (>>visible?) ;
 
 : (set-rect-dim) ( dim gadget quot -- )
     >r 2dup rect-dim =
@@ -178,11 +174,11 @@ DEFER: relayout
 GENERIC: pref-dim* ( gadget -- dim )
 
 : ?set-gadget-pref-dim ( dim gadget -- )
-    dup gadget-layout-state
+    dup layout-state>>
-    [ 2drop ] [ set-gadget-pref-dim ] if ;
+    [ 2drop ] [ (>>pref-dim) ] if ;
 
 : pref-dim ( gadget -- dim )
-    dup gadget-pref-dim [ ] [
+    dup pref-dim>> [ ] [
         [ pref-dim* dup ] keep ?set-gadget-pref-dim
     ] ?if ;
 
@@ -196,10 +192,10 @@ M: gadget layout* drop ;
 
 : prefer ( gadget -- ) dup pref-dim swap set-layout-dim ;
 
-: validate ( gadget -- ) f swap set-gadget-layout-state ;
+: validate ( gadget -- ) f swap (>>layout-state) ;
 
 : layout ( gadget -- )
-    dup gadget-layout-state [
+    dup layout-state>> [
         dup validate
         dup layout*
         dup [ layout ] each-child
@@ -223,7 +219,7 @@ M: gadget layout* drop ;
     { t f } (queue-graft) ;
 
 : graft-later ( gadget -- )
-    dup gadget-graft-state {
+    dup graft-state>> {
         { { f t } [ drop ] }
         { { t t } [ drop ] }
         { { t f } [ unqueue-graft ] }
@@ -231,7 +227,7 @@ M: gadget layout* drop ;
     } case ;
 
 : ungraft-later ( gadget -- )
-    dup gadget-graft-state {
+    dup graft-state>> {
         { { f f } [ drop ] }
         { { t f } [ drop ] }
         { { f t } [ unqueue-graft ] }
@@ -255,11 +251,11 @@ M: gadget ungraft* drop ;
 : (unparent) ( gadget -- )
     dup ungraft
     dup forget-pref-dim
-    f swap set-gadget-parent ;
+    f swap (>>parent) ;
 
 : unfocus-gadget ( child gadget -- )
-    tuck gadget-focus eq?
+    tuck focus>> eq?
-    [ f swap set-gadget-focus ] [ drop ] if ;
+    [ f swap (>>focus) ] [ drop ] if ;
 
 SYMBOL: in-layout?
 
@@ -270,10 +266,10 @@ SYMBOL: in-layout?
 : unparent ( gadget -- )
     not-in-layout
     [
-        dup gadget-parent dup [
+        dup parent>> dup [
             over (unparent)
             [ unfocus-gadget ] 2keep
-            [ gadget-children delete ] keep
+            [ children>> delete ] keep
             relayout
         ] [
             2drop
@@ -282,21 +278,21 @@ SYMBOL: in-layout?
 
 : (clear-gadget) ( gadget -- )
     dup [ (unparent) ] each-child
-    f over set-gadget-focus
+    f over (>>focus)
-    f swap set-gadget-children ;
+    f swap (>>children) ;
 
 : clear-gadget ( gadget -- )
     not-in-layout
     dup (clear-gadget) relayout ;
 
 : ((add-gadget)) ( gadget box -- )
-    [ gadget-children ?push ] keep set-gadget-children ;
+    [ children>> ?push ] keep (>>children) ;
 
 : (add-gadget) ( gadget box -- )
     over unparent
-    dup pick set-gadget-parent
+    dup pick (>>parent)
     [ ((add-gadget)) ] 2keep
-    gadget-graft-state second [ graft ] [ drop ] if ;
+    graft-state>> second [ graft ] [ drop ] if ;
 
 : add-gadget ( gadget parent -- )
     not-in-layout
@@ -307,7 +303,7 @@ SYMBOL: in-layout?
     swap [ over (add-gadget) ] each relayout ;
 
 : parents ( gadget -- seq )
-    [ gadget-parent ] follow ;
+    [ parent>> ] follow ;
 
 : each-parent ( gadget quot -- ? )
     >r parents r> all? ; inline
@@ -319,7 +315,7 @@ SYMBOL: in-layout?
     parents { 0 0 } [ rect-loc v+ ] reduce ;
 
 : (screen-rect) ( gadget -- loc ext )
-    dup gadget-parent [
+    dup parent>> [
         >r rect-extent r> (screen-rect)
         >r tuck v+ r> vmin >r v+ r>
     ] [
@@ -333,7 +329,7 @@ SYMBOL: in-layout?
     {
         { [ 2dup eq? ] [ 2drop t ] }
         { [ dup not ] [ 2drop f ] }
-        [ gadget-parent child? ]
+        [ parent>> child? ]
     } cond ;
 
 GENERIC: focusable-child* ( gadget -- child/t )
@@ -346,7 +342,7 @@ M: gadget focusable-child* drop t ;
 
 GENERIC: request-focus-on ( child gadget -- )
 
-M: gadget request-focus-on gadget-parent request-focus-on ;
+M: gadget request-focus-on parent>> request-focus-on ;
 
 M: f request-focus-on 2drop ;
 
@@ -354,7 +350,7 @@ M: f request-focus-on 2drop ;
     [ focusable-child ] keep request-focus-on ;
 
 : focus-path ( world -- seq )
-    [ gadget-focus ] follow ;
+    [ focus>> ] follow ;
 
 : gadget, ( gadget -- ) gadget get add-gadget ;
 
@@ -371,7 +367,7 @@ M: f request-focus-on 2drop ;
 ! Deprecated
 : set-gadget-delegate ( gadget tuple -- )
     over [
-        dup pick [ set-gadget-parent ] with each-child
+        dup pick [ (>>parent) ] with each-child
     ] when set-delegate ;
 
 : construct-gadget ( class -- tuple )