From c1328ac08e0500dcce7bba0c600d13cd386da884 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 12:22:27 -0500 Subject: [PATCH 01/35] math.physics.pos: distance method --- extra/math/physics/pos/pos.factor | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/extra/math/physics/pos/pos.factor b/extra/math/physics/pos/pos.factor index 1582c42108..69155686c8 100644 --- a/extra/math/physics/pos/pos.factor +++ b/extra/math/physics/pos/pos.factor @@ -1,5 +1,17 @@ +USING: kernel sequences multi-methods accessors math.vectors ; + IN: math.physics.pos TUPLE: pos pos ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +GENERIC: distance ( a b -- c ) + +METHOD: distance { sequence sequence } v- norm ; + +METHOD: distance { pos pos } [ pos>> ] bi@ distance ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + From 3bb6d9e57256fb17ee63ab7022bf2645f22f1233 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 12:29:51 -0500 Subject: [PATCH 02/35] boids: use 'distance' method --- extra/boids/boids.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor index cff33c9d19..ab624a606b 100644 --- a/extra/boids/boids.factor +++ b/extra/boids/boids.factor @@ -73,10 +73,6 @@ VAR: separation-radius ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: distance ( boid boid -- n ) [ pos>> ] [ pos>> ] bi* v- norm ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : constrain ( n a b -- n ) rot min max ; : angle-between ( vec vec -- angle ) From 4a9363091ec9bfae869eb3ba2fe2a9243d295998 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 13:05:51 -0500 Subject: [PATCH 03/35] springies: use new accessors --- extra/springies/springies.factor | 46 ++++++++++++++------------------ 1 file changed, 20 insertions(+), 26 deletions(-) diff --git a/extra/springies/springies.factor b/extra/springies/springies.factor index fb69783975..818aa675e2 100755 --- a/extra/springies/springies.factor +++ b/extra/springies/springies.factor @@ -28,16 +28,10 @@ VAR: gravity ! node ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TUPLE: node mass elas pos vel force ; - TUPLE: node < vel mass elas force ; C: node -! : >>pos ( node pos -- node ) over set-node-pos ; - -! : >>vel ( node vel -- node ) over set-node-vel ; - : node-vel ( node -- vel ) vel>> ; : set-node-vel ( vel node -- ) swap >>vel drop ; @@ -52,9 +46,9 @@ C: node : >>vel-x ( node x -- node ) over vel>> set-first ; : >>vel-y ( node y -- node ) over vel>> set-second ; -: apply-force ( node vec -- ) over node-force v+ swap set-node-force ; +: apply-force ( node vec -- ) over force>> v+ >>force drop ; -: reset-force ( node -- ) 0 0 2array swap set-node-force ; +: reset-force ( node -- node ) 0 0 2array >>force ; : node-id ( id -- node ) 1- nodes> nth ; @@ -67,12 +61,12 @@ TUPLE: spring rest-length k damp node-a node-b ; C: spring : end-points ( spring -- b-pos a-pos ) - [ spring-node-b pos>> ] [ spring-node-a pos>> ] bi ; + [ node-b>> pos>> ] [ node-a>> pos>> ] bi ; : spring-length ( spring -- length ) end-points v- norm ; : stretch-length ( spring -- length ) - [ spring-length ] [ spring-rest-length ] bi - ; + [ spring-length ] [ rest-length>> ] bi - ; : dir ( spring -- vec ) end-points v- normalize ; @@ -87,14 +81,14 @@ C: spring ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: hooke-force-mag ( spring -- mag ) [ spring-k ] [ stretch-length ] bi * ; +: hooke-force-mag ( spring -- mag ) [ k>> ] [ stretch-length ] bi * ; : hooke-force ( spring -- force ) [ dir ] [ hooke-force-mag ] bi v*n ; : hooke-forces ( spring -- a b ) hooke-force dup vneg ; : act-on-nodes-hooke ( spring -- ) - [ spring-node-a ] [ spring-node-b ] [ ] tri hooke-forces swapd + [ node-a>> ] [ node-b>> ] [ ] tri hooke-forces swapd apply-force apply-force ; @@ -118,37 +112,37 @@ C: spring ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : relative-velocity-a ( spring -- vel ) - [ spring-node-a vel>> ] [ spring-node-b vel>> ] bi v- ; + [ node-a>> vel>> ] [ node-b>> vel>> ] bi v- ; : unit-vec-b->a ( spring -- vec ) - [ spring-node-a pos>> ] [ spring-node-b pos>> ] bi v- ; + [ node-a>> pos>> ] [ node-b>> pos>> ] bi v- ; : relative-velocity-along-spring-a ( spring -- vel ) [ relative-velocity-a ] [ unit-vec-b->a ] bi vector-projection ; : damping-force-a ( spring -- vec ) - [ relative-velocity-along-spring-a ] [ spring-damp ] bi v*n vneg ; + [ relative-velocity-along-spring-a ] [ damp>> ] bi v*n vneg ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : relative-velocity-b ( spring -- vel ) - [ spring-node-b vel>> ] [ spring-node-a vel>> ] bi v- ; + [ node-b>> vel>> ] [ node-a>> vel>> ] bi v- ; : unit-vec-a->b ( spring -- vec ) - [ spring-node-b pos>> ] [ spring-node-a pos>> ] bi v- ; + [ node-b>> pos>> ] [ node-a>> pos>> ] bi v- ; : relative-velocity-along-spring-b ( spring -- vel ) [ relative-velocity-b ] [ unit-vec-a->b ] bi vector-projection ; : damping-force-b ( spring -- vec ) - [ relative-velocity-along-spring-b ] [ spring-damp ] bi v*n vneg ; + [ relative-velocity-along-spring-b ] [ damp>> ] bi v*n vneg ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : act-on-nodes-damping ( spring -- ) dup - [ spring-node-a ] [ damping-force-a ] bi apply-force - [ spring-node-b ] [ damping-force-b ] bi apply-force ; + [ node-a>> ] [ damping-force-a ] bi apply-force + [ node-b>> ] [ damping-force-b ] bi apply-force ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -164,22 +158,22 @@ C: spring : bounce-top ( node -- ) world-height 1- >>pos-y - dup [ vel-y ] [ node-elas ] bi * neg >>vel-y + dup [ vel-y ] [ elas>> ] bi * neg >>vel-y drop ; : bounce-bottom ( node -- ) 0 >>pos-y - dup [ vel-y ] [ node-elas ] bi * neg >>vel-y + dup [ vel-y ] [ elas>> ] bi * neg >>vel-y drop ; : bounce-left ( node -- ) 0 >>pos-x - dup [ vel-x ] [ node-elas ] bi * neg >>vel-x + dup [ vel-x ] [ elas>> ] bi * neg >>vel-x drop ; : bounce-right ( node -- ) world-width 1- >>pos-x - dup [ vel-x ] [ node-elas ] bi * neg >>vel-x + dup [ vel-x ] [ elas>> ] bi * neg >>vel-x drop ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -213,7 +207,7 @@ C: spring ! F = ma -: calc-acceleration ( node -- vec ) [ node-force ] [ node-mass ] bi v/n ; +: calc-acceleration ( node -- vec ) [ force>> ] [ mass>> ] bi v/n ; : new-vel ( node -- vel ) [ vel>> ] [ calc-acceleration time-slice> v*n ] bi v+ ; @@ -223,7 +217,7 @@ C: spring : iterate-node ( node -- ) dup new-pos >>pos dup new-vel >>vel - dup reset-force + reset-force handle-bounce ; : iterate-nodes ( -- ) nodes> [ iterate-node ] each ; From 8160859c8b61cb63bb0308a959d1920b3f0ad21f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Jul 2008 13:12:45 -0500 Subject: [PATCH 04/35] Fixes --- core/classes/tuple/parser/parser-tests.factor | 2 +- core/optimizer/math/math.factor | 5 ++++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor index 10cbe268da..d40b71b477 100644 --- a/core/classes/tuple/parser/parser-tests.factor +++ b/core/classes/tuple/parser/parser-tests.factor @@ -51,7 +51,7 @@ must-fail-with [ error>> unexpected-eof? ] must-fail-with -[ "IN: classes.tuple.parser.tests USE: generic.standard TUPLE: foo { slot no-method } ;" eval ] +[ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval ] [ error>> no-initial-value? ] must-fail-with diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index 799f4d80cf..b208a9f894 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -444,7 +444,10 @@ most-negative-fixnum most-positive-fixnum [a,b] { /f < > <= >= } [ { real real } "input-classes" set-word-prop ] each -{ /i bitand bitor bitxor bitnot shift } +{ /i mod /mod } +[ { rational rational } "input-classes" set-word-prop ] each + +{ bitand bitor bitxor bitnot shift } [ { integer integer } "input-classes" set-word-prop ] each { From 80a38f8990d473fa5bc63709ce44357c8df0413b Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 15:48:20 -0500 Subject: [PATCH 05/35] boids.ui: use newfx --- extra/boids/ui/ui.factor | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/extra/boids/ui/ui.factor b/extra/boids/ui/ui.factor index ab1f8e5f80..b1f594b8c2 100755 --- a/extra/boids/ui/ui.factor +++ b/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 "2" } C[ drop sub-10-boids ] put-at - T{ key-down f f "3" } C[ drop add-10-boids ] put-at + T{ key-down f f "1" } C[ drop randomize ] is + T{ key-down f f "2" } C[ drop sub-10-boids ] is + 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 "a" } C[ drop dec-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 ] is - T{ key-down f f "w" } C[ drop inc-alignment-weight ] put-at - T{ key-down f f "s" } C[ drop dec-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 ] is - T{ key-down f f "e" } C[ drop inc-separation-weight ] put-at - T{ key-down f f "d" } C[ drop dec-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 ] is - T{ key-down f f "ESC" } C[ drop toggle-loop ] put-at + T{ key-down f f "ESC" } C[ drop toggle-loop ] is tuck set-gadget-delegate "Boids" open-window ; : boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ; From 44c2b9823de331a9ab3e97cf63704693d0108904 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 15:49:14 -0500 Subject: [PATCH 06/35] assocs.lib: remove old code --- extra/assocs/lib/lib.factor | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index 14632df771..5036a13d78 100755 --- a/extra/assocs/lib/lib.factor +++ b/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 ; From 2374b4293d0c35cad3137a5ac086f781fd5ae2ca Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 15:53:20 -0500 Subject: [PATCH 07/35] automata: no need for >array when using --- extra/automata/automata.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/automata/automata.factor b/extra/automata/automata.factor index a70eaa063d..979a733692 100644 --- a/extra/automata/automata.factor +++ b/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 ; From 5decac30d2861c4649c8c08ca131cd9c32f206ea Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 16:46:50 -0500 Subject: [PATCH 08/35] automata.ui: new automata-window* --- extra/automata/ui/ui.factor | 65 +++++++++++++++++++++++++------------ 1 file changed, 44 insertions(+), 21 deletions(-) diff --git a/extra/automata/ui/ui.factor b/extra/automata/ui/ui.factor index cfec6597c2..5678a6f06b 100644 --- a/extra/automata/ui/ui.factor +++ b/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 +: automata-window* ( -- ) + init-rule + set-interesting -{ -[ "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 { 400 400 } over set-slate-dim dup >slate -over @center grid-add + -{ -{ T{ key-down f f "1" } [ [ start-center ] view-action ] } -{ T{ key-down f f "2" } [ [ start-random ] view-action ] } -{ T{ key-down f f "3" } [ [ run-rule ] view-action ] } -{ T{ key-down f f "5" } [ [ random-rule ] view-action ] } -{ T{ key-down f f "n" } [ [ automata-window ] view-action ] } -} [ make* ] map >hashtable tuck set-gadget-delegate -"Automata" open-window ; + "1 - Center" [ start-center ] view-button add-gadget + "2 - Random" [ start-random ] view-button add-gadget + "3 - Continue" [ run-rule ] view-button add-gadget + "5 - Random Rule" [ random-rule ] view-button add-gadget + "n - New" [ automata-window ] view-button add-gadget + + @top grid-add + + C[ display ] + { 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 + + + + tuck set-gadget-delegate + + "Automata" open-window ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From e16aa9ead3c2873e3def98f8904d0f5f8238af18 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 17:45:57 -0500 Subject: [PATCH 09/35] ui.gadgets: update parent accessors --- extra/ui/gadgets/gadgets.factor | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index a274dc2392..fcb6c765a3 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/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 -visible? root? clipped? layout-state graft-state graft-node -interior boundary -model ; + pref-dim parent children orientation focus + visible? root? clipped? layout-state graft-state graft-node + interior boundary + model ; M: gadget equal? 2drop f ; @@ -58,7 +58,7 @@ M: gadget model-changed 2drop ; 2drop { 0 0 } ] [ over rect-loc >r - >r gadget-parent r> relative-loc + >r parent>> r> relative-loc r> v+ ] if ; @@ -150,7 +150,7 @@ DEFER: relayout \ invalidate* over set-gadget-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? @@ -255,7 +255,7 @@ 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? @@ -270,7 +270,7 @@ SYMBOL: in-layout? : unparent ( gadget -- ) not-in-layout [ - dup gadget-parent dup [ + dup parent>> dup [ over (unparent) [ unfocus-gadget ] 2keep [ gadget-children delete ] keep @@ -294,7 +294,7 @@ SYMBOL: in-layout? : (add-gadget) ( gadget box -- ) over unparent - dup pick set-gadget-parent + dup pick (>>parent) [ ((add-gadget)) ] 2keep gadget-graft-state second [ graft ] [ drop ] if ; @@ -307,7 +307,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 +319,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 +333,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 +346,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 ; @@ -371,7 +371,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 ) From a4678cc758d0813e4502badedaad9a20755230f1 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 17:48:08 -0500 Subject: [PATCH 10/35] ui.gadgets: update children accessors --- extra/ui/gadgets/gadgets.factor | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index fcb6c765a3..62d01d844b 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -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 @@ -68,7 +68,7 @@ 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 ; @@ -100,7 +100,7 @@ M: gadget children-on nip gadget-children ; >r >r gadget-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 -- ? ) @@ -124,7 +124,7 @@ M: gadget gadget-text-separator [ 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 ; @@ -273,7 +273,7 @@ SYMBOL: in-layout? dup parent>> dup [ over (unparent) [ unfocus-gadget ] 2keep - [ gadget-children delete ] keep + [ children>> delete ] keep relayout ] [ 2drop @@ -283,14 +283,14 @@ SYMBOL: in-layout? : (clear-gadget) ( gadget -- ) dup [ (unparent) ] each-child f over set-gadget-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 From 33da43aa907b7d392bab6551d31137b552dd8010 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 17:54:57 -0500 Subject: [PATCH 11/35] ui.gadgets: more accessor updates --- extra/ui/gadgets/gadgets.factor | 46 ++++++++++++++++----------------- 1 file changed, 23 insertions(+), 23 deletions(-) diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 62d01d844b..6f49791164 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -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,13 +45,13 @@ 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? [ @@ -83,7 +83,7 @@ M: gadget children-on nip children>> ; 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,7 +97,7 @@ M: gadget children-on nip 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 children>> r> each ; inline @@ -117,7 +117,7 @@ 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 @@ -132,9 +132,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 +147,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 ] [ 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 +178,11 @@ DEFER: relayout GENERIC: pref-dim* ( gadget -- dim ) : ?set-gadget-pref-dim ( dim gadget -- ) - dup gadget-layout-state - [ 2drop ] [ set-gadget-pref-dim ] if ; + dup layout-state>> + [ 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 +196,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 @@ -258,8 +258,8 @@ M: gadget ungraft* drop ; f swap (>>parent) ; : unfocus-gadget ( child gadget -- ) - tuck gadget-focus eq? - [ f swap set-gadget-focus ] [ drop ] if ; + tuck focus>> eq? + [ f swap (>>focus) ] [ drop ] if ; SYMBOL: in-layout? @@ -282,7 +282,7 @@ SYMBOL: in-layout? : (clear-gadget) ( gadget -- ) dup [ (unparent) ] each-child - f over set-gadget-focus + f over (>>focus) f swap (>>children) ; : clear-gadget ( gadget -- ) @@ -354,7 +354,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 ; From 80783019c2773a0416d304baac7b4ce32b11a3cd Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 17:57:57 -0500 Subject: [PATCH 12/35] ui.gadgets: cleaner fast-children-on --- extra/ui/gadgets/gadgets.factor | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 6f49791164..f5e1f35081 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -74,13 +74,9 @@ M: gadget children-on nip children>> ; swapd [ rect-loc v- over v. 0 <=> ] binsearch nip ; : fast-children-on ( rect axis children -- from to ) - 3dup - >r >r dup rect-loc swap rect-dim v+ - r> r> (fast-children-on) ?1+ - >r - >r >r rect-loc - r> r> (fast-children-on) 0 or - r> ; + [ >r >r rect-loc r> r> (fast-children-on) 0 or ] + [ >r >r dup rect-loc swap rect-dim v+ r> r> (fast-children-on) ?1+ ] + 3bi ; : inside? ( bounds gadget -- ? ) dup visible?>> [ intersects? ] [ 2drop f ] if ; From 49f58ce15b30a06c5cc6eda1a67f40bdd2b1fed5 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 17:58:44 -0500 Subject: [PATCH 13/35] ui.gadgets: proper indentation --- extra/ui/gadgets/gadgets.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index f5e1f35081..59041c6115 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -74,9 +74,9 @@ M: gadget children-on nip children>> ; swapd [ rect-loc v- over v. 0 <=> ] binsearch nip ; : fast-children-on ( rect axis children -- from to ) - [ >r >r rect-loc r> r> (fast-children-on) 0 or ] - [ >r >r dup rect-loc swap rect-dim v+ r> r> (fast-children-on) ?1+ ] - 3bi ; + [ >r >r rect-loc r> r> (fast-children-on) 0 or ] + [ >r >r dup rect-loc swap rect-dim v+ r> r> (fast-children-on) ?1+ ] + 3bi ; : inside? ( bounds gadget -- ? ) dup visible?>> [ intersects? ] [ 2drop f ] if ; From 32ca39ce8580590003da788d5f35c49d8d0d0e9e Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 18:02:32 -0500 Subject: [PATCH 14/35] ui.gadgets: more accessors updates --- extra/ui/gadgets/gadgets.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 59041c6115..3fc185a10e 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -219,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 ] } @@ -227,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 ] } @@ -292,7 +292,7 @@ SYMBOL: in-layout? over unparent 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 From 0770d50d7b67c810c571dfbe049faba0c7d53cc6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Jul 2008 18:52:31 -0500 Subject: [PATCH 15/35] Bi-assocs: fast at and value-at --- core/assocs/assocs.factor | 9 ++++--- extra/biassocs/biassocs-tests.factor | 22 +++++++++++++++++ extra/biassocs/biassocs.factor | 35 ++++++++++++++++++++++++++++ 3 files changed, 63 insertions(+), 3 deletions(-) create mode 100644 extra/biassocs/biassocs-tests.factor create mode 100644 extra/biassocs/biassocs.factor diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index f56ac810d9..6cb8958298 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -144,10 +144,13 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) : extract-keys ( seq assoc -- subassoc ) [ [ dupd at ] curry ] keep map>assoc ; -! M: assoc >alist [ 2array ] { } assoc>map ; +GENERIC: value-at* ( value assoc -- key/f ? ) -: value-at ( value assoc -- key/f ) - swap [ = nip ] curry assoc-find 2drop ; +M: assoc value-at* swap [ = nip ] curry assoc-find nip ; + +: value-at ( value assoc -- key/f ) value-at* drop ; + +: value? ( value assoc -- ? ) value-at* nip ; : push-at ( value key assoc -- ) [ ?push ] change-at ; diff --git a/extra/biassocs/biassocs-tests.factor b/extra/biassocs/biassocs-tests.factor new file mode 100644 index 0000000000..4cd7f00f80 --- /dev/null +++ b/extra/biassocs/biassocs-tests.factor @@ -0,0 +1,22 @@ +IN: biassocs.tests +USING: biassocs assocs namespaces tools.test ; + + "h" set + +[ 0 ] [ "h" get assoc-size ] unit-test + +[ ] [ 1 2 "h" get set-at ] unit-test + +[ 1 ] [ 2 "h" get at ] unit-test + +[ 2 ] [ 1 "h" get value-at ] unit-test + +[ 1 ] [ "h" get assoc-size ] unit-test + +[ ] [ 1 3 "h" get set-at ] unit-test + +[ 1 ] [ 3 "h" get at ] unit-test + +[ 2 ] [ 1 "h" get value-at ] unit-test + +[ 2 ] [ "h" get assoc-size ] unit-test diff --git a/extra/biassocs/biassocs.factor b/extra/biassocs/biassocs.factor new file mode 100644 index 0000000000..9f12d04fc4 --- /dev/null +++ b/extra/biassocs/biassocs.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel assocs accessors ; +IN: biassocs + +TUPLE: biassoc from to ; + +: ( exemplar -- biassoc ) + [ clone ] [ clone ] bi biassoc boa ; + +: ( -- bihashtable ) + H{ } ; + +M: biassoc assoc-size from>> assoc-size ; + +M: biassoc at* from>> at* ; + +M: biassoc value-at* to>> at* ; + +: once-at ( value key assoc -- ) + 2dup key? [ 3drop ] [ set-at ] if ; + +M: biassoc set-at + [ from>> set-at ] [ swapd to>> once-at ] 3bi ; + +M: biassoc delete-at + "biassocs do not support deletion" throw ; + +M: biassoc >alist + from>> >alist ; + +M: biassoc clear-assoc + [ from>> clear-assoc ] [ to>> clear-assoc ] bi ; + +INSTANCE: biassoc assoc From eda828169465529cb2bb05b21dbc1d237ad8470d Mon Sep 17 00:00:00 2001 From: erg Date: Sat, 12 Jul 2008 20:56:44 -0500 Subject: [PATCH 16/35] document conjoin --- core/sets/sets-docs.factor | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor index 205d4d34bf..57d62f6480 100644 --- a/core/sets/sets-docs.factor +++ b/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." } From a700ec70418a6801f4bc364d2f3d48f8f9ea665e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Jul 2008 21:15:11 -0500 Subject: [PATCH 17/35] More efficient float arrayss; 15% improvement on spectral-norm --- core/alien/c-types/c-types.factor | 3 ++- extra/float-arrays/float-arrays.factor | 24 ++++++++---------------- 2 files changed, 10 insertions(+), 17 deletions(-) diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index e576b87f52..405d679f4a 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -151,7 +151,8 @@ M: byte-array byte-length length ; swap dup length memcpy ; : (define-nth) ( word type quot -- ) - >r heap-size [ rot * ] swap prefix r> append define-inline ; + >r heap-size [ rot * >fixnum ] swap prefix + r> append define-inline ; : nth-word ( name vocab -- word ) >r "-nth" append r> create ; diff --git a/extra/float-arrays/float-arrays.factor b/extra/float-arrays/float-arrays.factor index 668bb7de41..0aa7fa5056 100755 --- a/extra/float-arrays/float-arrays.factor +++ b/extra/float-arrays/float-arrays.factor @@ -9,16 +9,8 @@ TUPLE: float-array { length array-capacity read-only } { underlying byte-array read-only } ; -bytes 8 * ; inline - -: float-array@ underlying>> swap >fixnum floats>bytes ; inline - -PRIVATE> - : ( n -- float-array ) - dup floats>bytes float-array boa ; inline + dup "double" float-array boa ; inline M: float-array clone [ length>> ] [ underlying>> clone ] bi float-array boa ; @@ -26,13 +18,13 @@ M: float-array clone M: float-array length length>> ; M: float-array nth-unsafe - float-array@ alien-double ; + underlying>> double-nth ; M: float-array set-nth-unsafe - [ >float ] 2dip float-array@ set-alien-double ; + [ >float ] 2dip underlying>> set-double-nth ; : >float-array ( seq -- float-array ) - T{ float-array f 0 B{ } } clone-like ; inline + T{ float-array } clone-like ; inline M: float-array like drop dup float-array? [ >float-array ] unless ; @@ -45,7 +37,7 @@ M: float-array equal? M: float-array resize [ drop ] [ - [ floats>bytes ] [ underlying>> ] bi* + [ "double" heap-size * ] [ underlying>> ] bi* resize-byte-array ] 2bi float-array boa ; @@ -58,13 +50,13 @@ INSTANCE: float-array sequence 1 [ set-first ] keep ; flushable : 2float-array ( x y -- array ) - T{ float-array f 0 B{ } } 2sequence ; flushable + T{ float-array } 2sequence ; flushable : 3float-array ( x y z -- array ) - T{ float-array f 0 B{ } } 3sequence ; flushable + T{ float-array } 3sequence ; flushable : 4float-array ( w x y z -- array ) - T{ float-array f 0 B{ } } 4sequence ; flushable + T{ float-array } 4sequence ; flushable : F{ ( parsed -- parsed ) \ } [ >float-array ] parse-literal ; parsing From f1879cb33788a91479ebb421d4f1fc8219a8447b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Jul 2008 21:28:43 -0500 Subject: [PATCH 18/35] Doc updates --- core/assocs/assocs-docs.factor | 20 +++++++++++++++++--- core/grouping/grouping-docs.factor | 4 ++++ extra/biassocs/authors.txt | 1 + extra/biassocs/biassocs-docs.factor | 28 ++++++++++++++++++++++++++++ extra/biassocs/biassocs.factor | 2 +- extra/biassocs/summary.txt | 1 + extra/biassocs/tags.txt | 1 + extra/bitfields/tags.txt | 1 - extra/lists/tags.txt | 4 +--- 9 files changed, 54 insertions(+), 8 deletions(-) create mode 100644 extra/biassocs/authors.txt create mode 100644 extra/biassocs/biassocs-docs.factor create mode 100644 extra/biassocs/summary.txt create mode 100644 extra/biassocs/tags.txt diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 0e1042391c..51293955d5 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -57,13 +57,19 @@ ARTICLE: "assocs-lookup" "Lookup and querying of assocs" "Utility operations built up from the " { $link "assocs-protocol" } ":" { $subsection key? } { $subsection at } -{ $subsection value-at } { $subsection assoc-empty? } { $subsection keys } { $subsection values } { $subsection assoc-stack } { $see-also at* assoc-size } ; +ARTICLE: "assocs-values" "Transposed assoc operations" +"Most assoc words take a key and find the corresponding value. The following words take a value and find the corresponding key:" +{ $subsection value-at } +{ $subsection value-at* } +{ $subsection value? } +"With most assoc implementations, these words runs in linear time, proportional to the number of entries in the assoc. For fast value lookups, use " { $vocab-link "biassocs" } "." ; + ARTICLE: "assocs-sets" "Set-theoretic operations on assocs" "It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)." { $subsection assoc-subset? } @@ -111,6 +117,7 @@ $nl { $subsection "assocs-protocol" } "A large set of utility words work on any object whose class implements the associative mapping protocol." { $subsection "assocs-lookup" } +{ $subsection "assocs-values" } { $subsection "assocs-mutation" } { $subsection "assocs-combinators" } { $subsection "assocs-sets" } ; @@ -231,10 +238,17 @@ HELP: assoc-stack { $description "Searches for the key in successive elements of the sequence, starting from the end. If an assoc containing the key is found, the associated value is output. If no assoc contains the key, outputs " { $link f } "." } { $notes "This word is used to implement abstractions such as nested scopes; if the sequence is a stack represented by a vector, then the most recently pushed assoc -- the innermost scope -- will be searched first." } ; +HELP: value-at* +{ $values { "value" "an object" } { "assoc" assoc } { "key/f" "the key associated to the value, or " { $link f } } { "?" "a boolean" } } +{ $description "Looks up the key associated with a value. The boolean flag can decide beteen the case of a missing key, and a key of " { $link f } "." } ; + HELP: value-at { $values { "value" "an object" } { "assoc" assoc } { "key/f" "the key associated to the value, or " { $link f } } } -{ $description "Looks up the key associated with a value. No distinction is made between a missing key and a key set to " { $link f } "." } -{ $notes "This word runs in linear time, proportional to the number of entries in the assoc." } ; +{ $description "Looks up the key associated with a value. No distinction is made between a missing key and a key set to " { $link f } "." } ; + +HELP: value? +{ $values { "value" "an object" } { "assoc" assoc } { "?" "a boolean" } } +{ $description "Tests if an assoc contains at least one key with the given value." } ; HELP: delete-at* { $values { "key" "a key" } { "assoc" assoc } { "old" "the previous value or " { $link f } } { "?" "a boolean" } } diff --git a/core/grouping/grouping-docs.factor b/core/grouping/grouping-docs.factor index f7a37691a6..3b3a98eabd 100644 --- a/core/grouping/grouping-docs.factor +++ b/core/grouping/grouping-docs.factor @@ -2,10 +2,14 @@ USING: help.markup help.syntax sequences strings ; IN: grouping ARTICLE: "grouping" "Groups and clumps" +"Splitting a sequence into disjoint, fixed-length subsequences:" +{ $subsection group } "A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:" { $subsection groups } { $subsection } { $subsection } +"Splitting a sequence into overlapping, fixed-length subsequences:" +{ $subsection clump } "A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:" { $subsection clumps } { $subsection } diff --git a/extra/biassocs/authors.txt b/extra/biassocs/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/biassocs/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/biassocs/biassocs-docs.factor b/extra/biassocs/biassocs-docs.factor new file mode 100644 index 0000000000..1fde3d05b3 --- /dev/null +++ b/extra/biassocs/biassocs-docs.factor @@ -0,0 +1,28 @@ +IN: biassocs +USING: help.markup help.syntax assocs kernel ; + +HELP: biassoc +{ $class-description "The class of bidirectional assocs. Bidirectional assoc are implemented by combining two assocs, with one the transpose of the other." } ; + +HELP: +{ $values { "exemplar" assoc } { "biassoc" biassoc } } +{ $description "Creates a new biassoc using a new assoc of the same type as " { $snippet "exemplar" } " for underlying storage." } ; + +HELP: +{ $values { "biassoc" biassoc } } +{ $description "Creates a new biassoc using a pair of hashtables for underlying storage." } ; + +HELP: once-at +{ $values { "value" object } { "key" object } { "assoc" assoc } } +{ $description "If the assoc does not contain the given key, adds the key/value pair to the assoc, otherwise does nothing." } ; + +ARTICLE: "biassocs" "Bidirectional assocs" +"A " { $emphasis "bidirectional assoc" } " combines a pair of assocs to form a data structure where both normal assoc opeartions (eg, " { $link at } "), as well as " { $link "assocs-values" } " (eg, " { $link value-at } ") run in sub-linear time." +$nl +"Bidirectional assocs implement the entire assoc protocol with the exception of " { $link delete-at } ". Duplicate values are allowed, however value lookups with " { $link value-at } " only return the first key that a given value was stored with." +{ $subsection biassoc } +{ $subsection biassoc? } +{ $subsection } +{ $subsection } ; + +ABOUT: "biassocs" diff --git a/extra/biassocs/biassocs.factor b/extra/biassocs/biassocs.factor index 9f12d04fc4..cd1e57f6ec 100644 --- a/extra/biassocs/biassocs.factor +++ b/extra/biassocs/biassocs.factor @@ -8,7 +8,7 @@ TUPLE: biassoc from to ; : ( exemplar -- biassoc ) [ clone ] [ clone ] bi biassoc boa ; -: ( -- bihashtable ) +: ( -- biassoc ) H{ } ; M: biassoc assoc-size from>> assoc-size ; diff --git a/extra/biassocs/summary.txt b/extra/biassocs/summary.txt new file mode 100644 index 0000000000..84c5b15afc --- /dev/null +++ b/extra/biassocs/summary.txt @@ -0,0 +1 @@ +Bidirectional assocs diff --git a/extra/biassocs/tags.txt b/extra/biassocs/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/extra/biassocs/tags.txt @@ -0,0 +1 @@ +collections diff --git a/extra/bitfields/tags.txt b/extra/bitfields/tags.txt index 9ffc038dbd..f4274299b1 100644 --- a/extra/bitfields/tags.txt +++ b/extra/bitfields/tags.txt @@ -1,2 +1 @@ -collections extensions diff --git a/extra/lists/tags.txt b/extra/lists/tags.txt index e44334b2b5..42d711b32b 100644 --- a/extra/lists/tags.txt +++ b/extra/lists/tags.txt @@ -1,3 +1 @@ -cons -lists -sequences +collections From 16b85df5db54c427c036db81614dd49d836b52d3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Jul 2008 22:27:28 -0500 Subject: [PATCH 19/35] Fixes and a small optiimization --- core/bootstrap/image/image.factor | 3 +++ core/cpu/x86/bootstrap.factor | 6 +++++ core/generator/fixup/fixup.factor | 1 + core/inference/errors/errors.factor | 6 ++--- core/optimizer/def-use/def-use.factor | 5 ++-- core/optimizer/known-words/known-words.factor | 18 ++++++------- core/optimizer/math/math.factor | 8 +++--- .../pattern-match/pattern-match.factor | 5 ++-- extra/optimizer/debugger/debugger.factor | 10 +++---- vm/code_heap.c | 2 ++ vm/code_heap.h | 4 ++- vm/quotations.c | 5 ++-- vm/run.h | 26 +++---------------- 13 files changed, 46 insertions(+), 53 deletions(-) diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 632938bb2d..97a95f98b8 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -119,6 +119,7 @@ SYMBOL: jit-primitive SYMBOL: jit-word-jump SYMBOL: jit-word-call SYMBOL: jit-push-literal +SYMBOL: jit-push-immediate SYMBOL: jit-if-word SYMBOL: jit-if-jump SYMBOL: jit-dispatch-word @@ -149,6 +150,7 @@ SYMBOL: undefined-quot { jit-epilog 33 } { jit-return 34 } { jit-profiling 35 } + { jit-push-immediate 36 } { jit-declare-word 42 } { undefined-quot 60 } } at header-size + ; @@ -438,6 +440,7 @@ M: quotation ' jit-word-jump jit-word-call jit-push-literal + jit-push-immediate jit-if-word jit-if-jump jit-dispatch-word diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor index bd90ca65f0..76a42b3f2d 100755 --- a/core/cpu/x86/bootstrap.factor +++ b/core/cpu/x86/bootstrap.factor @@ -40,6 +40,12 @@ big-endian off ds-reg [] arg0 MOV ! store literal on datastack ] rc-absolute-cell rt-literal 1 rex-length + jit-push-literal jit-define +[ + arg0 0 MOV ! load literal + ds-reg bootstrap-cell ADD ! increment datastack pointer + ds-reg [] arg0 MOV ! store literal on datastack +] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define + [ arg0 0 MOV ! load XT arg1 stack-reg MOV ! pass callstack pointer as arg 2 diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index 058822bf2f..9be8151bee 100755 --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -72,6 +72,7 @@ SYMBOL: label-table : rt-xt 4 ; : rt-here 5 ; : rt-label 6 ; +: rt-immediate 7 ; TUPLE: label-fixup label class ; diff --git a/core/inference/errors/errors.factor b/core/inference/errors/errors.factor index e1d5bd434c..9e01492529 100644 --- a/core/inference/errors/errors.factor +++ b/core/inference/errors/errors.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: kernel generic sequences prettyprint io words arrays +summary effects debugger assocs accessors inference.backend +inference.dataflow ; IN: inference.errors -USING: inference.backend inference.dataflow kernel generic -sequences prettyprint io words arrays summary effects debugger -assocs accessors ; M: inference-error error-help error>> error-help ; diff --git a/core/optimizer/def-use/def-use.factor b/core/optimizer/def-use/def-use.factor index d4905a1718..55088fd7e2 100755 --- a/core/optimizer/def-use/def-use.factor +++ b/core/optimizer/def-use/def-use.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces assocs sequences inference.dataflow -inference.backend kernel generic assocs classes vectors -accessors combinators ; +USING: namespaces assocs sequences kernel generic assocs classes +vectors accessors combinators inference.dataflow inference.backend ; IN: optimizer.def-use SYMBOL: def-use diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index 76ad0009cb..7527199fe9 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -1,15 +1,15 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien arrays generic hashtables definitions -inference.dataflow inference.state inference.class kernel assocs -math math.order math.private kernel.private sequences words -parser vectors strings sbufs io namespaces assocs quotations -sequences.private io.binary io.streams.string layouts splitting -math.intervals math.floats.private classes.tuple classes.predicate -classes.tuple.private classes classes.algebra optimizer.def-use -optimizer.backend optimizer.pattern-match optimizer.inlining -sequences.private combinators byte-arrays byte-vectors -slots.private ; +kernel assocs math math.order math.private kernel.private +sequences words parser vectors strings sbufs io namespaces +assocs quotations sequences.private io.binary io.streams.string +layouts splitting math.intervals math.floats.private +classes.tuple classes.predicate classes.tuple.private classes +classes.algebra sequences.private combinators byte-arrays +byte-vectors slots.private inference.dataflow inference.state +inference.class optimizer.def-use optimizer.backend +optimizer.pattern-match optimizer.inlining ; IN: optimizer.known-words { (tuple) } [ diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index b208a9f894..c20cba99cb 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -2,10 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: effects alien alien.accessors arrays generic hashtables kernel assocs math math.libm math.private kernel.private -sequences words parser inference.class inference.dataflow -vectors strings sbufs io namespaces assocs quotations -math.intervals sequences.private combinators splitting layouts -math.parser classes classes.algebra generic.math +sequences words parser vectors strings sbufs io namespaces +assocs quotations math.intervals sequences.private combinators +splitting layouts math.parser classes classes.algebra +generic.math inference.class inference.dataflow optimizer.pattern-match optimizer.backend optimizer.def-use optimizer.inlining optimizer.math.partial generic.standard system accessors ; diff --git a/core/optimizer/pattern-match/pattern-match.factor b/core/optimizer/pattern-match/pattern-match.factor index 51fa254a25..647dda368f 100755 --- a/core/optimizer/pattern-match/pattern-match.factor +++ b/core/optimizer/pattern-match/pattern-match.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences namespaces generic +combinators classes classes.algebra +inference inference.dataflow ; IN: optimizer.pattern-match -USING: kernel sequences inference namespaces generic -combinators classes classes.algebra inference.dataflow ; ! Funny pattern matching SYMBOL: @ diff --git a/extra/optimizer/debugger/debugger.factor b/extra/optimizer/debugger/debugger.factor index c20685cf70..2a79d8977f 100755 --- a/extra/optimizer/debugger/debugger.factor +++ b/extra/optimizer/debugger/debugger.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: classes inference inference.dataflow io kernel -kernel.private math.parser namespaces optimizer prettyprint -prettyprint.backend sequences words arrays match macros -assocs sequences.private optimizer.specializers generic -combinators sorting math quotations accessors ; +USING: classes io kernel kernel.private math.parser namespaces +optimizer prettyprint prettyprint.backend sequences words arrays +match macros assocs sequences.private generic combinators +sorting math quotations accessors inference inference.dataflow +optimizer.specializers ; IN: optimizer.debugger ! A simple tool for turning dataflow IR into quotations, for diff --git a/vm/code_heap.c b/vm/code_heap.c index 69ffdeb2aa..1435caa9d2 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -63,6 +63,8 @@ INLINE CELL compute_code_rel(F_REL *rel, return (CELL)get_rel_symbol(rel,literals_start); case RT_LITERAL: return CREF(literals_start,REL_ARGUMENT(rel)); + case RT_IMMEDIATE: + return get(CREF(literals_start,REL_ARGUMENT(rel))); case RT_XT: return (CELL)untag_word(get(CREF(literals_start,REL_ARGUMENT(rel))))->xt; case RT_HERE: diff --git a/vm/code_heap.h b/vm/code_heap.h index 80605b1d28..c3b476c4b5 100755 --- a/vm/code_heap.h +++ b/vm/code_heap.h @@ -12,7 +12,9 @@ typedef enum { /* current offset */ RT_HERE, /* a local label */ - RT_LABEL + RT_LABEL, + /* immeditae literal */ + RT_IMMEDIATE } F_RELTYPE; typedef enum { diff --git a/vm/quotations.c b/vm/quotations.c index 2d54f23a6f..a1555136db 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -30,9 +30,8 @@ push the array and immediately drop it after. in the VM. They are open-coded and no subroutine call is generated. This includes stack shufflers, some fixnum arithmetic words, and words such as tag, slot and eq?. A primitive call is relatively expensive (two subroutine calls) -so this results in a big speedup for relatively little effort. +so this results in a big speedup for relatively little effort. */ -*/ bool jit_primitive_call_p(F_ARRAY *array, CELL i) { return (i + 2) == array_capacity(array) @@ -253,7 +252,7 @@ void jit_compile(CELL quot, bool relocate) } default: GROWABLE_ARRAY_ADD(literals,obj); - EMIT(userenv[JIT_PUSH_LITERAL],literals_count - 1); + EMIT(userenv[immediate_p(obj) ? JIT_PUSH_IMMEDIATE : JIT_PUSH_LITERAL],literals_count - 1); break; } } diff --git a/vm/run.h b/vm/run.h index 8a03049b93..96e606e38c 100755 --- a/vm/run.h +++ b/vm/run.h @@ -47,29 +47,9 @@ typedef enum { JIT_EPILOG, JIT_RETURN, JIT_PROFILING, - JIT_TAG, - JIT_TAG_WORD, - JIT_EQP, - JIT_EQP_WORD, - JIT_SLOT, - JIT_SLOT_WORD, - JIT_DECLARE_WORD, - JIT_DROP, - JIT_DROP_WORD, - JIT_DUP, - JIT_DUP_WORD, - JIT_TO_R, - JIT_TO_R_WORD, - JIT_FROM_R, - JIT_FROM_R_WORD, - JIT_SWAP, - JIT_SWAP_WORD, - JIT_OVER, - JIT_OVER_WORD, - JIT_FIXNUM_MINUS, - JIT_FIXNUM_MINUS_WORD, - JIT_FIXNUM_GE, - JIT_FIXNUM_GE_WORD, + JIT_PUSH_IMMEDIATE, + + JIT_DECLARE_WORD = 42, STACK_TRACES_ENV = 59, From 54b24fd8b1060c80362898744e797b5d285935d7 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 13 Jul 2008 01:24:43 -0500 Subject: [PATCH 20/35] ui.gadgets: new effects for add-gadget, add-gadgets, and (add-gadget) --- extra/ui/gadgets/gadgets.factor | 31 ++++++++++++++++++------------- 1 file changed, 18 insertions(+), 13 deletions(-) diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 3fc185a10e..ebe3773ce9 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -285,22 +285,27 @@ SYMBOL: in-layout? not-in-layout dup (clear-gadget) relayout ; -: ((add-gadget)) ( gadget box -- ) - [ children>> ?push ] keep (>>children) ; +: ((add-gadget)) ( parent child -- parent ) + over children>> ?push >>children ; -: (add-gadget) ( gadget box -- ) - over unparent - dup pick (>>parent) - [ ((add-gadget)) ] 2keep - graft-state>> second [ graft ] [ drop ] if ; +: (add-gadget) ( parent child -- parent ) + dup unparent + over >>parent + tuck ((add-gadget)) + tuck graft-state>> second + [ graft ] + [ drop ] + if ; -: add-gadget ( gadget parent -- ) +: add-gadget ( parent child -- parent ) not-in-layout - [ (add-gadget) ] keep relayout ; - -: add-gadgets ( seq parent -- ) + (add-gadget) + dup relayout ; + +: add-gadgets ( parent children -- parent ) not-in-layout - swap [ over (add-gadget) ] each relayout ; + [ (add-gadget) ] each + dup relayout ; : parents ( gadget -- seq ) [ parent>> ] follow ; @@ -352,7 +357,7 @@ M: f request-focus-on 2drop ; : focus-path ( world -- seq ) [ focus>> ] follow ; -: gadget, ( gadget -- ) gadget get add-gadget ; +: gadget, ( gadget -- ) gadget get swap add-gadget drop ; : g ( -- gadget ) gadget get ; From 73e30123f52ae037b11f1977933c04e6e98f61fd Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 13 Jul 2008 01:25:44 -0500 Subject: [PATCH 21/35] ui.gadgets.*: updates for new effects --- extra/ui/gadgets/books/books.factor | 2 +- extra/ui/gadgets/borders/borders.factor | 2 +- extra/ui/gadgets/grids/grids.factor | 4 ++-- extra/ui/gadgets/incremental/incremental.factor | 2 +- extra/ui/gadgets/lists/lists.factor | 2 +- extra/ui/gadgets/menus/menus.factor | 4 ++-- extra/ui/gadgets/panes/panes.factor | 12 ++++++------ extra/ui/gadgets/sliders/sliders.factor | 2 +- extra/ui/gadgets/tabs/tabs.factor | 4 ++-- extra/ui/gadgets/tracks/tracks.factor | 2 +- extra/ui/gadgets/viewports/viewports.factor | 2 +- extra/ui/gadgets/wrappers/wrappers.factor | 2 +- 12 files changed, 20 insertions(+), 20 deletions(-) diff --git a/extra/ui/gadgets/books/books.factor b/extra/ui/gadgets/books/books.factor index 93a8d271af..ce15bd9e6c 100755 --- a/extra/ui/gadgets/books/books.factor +++ b/extra/ui/gadgets/books/books.factor @@ -19,7 +19,7 @@ M: book model-changed : new-book ( pages model class -- book ) new-gadget swap >>model - [ add-gadgets ] keep ; inline + [ swap add-gadgets drop ] keep ; inline : ( pages model -- book ) book new-book ; diff --git a/extra/ui/gadgets/borders/borders.factor b/extra/ui/gadgets/borders/borders.factor index 7d6a24fed1..d1cf7cfb29 100644 --- a/extra/ui/gadgets/borders/borders.factor +++ b/extra/ui/gadgets/borders/borders.factor @@ -10,7 +10,7 @@ TUPLE: border < gadget { align initial: { 1/2 1/2 } } ; : new-border ( child class -- border ) - new-gadget [ add-gadget ] keep ; inline + new-gadget [ swap add-gadget drop ] keep ; inline : ( child gap -- border ) swap border new-border diff --git a/extra/ui/gadgets/grids/grids.factor b/extra/ui/gadgets/grids/grids.factor index b539934771..474e6b95c0 100644 --- a/extra/ui/gadgets/grids/grids.factor +++ b/extra/ui/gadgets/grids/grids.factor @@ -12,7 +12,7 @@ grid : new-grid ( children class -- grid ) new-gadget - [ (>>grid) ] [ >r concat r> add-gadgets ] [ nip ] 2tri ; + [ (>>grid) ] [ >r concat r> swap add-gadgets drop ] [ nip ] 2tri ; inline : ( children -- grid ) @@ -21,7 +21,7 @@ grid : grid-child ( grid i j -- gadget ) rot grid>> nth nth ; : grid-add ( gadget grid i j -- ) - >r >r 2dup add-gadget r> r> + >r >r 2dup swap add-gadget drop r> r> 3dup grid-child unparent rot grid>> nth set-nth ; : grid-remove ( grid i j -- ) diff --git a/extra/ui/gadgets/incremental/incremental.factor b/extra/ui/gadgets/incremental/incremental.factor index c74f6676ad..8c227d76ce 100755 --- a/extra/ui/gadgets/incremental/incremental.factor +++ b/extra/ui/gadgets/incremental/incremental.factor @@ -45,7 +45,7 @@ M: incremental pref-dim* : add-incremental ( gadget incremental -- ) not-in-layout - 2dup (add-gadget) + 2dup swap (add-gadget) drop over prefer-incremental over layout-later 2dup incremental-loc diff --git a/extra/ui/gadgets/lists/lists.factor b/extra/ui/gadgets/lists/lists.factor index 776814853f..c2539e146a 100755 --- a/extra/ui/gadgets/lists/lists.factor +++ b/extra/ui/gadgets/lists/lists.factor @@ -48,7 +48,7 @@ TUPLE: list < pack index presenter color hook ; M: list model-changed nip dup clear-gadget - dup over add-gadgets + dup over swap add-gadgets drop bound-index ; : selected-rect ( list -- rect ) diff --git a/extra/ui/gadgets/menus/menus.factor b/extra/ui/gadgets/menus/menus.factor index 3e1145a8b6..4f815bc33d 100644 --- a/extra/ui/gadgets/menus/menus.factor +++ b/extra/ui/gadgets/menus/menus.factor @@ -15,7 +15,7 @@ TUPLE: menu-glass < gadget ; : ( menu world -- glass ) menu-glass new-gadget >r over menu-loc over set-rect-loc r> - [ add-gadget ] keep ; + [ swap add-gadget drop ] keep ; M: menu-glass layout* gadget-child prefer ; @@ -26,7 +26,7 @@ M: menu-glass layout* gadget-child prefer ; : show-glass ( gadget world -- ) over hand-clicked set-global [ hide-glass ] keep - [ add-gadget ] 2keep + [ swap add-gadget drop ] 2keep set-world-glass ; : show-menu ( gadget owner -- ) diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor index 973c8c5725..9b547ce544 100755 --- a/extra/ui/gadgets/panes/panes.factor +++ b/extra/ui/gadgets/panes/panes.factor @@ -22,10 +22,10 @@ selection-color caret mark selecting? ; drop ; : add-output ( current pane -- ) - [ set-pane-output ] [ add-gadget ] 2bi ; + [ set-pane-output ] [ swap add-gadget drop ] 2bi ; : add-current ( current pane -- ) - [ set-pane-current ] [ add-gadget ] 2bi ; + [ set-pane-current ] [ swap add-gadget drop ] 2bi ; : prepare-line ( pane -- ) [ clear-selection ] @@ -120,7 +120,7 @@ C: pane-stream GENERIC: write-gadget ( gadget stream -- ) M: pane-stream write-gadget - pane-stream-pane pane-current add-gadget ; + pane-stream-pane pane-current swap add-gadget drop ; M: style-stream write-gadget stream>> write-gadget ; @@ -299,12 +299,12 @@ M: paragraph dispose drop ; : gadget-write ( string gadget -- ) over empty? - [ 2drop ] [ >r