diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index bcc46721b0..83fd314761 100644 --- a/library/ui/gadgets.factor +++ b/library/ui/gadgets.factor @@ -115,3 +115,20 @@ M: gadget gadget-selection? drop f ; GENERIC: gadget-selection ( gadget -- string/f ) M: gadget gadget-selection drop f ; + +! Re-firing gestures while mouse held down, etc. Used by +! slider gadgets +TUPLE: timer-gadget quot ; + +C: timer-gadget ( gadget -- gadget ) + [ set-gadget-delegate ] keep ; + +M: timer-gadget tick nip timer-gadget-quot call ; + +: start-timer-gadget ( gadget quot -- ) + over >r curry r> + [ set-timer-gadget-quot ] keep + 100 add-timer ; + +: stop-timer-gadget ( gadget -- ) + dup remove-timer f swap set-timer-gadget-quot ; diff --git a/library/ui/gadgets/buttons.factor b/library/ui/gadgets/buttons.factor index 011a725a8e..f5074c64ef 100644 --- a/library/ui/gadgets/buttons.factor +++ b/library/ui/gadgets/buttons.factor @@ -62,16 +62,16 @@ C: button ( gadget quot -- button ) TUPLE: repeat-button ; repeat-button H{ - { T{ button-down } [ repeat-button-down ] } - { T{ button-up } [ repeat-button-up ] } + { T{ button-down } [ [ button-clicked ] start-timer-gadget ] } + { T{ button-up } [ stop-timer-gadget ] } } set-gestures C: repeat-button ( gadget quot -- button ) #! Button that calls the quotation every 100ms as long as #! the mouse is held down. - [ >r r> set-gadget-delegate ] keep ; - -M: repeat-button tick nip button-clicked ; + [ + >r r> set-gadget-delegate + ] keep ; TUPLE: button-paint plain rollover pressed selected ; diff --git a/library/ui/models.factor b/library/ui/models.factor index 62ed32e55f..7d0bc69554 100644 --- a/library/ui/models.factor +++ b/library/ui/models.factor @@ -88,30 +88,6 @@ M: filter model-changed dup filter-model model-value over filter-quot call swap set-model ; -TUPLE: validator model quot ; - -C: validator ( model quot -- filter ) - dup delegate>model - [ set-validator-quot ] keep - [ set-validator-model ] 2keep - [ add-dependency ] keep - dup model-changed ; - -M: validator model-changed - dup validator-model model-value dup - pick validator-quot call [ - swap delegate set-model - ] [ - 2drop - ] if ; - -M: validator set-model - 2dup validator-quot call [ - validator-model set-model - ] [ - 2drop - ] if ; - TUPLE: compose ; C: compose ( models -- compose ) diff --git a/library/ui/test/models.factor b/library/ui/test/models.factor index 0017ec266d..ee861ea51a 100644 --- a/library/ui/test/models.factor +++ b/library/ui/test/models.factor @@ -74,28 +74,3 @@ f "history" set [ 9 ] [ "y" get model-value ] unit-test [ ] [ "y" get deactivate-model ] unit-test [ f ] [ "z" get "x" get model-connections memq? ] unit-test - -! Test validators -3 "x" set -"x" get [ odd? ] "y" set -"y" get activate-model - -[ 3 ] [ "y" get model-value ] unit-test - -4 "x" get set-model - -[ 3 ] [ "y" get model-value ] unit-test - -5 "x" get set-model - -[ 5 ] [ "y" get model-value ] unit-test - -6 "y" get set-model - -[ 5 ] [ "x" get model-value ] unit-test -[ 5 ] [ "y" get model-value ] unit-test - -7 "y" get set-model - -[ 7 ] [ "x" get model-value ] unit-test -[ 7 ] [ "y" get model-value ] unit-test