PreviousUpNext

15.4.1410  src/lib/x-kit/widget/leaf/toggleswitch-behavior-g.pkg

## toggleswitch-behavior-g.pkg
#
# Implement behavior of buttons which toggle
# between ON and OFF states.
#
# The visual appearance of these toggles is
# specified separately, by the Button_Look
# argument to the generic.

# Compiled by:
#     src/lib/x-kit/widget/xkit-widget.sublib



# TODO: Allow disabling of highlighting 



#               "GOTO statement considered harmful"
#
#                           - C.A.R. Hoare supplied
#                             title to the famous
#                             E. W. Dijkstra letter in
#                             CACM 11, 3 (March, 1968) 


stipulate
    include threadkit;                                          # threadkit             is from   src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.pkg
    #
    package bb =  button_base;                                  # button_base           is from   src/lib/x-kit/widget/leaf/button-base.pkg
    package tt =  toggle_type;                                  # toggle_type           is from   src/lib/x-kit/widget/leaf/toggle-type.pkg
    package wg =  widget;                                       # widget                is from   src/lib/x-kit/widget/basic/widget.pkg
    package wa =  widget_attribute;                             # widget_attribute      is from   src/lib/x-kit/widget/lib/widget-attribute.pkg
    package xg =  xgeometry;                                    # xgeometry             is from   src/lib/std/2d/xgeometry.pkg
    #
    package xc =  xclient;                                      # xclient               is from   src/lib/x-kit/xclient/xclient.pkg
herein

    generic package  toggleswitch_behavior_g  (

        button_look:  Button_Look                       # Button_Look   is from   src/lib/x-kit/widget/leaf/button-look.api
    )
    : (weak)  Toggleswitch_Factory                                      # Toggleswitch_Factory  is from   src/lib/x-kit/widget/leaf/toggleswitch-factory.api

    {


        attributes
            =
            [ (wa::is_active,  wa::BOOL,  wa::BOOL_VAL TRUE),
              (wa::is_set,     wa::BOOL,  wa::BOOL_VAL FALSE)
            ];

        fun realize { kidplug, window, window_size } (state, (plea_slot, event_slot, bv))
            =
            {   my  xc::KIDPLUG { from_mouse', from_other', ... }
                    =
                    xc::ignore_keyboard  kidplug;

                mouse_slot =  make_mailslot ();

                receive_mouse'  =  take_from_mailslot'  mouse_slot;

                drawf =  button_look::config (bv, window, window_size);

                fun do_plea (bb::GET_BUTTON_ACTIVE_FLAG reply_1shot, state)
                        => 
                        {   put_in_oneshot (reply_1shot, bb::get_button_active_flag  state);
                            #
                            state;
                        };

                    do_plea (bb::SET_BUTTON_ACTIVE_FLAG arg, state)
                        =>
                        bb::set_button_active_flag (arg, state);

                    do_plea (bb::GET_SIZE_CONSTRAINT reply_1shot, state)
                        => 
                        {   put_in_oneshot (reply_1shot, button_look::bounds bv);
                            #
                            state;
                        };

                    do_plea (bb::GET_ARGS reply_1shot, state)
                        => 
                        {   put_in_oneshot (reply_1shot, button_look::window_args bv);
                            #
                            state;
                        };

                    do_plea (bb::GET_STATE reply_1shot, state)
                        =>
                        {   put_in_oneshot (reply_1shot, bb::get_state state);
                            #
                            state;
                        };

                    do_plea (bb::SET_STATE arg, state)
                        =>
                        bb::set_state (arg, state);

                    do_plea (_, state)
                        =>
                        state;
                end;


                fun do_mom (xc::ETC_REDRAW _, me as (state, drawf))
                        => 
                        {   drawf state;
                            me;
                        };

                    do_mom (xc::ETC_RESIZE (xg::BOX { wide, high, ... } ), (state, _))
                        => 
                        (state, button_look::config (bv, window, xg::SIZE { wide, high } ));

                    do_mom (_, me)
                        =>
                        me;
                end;


                fun do_mouse (bb::mouse::FOCUS v, me as ({ button_state, has_mouse_focus, mousebutton_is_down => FALSE }, drawf))
                        =>
                        if (v == has_mouse_focus)
                            #
                            me;
                        else
                            state' = { button_state, has_mouse_focus => v, mousebutton_is_down => FALSE };

                            drawf state';

                            put_in_mailslot
                              (
                                event_slot,

                                v  ??  tt::TOGGLE_READY
                                   ::  tt::TOGGLE_NORMAL
                              );

                            (state', drawf);
                        fi;

                    do_mouse (bb::mouse::FOCUS v, ({ button_state, has_mouse_focus, mousebutton_is_down => TRUE }, drawf))
                        =>
                        {   state' = { button_state, has_mouse_focus => v, mousebutton_is_down => TRUE };

                            drawf state';
                            (state', drawf);
                        };

                    do_mouse (bb::mouse::DOWN bttn, ({ button_state, ... }, drawf))
                        =>
                        {   state' = { button_state, has_mouse_focus => TRUE, mousebutton_is_down => TRUE };

                            drawf state';
                            (state', drawf);
                        };

                    do_mouse (bb::mouse::UP bttn, (state, drawf))
                        =>
                        if state.has_mouse_focus
                            #
                            state' = { button_state => bb::flip state.button_state, has_mouse_focus => TRUE, mousebutton_is_down => FALSE };

                            drawf state';

                            put_in_mailslot  (event_slot,  tt::TOGGLE_SET (bb::get_state state'));

                            (state', drawf);

                       else
                            state' = { button_state => state.button_state, has_mouse_focus => FALSE, mousebutton_is_down => FALSE };

                            drawf state';

                            put_in_mailslot  (event_slot,  tt::TOGGLE_NORMAL);

                            (state', drawf);
                       fi;
                end;

                fun active_cmd_p (me as (state, drawf))
                    =
                    do_one_mailop [

                        take_from_mailslot'  plea_slot
                            ==>
                            (fn mailop
                                =
                                {   state' = do_plea (mailop, state); 

                                    if (state' == state)
                                        #
                                        active_cmd_p me;
                                    else
                                        drawf state'; 

                                        if (bb::get_button_active_flag state')
                                            #
                                            put_in_mailslot  (event_slot,  tt::TOGGLE_SET (bb::get_state state'));
                                            #
                                            active_cmd_p (state', drawf);
                                        else
                                            if (state.has_mouse_focus or state.mousebutton_is_down)
                                                #
                                                put_in_mailslot  (event_slot,  tt::TOGGLE_NORMAL);
                                            fi;

                                            inactive_cmd_p (state', drawf);
                                        fi;
                                    fi;
                                }),


                        receive_mouse'        ==>  (fn m      =  active_cmd_p (do_mouse (m, me))),
                        from_other' ==>  (fn mailop =  active_cmd_p (do_mom (xc::envelope_contents mailop, me)))
                    ]

                also
                fun inactive_cmd_p (me as (state, drawf))
                    =
                    do_one_mailop [

                        take_from_mailslot'  plea_slot
                            ==>
                            (fn mailop
                                =
                                {   state' = do_plea (mailop, state); 

                                    if (state == state')
                                        #
                                        inactive_cmd_p me;
                                    else
                                        drawf state';

                                        if (bb::get_button_active_flag state')
                                            #   
                                            active_cmd_p (state', drawf);
                                        else
                                            put_in_mailslot  (event_slot,  tt::TOGGLE_SET (bb::get_state state'));
                                            #   
                                            inactive_cmd_p (state', drawf);
                                        fi;
                                    fi;
                                }),

                        receive_mouse' ==>
                            fn bb::mouse::FOCUS has_mouse_focus =>  inactive_cmd_p ({ button_state => state.button_state, has_mouse_focus, mousebutton_is_down => state.mousebutton_is_down }, drawf);
                                          _                     =>  inactive_cmd_p me;
                            end,


                        from_other' ==>
                            (fn mailop =  inactive_cmd_p (do_mom (xc::envelope_contents  mailop,  me)))
                    ];

                make_thread  "toggle_control from_mouse"  .{
                    #
                    bb::mse_p (from_mouse', mouse_slot);
                };

                if (bb::get_button_active_flag  state)     active_cmd_p (state, drawf);
                else                                     inactive_cmd_p (state, drawf);
                fi;
            };

        fun init (dictionary as (plea_slot, event_slot, bv)) state
            =
            loop state
            where 

                fun loop state
                    =
                    case (take_from_mailslot  plea_slot)
                        #                 
                        bb::GET_BUTTON_ACTIVE_FLAG reply_1shot => {  put_in_oneshot (reply_1shot, bb::get_button_active_flag state);  loop state;  };
                        bb::GET_STATE              reply_1shot => {  put_in_oneshot (reply_1shot, bb::get_state state);               loop state;  };
                        bb::GET_SIZE_CONSTRAINT    reply_1shot => {  put_in_oneshot (reply_1shot, button_look::bounds bv);      loop state;  };
                        bb::GET_ARGS               reply_1shot => {  put_in_oneshot (reply_1shot, button_look::window_args bv); loop state;  };
                        bb::SET_BUTTON_ACTIVE_FLAG arg         => loop (bb::set_button_active_flag (arg, state));
                        bb::SET_STATE arg                      => loop (bb::set_state (arg, state));
                        bb::DO_REALIZE arg                     => realize arg (state, dictionary);
                    esac;
            end;

        fun make_toggleswitchxxx (root_window, view, args)
            =
            {   attributes
                    =
                    wg::find_attribute (wg::attributes (view, attributes, args));

                plea_slot  =  make_mailslot ();
                event_slot =  make_mailslot ();

                button_state
                    =
                    bb::make_button_state
                      ( wa::get_bool (attributes wa::is_active),
                        wa::get_bool (attributes wa::is_set   )
                      );

                bv = button_look::make_button_look (root_window, view, args);

                fun getval msg ()
                    =
                    {   reply_1shot =  make_oneshot_maildrop ();
                        #
                        put_in_mailslot  (plea_slot,  msg reply_1shot);

                        take_from_oneshot  reply_1shot;
                    };

                make_thread  "toggle_control"  .{
                    #
                    init (plea_slot, event_slot, bv)
                         { button_state, has_mouse_focus => FALSE, mousebutton_is_down => FALSE };
                };

                tt::TOGGLE
                  {
                    plea_slot,

                    mailop  =>  take_from_mailslot'  event_slot,

                    widget
                        =>
                        wg::make_widget
                          {
                            root_window,
                            args                     =>   getval bb::GET_ARGS,
                            size_preference_thunk_of =>   getval bb::GET_SIZE_CONSTRAINT,
                            realize                  =>   fn arg =  put_in_mailslot  (plea_slot,  bb::DO_REALIZE arg)
                          }
                  };
            };

        fun make_toggleswitch_with_click_callback (root_window, view, args) click_callback 
            = 
            {   my tt::TOGGLE { widget, plea_slot, mailop }
                    =
                    make_toggleswitchxxx (root_window, view, args);

                fun listener ()
                    =
                    listener
                        case (block_until_mailop_fires  mailop)   
                            #
                            tt::TOGGLE_SET b => click_callback b;
                            _                => ();
                        esac;


                make_thread  "toggle_control command"  listener;

                tt::TOGGLE
                  {
                    widget,
                    #
                    plea_slot,
                    #
                    mailop =>  take_from_oneshot' (make_oneshot_maildrop ())
                  };
            };

    };                                  # generic package toggle_control_g 

end;

## COPYRIGHT (c) 1991, 1994 by AT&T Bell Laboratories.  See SMLNJ-COPYRIGHT file for details.
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2013,
## released per terms of SMLNJ-COPYRIGHT.


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext