diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index bcf75b9e0f..6b785a61ba 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -210,3 +210,6 @@ GENERIC# set-slots 1 ( ... tuple slots -- ) : construct ( ... slots class -- tuple ) new [ swap set-slots ] keep ; inline + +: construct-delegate ( delegate class -- tuple ) + >r { set-delegate } r> construct ; inline diff --git a/extra/models/compose/compose.factor b/extra/models/compose/compose.factor index 0dfc65548d..015986fad0 100755 --- a/extra/models/compose/compose.factor +++ b/extra/models/compose/compose.factor @@ -1,19 +1,24 @@ -USING: models kernel sequences ; +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors models kernel sequences ; IN: models.compose -TUPLE: compose ; +TUPLE: compose < model ; + +: new-compose ( models class -- compose ) + f swap new-model + swap clone >>dependencies ; inline : ( models -- compose ) - f compose construct-model - swap clone over set-model-dependencies ; + compose new-compose ; -: composed-value >r model-dependencies r> map ; inline +: composed-value [ dependencies>> ] dip map ; inline -: set-composed-value >r model-dependencies r> 2each ; inline +: set-composed-value [ dependencies>> ] dip 2each ; inline M: compose model-changed nip - dup [ model-value ] composed-value swap delegate set-model ; + [ [ model-value ] composed-value ] keep set-model ; M: compose model-activated dup model-changed ; diff --git a/extra/models/delay/delay.factor b/extra/models/delay/delay.factor index 40b669d915..22512942e3 100755 --- a/extra/models/delay/delay.factor +++ b/extra/models/delay/delay.factor @@ -1,24 +1,26 @@ -USING: kernel models alarms ; +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel models alarms ; IN: models.delay -TUPLE: delay model timeout alarm ; +TUPLE: delay < model model timeout alarm ; : update-delay-model ( delay -- ) - dup delay-model model-value swap set-model ; + [ delay-model model-value ] keep set-model ; : ( model timeout -- delay ) - f delay construct-model - [ set-delay-timeout ] keep - [ set-delay-model ] 2keep - [ add-dependency ] keep ; + f delay new-model + swap >>timeout + over >>model + [ add-dependency ] keep ; : cancel-delay ( delay -- ) delay-alarm [ cancel-alarm ] when* ; : start-delay ( delay -- ) - dup [ f over set-delay-alarm update-delay-model ] curry - over delay-timeout later - swap set-delay-alarm ; + dup + [ [ f >>alarm update-delay-model ] curry ] [ timeout>> ] bi later + >>alarm drop ; M: delay model-changed nip dup cancel-delay start-delay ; diff --git a/extra/models/filter/filter.factor b/extra/models/filter/filter.factor index 78b1ce09e5..b16bdc9a48 100755 --- a/extra/models/filter/filter.factor +++ b/extra/models/filter/filter.factor @@ -1,16 +1,17 @@ -USING: models kernel ; +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors models kernel ; IN: models.filter -TUPLE: filter model quot ; +TUPLE: filter < model model quot ; : ( model quot -- filter ) - f filter construct-model - [ set-filter-quot ] keep - [ set-filter-model ] 2keep - [ add-dependency ] keep ; + f filter new-model + swap >>quot + over >>model + [ add-dependency ] keep ; M: filter model-changed - swap model-value over filter-quot call - swap set-model ; + [ [ value>> ] [ quot>> ] bi* call ] [ nip ] 2bi set-model ; -M: filter model-activated dup filter-model swap model-changed ; +M: filter model-activated [ model>> ] keep model-changed ; diff --git a/extra/models/history/history.factor b/extra/models/history/history.factor index 067b76c2ec..ab79d66eb6 100755 --- a/extra/models/history/history.factor +++ b/extra/models/history/history.factor @@ -1,14 +1,17 @@ -USING: kernel models sequences ; +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel models sequences ; IN: models.history -TUPLE: history back forward ; +TUPLE: history < model back forward ; -: reset-history ( history -- ) - V{ } clone over set-history-back - V{ } clone swap set-history-forward ; +: reset-history ( history -- history ) + V{ } clone >>back + V{ } clone >>forward ; inline : ( value -- history ) - history construct-model dup reset-history ; + history new-model + reset-history ; : (add-history) ( history to -- ) swap model-value dup [ swap push ] [ 2drop ] if ; diff --git a/extra/models/mapping/mapping.factor b/extra/models/mapping/mapping.factor index 4e12dbccc1..c401714dd4 100755 --- a/extra/models/mapping/mapping.factor +++ b/extra/models/mapping/mapping.factor @@ -1,20 +1,21 @@ -USING: models kernel assocs ; +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors models kernel assocs ; IN: models.mapping -TUPLE: mapping assoc ; +TUPLE: mapping < model assoc ; : ( models -- mapping ) - f mapping construct-model - over values over set-model-dependencies - tuck set-mapping-assoc ; + f mapping new-model + over values >>dependencies + swap >>assoc ; M: mapping model-changed - nip - dup mapping-assoc [ model-value ] assoc-map - swap delegate set-model ; + nip [ assoc>> [ value>> ] assoc-map ] keep set-model ; -M: mapping model-activated dup model-changed ; +M: mapping model-activated + dup model-changed ; M: mapping update-model - dup model-value swap mapping-assoc + [ value>> ] [ assoc>> ] bi [ swapd at set-model ] curry assoc-each ; diff --git a/extra/models/models.factor b/extra/models/models.factor index 48c43d9368..94b47dc4db 100755 --- a/extra/models/models.factor +++ b/extra/models/models.factor @@ -100,9 +100,6 @@ M: model update-model drop ; : (change-model) ( model quot -- ) ((change-model)) set-model-value ; inline -: construct-model ( value class -- instance ) - >r { set-delegate } r> construct ; inline - GENERIC: range-value ( model -- value ) GENERIC: range-page-value ( model -- value ) GENERIC: range-min-value ( model -- value ) diff --git a/extra/models/range/range.factor b/extra/models/range/range.factor index 761e077948..8e230a2d0c 100755 --- a/extra/models/range/range.factor +++ b/extra/models/range/range.factor @@ -1,32 +1,33 @@ -USING: kernel models arrays sequences math math.order +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel models arrays sequences math math.order models.compose ; IN: models.range -TUPLE: range ; +TUPLE: range < compose ; : ( value min max page -- range ) - 4array [ ] map - { set-delegate } range construct ; + 4array [ ] map range new-compose ; -: range-model ( range -- model ) model-dependencies first ; -: range-page ( range -- model ) model-dependencies second ; -: range-min ( range -- model ) model-dependencies third ; -: range-max ( range -- model ) model-dependencies fourth ; +: range-model ( range -- model ) dependencies>> first ; +: range-page ( range -- model ) dependencies>> second ; +: range-min ( range -- model ) dependencies>> third ; +: range-max ( range -- model ) dependencies>> fourth ; M: range range-value - [ range-model model-value ] keep clamp-value ; + [ range-model value>> ] keep clamp-value ; -M: range range-page-value range-page model-value ; +M: range range-page-value range-page value>> ; -M: range range-min-value range-min model-value ; +M: range range-min-value range-min value>> ; -M: range range-max-value range-max model-value ; +M: range range-max-value range-max value>> ; M: range range-max-value* - dup range-max-value swap range-page-value [-] ; + [ range-max-value ] [ range-page-value ] bi [-] ; M: range set-range-value - [ clamp-value ] keep range-model set-model ; + [ clamp-value ] [ range-model ] bi set-model ; M: range set-range-page-value range-page set-model ; diff --git a/extra/ui/gadgets/borders/borders-tests.factor b/extra/ui/gadgets/borders/borders-tests.factor new file mode 100644 index 0000000000..268d1ab0a3 --- /dev/null +++ b/extra/ui/gadgets/borders/borders-tests.factor @@ -0,0 +1,25 @@ +IN: ui.gadgets.borders.tests +USING: tools.test accessors namespaces kernel +ui.gadgets ui.gadgets.borders ; + +[ { 110 210 } ] [ { 100 200 } >>dim 5 pref-dim ] unit-test + +[ ] [ { 100 200 } >>dim "g" set ] unit-test + +[ ] [ "g" get 0 { 100 200 } >>dim "b" set ] unit-test + +[ T{ rect f { 0 0 } { 100 200 } } ] [ "b" get border-child-rect ] unit-test + +[ ] [ "g" get 5 { 210 210 } >>dim "b" set ] unit-test + +[ T{ rect f { 55 5 } { 100 200 } } ] [ "b" get border-child-rect ] unit-test + +[ ] [ "b" get { 0 0 } >>align drop ] unit-test + +[ { 5 5 } ] [ "b" get { 100 200 } border-loc ] unit-test + +[ T{ rect f { 5 5 } { 100 200 } } ] [ "b" get border-child-rect ] unit-test + +[ ] [ "b" get { 1 1 } >>fill drop ] unit-test + +[ T{ rect f { 5 5 } { 200 200 } } ] [ "b" get border-child-rect ] unit-test diff --git a/extra/ui/gadgets/borders/borders.factor b/extra/ui/gadgets/borders/borders.factor index ce7ea32008..55d1993b1d 100644 --- a/extra/ui/gadgets/borders/borders.factor +++ b/extra/ui/gadgets/borders/borders.factor @@ -4,43 +4,44 @@ USING: accessors arrays ui.gadgets kernel math namespaces vectors sequences math.vectors ; IN: ui.gadgets.borders -TUPLE: border < gadget size fill ; +TUPLE: border < gadget +{ size initial: { 0 0 } } +{ fill initial: { 0 0 } } +{ align initial: { 1/2 1/2 } } ; + +: new-border ( child class -- border ) + new-gadget [ add-gadget ] keep ; inline : ( child gap -- border ) - border new-gadget - swap dup 2array >>size - { 0 0 } >>fill - [ add-gadget ] keep ; + swap border new-border + swap dup 2array >>size ; M: border pref-dim* - [ border-size 2 v*n ] keep + [ size>> 2 v*n ] keep gadget-child pref-dim v+ ; -: border-major-rect ( border -- rect ) - dup border-size swap rect-dim over 2 v*n v- ; +: border-major-dim ( border -- dim ) + [ dim>> ] [ size>> 2 v*n ] bi v- ; -: border-minor-rect ( major border -- rect ) - gadget-child pref-dim - [ >r rect-bounds r> v- [ 2 / >fixnum ] map v+ ] keep - ; +: border-minor-dim ( border -- dim ) + gadget-child pref-dim ; -: scale-rect ( rect vec -- loc dim ) - [ v* ] curry >r rect-bounds r> bi@ ; +: scale ( a b s -- c ) + tuck { 1 1 } swap v- [ v* ] 2bi@ v+ ; -: average-rects ( rect1 rect2 weight -- rect ) - tuck >r >r scale-rect r> r> { 1 1 } swap v- scale-rect - swapd v+ >r v+ r> ; +: border-dim ( border -- dim ) + [ border-major-dim ] [ border-minor-dim ] [ fill>> ] tri scale ; + +: border-loc ( border dim -- loc ) + [ [ size>> ] [ align>> ] [ border-major-dim ] tri ] dip v- v* v+ ; : border-child-rect ( border -- rect ) - dup border-major-rect - dup pick border-minor-rect - rot border-fill - average-rects ; + dup border-dim [ border-loc ] keep ; M: border layout* dup border-child-rect swap gadget-child - over rect-loc over set-rect-loc - swap rect-dim swap set-layout-dim ; + over loc>> over set-rect-loc + swap dim>> swap set-layout-dim ; M: border focusable-child* gadget-child ; diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor index e38676c375..96a89e8aa6 100755 --- a/extra/ui/gadgets/buttons/buttons.factor +++ b/extra/ui/gadgets/buttons/buttons.factor @@ -4,12 +4,12 @@ USING: accessors arrays kernel math models namespaces sequences strings quotations assocs combinators classes colors classes.tuple opengl math.vectors ui.commands ui.gadgets ui.gadgets.borders -ui.gadgets.labels ui.gadgets.theme ui.gadgets.wrappers +ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.render ; IN: ui.gadgets.buttons -TUPLE: button < wrapper pressed? selected? quot ; +TUPLE: button < border pressed? selected? quot ; : buttons-down? ( -- ? ) hand-buttons get-global empty? not ; @@ -41,11 +41,9 @@ button H{ } set-gestures : new-button ( label quot class -- button ) - new-gadget - swap >>quot - [ >r >label r> add-gadget ] keep ; inline + [ swap >label ] dip new-border swap >>quot ; inline -: