! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets-buttons USING: gadgets gadgets-borders gadgets-layouts gadgets-theme generic io kernel lists math namespaces sequences sequences styles threads ; TUPLE: button rollover? pressed? ; : button-down? ( -- ? ) hand get hand-buttons empty? not ; : mouse-over? ( gadget -- ? ) hand get hand-gadget child? ; : mouse-clicked? ( gadget -- ? ) hand get hand-clicked child? ; : button-update ( button -- ) dup mouse-over? over set-button-rollover? dup button-rollover? button-down? and over mouse-clicked? and over set-button-pressed? relayout-1 ; : button-clicked ( button -- ) #! If the mouse is released while still inside the button, #! fire an action gesture. dup button-update dup button-rollover? [ [ action ] swap handle-gesture ] when drop ; : button-action ( action -- quot ) [ [ swap handle-gesture drop ] cons ] [ [ drop ] ] if* ; : button-gestures ( button quot -- ) dupd [ action ] set-action dup [ button-clicked ] [ button-up ] set-action dup [ button-update ] [ button-down ] set-action dup [ button-update ] [ mouse-leave ] set-action [ button-update ] [ mouse-enter ] set-action ; C: button ( gadget quot -- button ) rot over set-gadget-delegate [ swap button-gestures ] keep ; : ( gadget quot -- button )