core/ui/gadgets/buttons.factor

   1 ! Copyright (C) 2005, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: gadgets-buttons
   4 USING: gadgets gadgets-borders gadgets-labels
   5 gadgets-theme generic io kernel math models namespaces sequences
   6 strings styles threads words ;
   7
   8 TUPLE: button rollover? pressed? selected? quot ;
   9
  10 : buttons-down? ( -- ? )
  11     hand-buttons get-global empty? not ;
  12
  13 : mouse-over? ( gadget -- ? )
  14     hand-gadget get-global child? ;
  15
  16 : mouse-clicked? ( gadget -- ? )
  17     hand-clicked get-global child? ;
  18
  19 : button-update ( button -- )
  20     dup mouse-over? over set-button-rollover?
  21     dup mouse-clicked? buttons-down? and
  22     over button-rollover? and over set-button-pressed?
  23     relayout-1 ;
  24
  25 : if-clicked ( button quot -- )
  26     >r dup button-update dup button-rollover? r> [ drop ] if ;
  27
  28 : button-clicked ( button -- )
  29     dup button-quot if-clicked ;
  30
  31 button H{
  32     { T{ button-up } [ button-clicked ] }
  33     { T{ button-down } [ button-update ] }
  34     { T{ mouse-leave } [ button-update ] }
  35     { T{ mouse-enter } [ button-update ] }
  36 } set-gestures
  37
  38 GENERIC: >label ( obj -- gadget )
  39 M: string >label <label> ;
  40 M: object >label ;
  41 M: f >label drop <gadget> ;
  42
  43 C: button ( gadget quot -- button )
  44     [ set-button-quot ] keep
  45     [ set-gadget-delegate ] keep ;
  46
  47 : <roll-button> ( label quot -- button )
  48     >r >label r>
  49     <button> dup roll-button-theme ;
  50
  51 : <bevel-button> ( label quot -- button )
  52     >r >label <default-border> r>
  53     <button> dup bevel-button-theme ;
  54
  55 TUPLE: repeat-button ;
  56
  57 repeat-button H{
  58     { T{ button-down } [ [ button-clicked ] start-timer-gadget ] }
  59     { T{ button-up } [ dup stop-timer-gadget button-update ] }
  60 } set-gestures
  61
  62 C: repeat-button ( label quot -- button )
  63     #! Button that calls the quotation every 100ms as long as
  64     #! the mouse is held down.
  65     [
  66         >r <bevel-button> <timer-gadget> r> set-gadget-delegate
  67     ] keep ;
  68
  69 TUPLE: button-paint plain rollover pressed selected ;
  70
  71 : button-paint ( button paint -- button paint )
  72     {
  73         { [ over button-pressed? ] [ button-paint-pressed ] }
  74         { [ over button-selected? ] [ button-paint-selected ] }
  75         { [ over button-rollover? ] [ button-paint-rollover ] }
  76         { [ t ] [ button-paint-plain ] }
  77     } cond ;
  78
  79 M: button-paint draw-interior
  80     button-paint draw-interior ;
  81
  82 M: button-paint draw-boundary
  83     button-paint draw-boundary ;
  84
  85 : <radio-control> ( model value label -- gadget )
  86     over [ swap set-control-value ] curry <bevel-button>
  87     swap [ swap >r = r> set-button-selected? ] curry <control> ;
  88
  89 : <radio-box> ( model assoc -- gadget )
  90     [ first2 <radio-control> ] map-with make-shelf ;