PreviousUpNext

15.4.1434  src/lib/x-kit/widget/wrapper/iconifiable-widget.pkg

## iconifiable-widget.pkg
#
# Widget for "iconizing" another widget.

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






###           "The true mystery of the world
###            is the visible, not the invisible."
###
###                       -- Oscar Wilde


stipulate
    include threadkit;                                          # threadkit             is from   src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.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
    #
    package d3 =  three_d;                                      # three_d               is from   src/lib/x-kit/widget/lib/three-d.pkg
    package mr =  xevent_mail_router;                           # xevent_mail_router    is from   src/lib/x-kit/widget/basic/xevent-mail-router.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
herein

    package   iconifiable_widget
    : (weak)  Iconifiable_Widget                                # Iconifiable_Widget    is from   src/lib/x-kit/widget/wrapper/iconifiable-widget.api
    {
        Plea_Mail
          #     
          = GET_SIZE_CONSTRAINT    Oneshot_Maildrop( wg::Widget_Size_Preference )
          #     
          | DO_REALIZE  { kidplug:     xc::Kidplug,
                          window:      xc::Window,
                          window_size: xg::Size
                        }
          ;

        Iconifiable_Widget
            =
            ICONIFIABLE_WIDGET
              { widget:     wg::Widget,
                plea_slot:  Mailslot( Plea_Mail )
              };

        default_font = "-Adobe-Helvetica-Bold-R-Normal--*-120-*";

        min_border_thickness = 4;
        light_border_thickness  = 2;

        pady  =  2;                             # Padding above and below label.
        space = 10;                     # Spacing between light and label.


        attributes
            =
            [ (wa::border_thickness,   wa::INT,    wa::INT_VAL 10),
              (wa::label,          wa::STRING, wa::STRING_VAL ""),
              (wa::font,           wa::FONT,   wa::STRING_VAL default_font),
              (wa::color,          wa::COLOR,  wa::NO_VAL),
              (wa::background,     wa::COLOR,  wa::STRING_VAL "white"),
              (wa::foreground,     wa::COLOR,  wa::STRING_VAL "black"),
              (wa::select_color,   wa::COLOR,  wa::STRING_VAL "black")
            ];

        fun make_font_info font
            =
            {   my  { ascent  => font_ascent,
                      descent => font_descent
                    }
                    =
                    xc::font_high font;

                (font, font_ascent, font_descent);
            };

        fun make_text_label (s, font)
            =
            {   my xc::CHAR_INFO { left_bearing, right_bearing, ... }
                    =
                    .overall_info (xc::text_extents font s);

                (s, left_bearing, right_bearing);
            };

        fun size_of_label ((s, lb, rb), (_, fa, fd))
            =
            xg::SIZE { wide =>  rb - lb + 2,
                       high =>  fa + fd
                     };

        fun set_light_width (_, fonta, fontd)
            =
            (80 * (fonta+fontd)) / 100;

        Result = { child:     wg::Widget,
                   shades:    wg::Shades,

                   fontinfo: (xc::Font, Int, Int),
                   label:    (String, Int, Int),

                   fg:        xc::Rgb,
                   bg:        xc::Rgb,
                   on_color:  xc::Rgb,

                   light_size:    Int,
                   pady:          Int,
                   border_thickness:  Int
                 };

        fun make_result (root, view, args) child
            =
            {   attributes = wg::find_attribute (wg::attributes (view, attributes, args));

                my fontinfo as (f, _, _)
                    =
                    make_font_info (wa::get_font (attributes wa::font));

                label =  make_text_label (wa::get_string (attributes wa::label), f);

                border_thickness     =  wa::get_int   (attributes wa::border_thickness);

                foreground_color =  wa::get_color (attributes wa::foreground);
                background_color =  wa::get_color (attributes wa::background);
                select_color     =  wa::get_color (attributes wa::select_color);

                color = case (wa::get_color_opt (attributes wa::color))   
                            #
                            THE color =>  color; 
                            _         =>  background_color;
                        esac;

                light_size = set_light_width fontinfo;

                  { child,
                    fontinfo,
                    label,
                    fg => foreground_color,
                    bg => background_color,
                    pady,
                    shades => wg::shades root color,
                    light_size,
                    border_thickness => int::max (border_thickness, min_border_thickness),
                    on_color => select_color
                  };
            };

        fun drawfn (dr, xg::SIZE { wide, high },  v: Result)
            =
            {   v.fontinfo ->  (font, font_ascent, font_descent);

                font_high = font_ascent + font_descent;

                txt_pen =  xc::make_pen [ xc::p::FOREGROUND (xc::rgb8_from_rgb  v.fg      ) ];
                on_pen  =  xc::make_pen [ xc::p::FOREGROUND (xc::rgb8_from_rgb  v.on_color) ];

                fun draw_light (is_on, relief)
                    =
                    {   light_size = v.light_size;

                        col = v.border_thickness;
                        row = v.pady + (font_high - light_size) / 2;

                        box =  xg::BOX
                                 { col, row,
                                   wide => light_size,
                                   high => light_size
                                 };

                        arg = { box, relief, width => light_border_thickness };

                        shades = v.shades;

                        if is_on
                            #
                            xc::fill_box  dr  on_pen  box;

                            d3::draw_box  dr  arg  shades;
                        else
                            d3::draw_filled_box  dr  arg  shades;
                        fi;
                    };

                fun draw_groove ()
                    =
                    {   bw = v.border_thickness;

                        my  xg::SIZE { wide => label_wide, ... }
                            =
                            size_of_label (v.label, v.fontinfo);

                        light_size = v.light_size;

                        y = v.pady + (font_high / 2);
                        rht = high - y - (bw / 2);

                        box =  xg::BOX { col=>bw / 2, row=>y, wide=>wide-bw, high=>rht };

                        clr_box
                            =
                            xg::BOX
                              { col  => bw + light_size,
                                row  => v.pady,
                                wide => space + label_wide,
                                high => font_high
                              };

                        arg = { box, width=>2, relief=>wg::GROOVE };

                        d3::draw_box dr arg v.shades;

                        xc::clear_box dr clr_box;
                    };

                fun draw_label ()
                    =
                    {   light_size = v.light_size;

                        v.fontinfo ->  (font, font_ascent, _);
                        v.label    ->  (s, lb, _);

                        col = v.border_thickness + light_size + space - lb + 1;
                        row = v.pady + font_ascent + 1;

                        xc::draw_transparent_string
                            dr
                            txt_pen
                            font
                            (xg::POINT { col, row }, s);
                    };

                fun init ()
                    =
                    {   xc::clear_drawable  dr;
                        draw_groove ();
                        draw_label ();
                    };

                fun draw (do_init, is_open, down)
                    =
                    {   if do_init   init();   fi; 

                        draw_light
                          ( is_open,
                            down ?? wg::SUNKEN :: wg::RAISED
                          );
                    };

                  draw;
              };

        Mouse_Event = MOUSE_EVENT_DOWN
                    | MOUSE_EVENT_UP  Bool
                    ;

        fun mouse_p (m, m_slot)
            =
            loop ()
            where
                fun down_loop is_in
                    = 
                    case (xc::envelope_contents  (block_until_mailop_fires  m))
                        #
                        xc::MOUSE_LAST_UP _ =>  put_in_mailslot  (m_slot,  MOUSE_EVENT_UP is_in);
                        xc::MOUSE_LEAVE _   =>  down_loop  FALSE;
                        xc::MOUSE_ENTER _   =>  down_loop  TRUE;
                        _                   =>  down_loop  is_in;
                    esac; 

                fun loop ()
                    =
                    for (;;) {
                        #
                        case (xc::envelope_contents  (block_until_mailop_fires  m))    
                            #
                            xc::MOUSE_FIRST_DOWN { mouse_button, ... }
                                =>
                                {   put_in_mailslot  (m_slot,  MOUSE_EVENT_DOWN);
                                    #
                                    down_loop TRUE;
                                };

                            _ => ();
                        esac;
                    };
            end;

        fun adjust (wg::INT_PREFERENCE { start_at, step_by, min_steps, ideal_steps, max_steps }, low)
            =
            {   fun adj (l, mn)
                    =
                    if (l >= low)   mn;
                    else            adj (l+step_by, mn+1);
                    fi;

                min_steps = adj (start_at+min_steps*step_by, min_steps);
                ideal_steps = int::max (ideal_steps, min_steps);

                max_steps
                    =
                    case max_steps    
                        #
                        THE m => THE (int::max (m, ideal_steps));
                        NULL => NULL; 
                    esac;

                wg::INT_PREFERENCE { start_at, step_by, min_steps, ideal_steps, max_steps };
            };


        fun bounds (result:  Result, is_open)
            =
            {
                fun inc_base (wg::INT_PREFERENCE { start_at, step_by, min_steps, ideal_steps, max_steps }, extra)
                    =
                    wg::INT_PREFERENCE { start_at=>start_at+extra, step_by, min_steps, ideal_steps, max_steps };

                my  xg::SIZE { wide, high }
                    =
                    size_of_label (result.label, result.fontinfo );

                my { col_preference, row_preference }
                    =
                    wg::size_preference_of  result.child;

                xextra =  2*result.border_thickness;

                topwid =  xextra + result.light_size + wide + space;

                col_preference
                    =
                    if (wg::minimum_length col_preference >= topwid)         col_preference;
                    else                                            adjust (col_preference, topwid);
                    fi;

                yextra = 2*result.pady + result.border_thickness + high;

                row_preference
                    =
                    if is_open  inc_base (row_preference, yextra);
                    else        wg::tight_preference yextra;
                    fi;

                { col_preference =>  inc_base (col_preference, xextra),
                  row_preference
                }; 
            };


        fun realize ( { kidplug, window, window_size }, result:  Result, plea')
            =
            {   mslot =  make_mailslot ();

                rcvm  =  take_from_mailslot'  mslot;

                kidplug ->  xc::KIDPLUG { to_mom=>myco, ... };

                my { kidplug, momplug }
                    =
                    xc::make_widget_cable ();

                my  xc::KIDPLUG { from_other', from_mouse', ... }
                    =
                    xc::ignore_keyboard  kidplug;

                fun child_box (xg::SIZE { wide, high } )
                    =
                    {   bw = result.border_thickness;

                        result.fontinfo ->  (_, font_ascent, font_descent);

                        yoff =  result.pady + font_ascent + font_descent;

                        xg::BOX
                          { col  => bw,
                            row  => yoff,

                            wide => int::max (1, wide-bw-bw),
                            high => int::max (1, high-yoff-bw)
                          };
                    };

                crect = child_box window_size;

                cwin =  wg::make_child_window  (window,  crect,  wg::args_of result.child);

                my  { kidplug => ckidplug,
                      momplug => cmomplug
                    }
                    =
                    xc::make_widget_cable ();

                cmomplug ->  xc::MOMPLUG { from_kid'=>childco, ... };

                dr =  xc::drawable_of_window  window;


                fun handle_co (xc::REQ_RESIZE, is_open)
                        => 
                        if is_open   block_until_mailop_fires  (myco  xc::REQ_RESIZE);   fi;

                   handle_co (xc::REQ_DESTRUCTION, _)
                       => 
                       {   xc::destroy_window  cwin;
                           #
                           block_until_mailop_fires  (myco  xc::REQ_DESTRUCTION);
                       };
                end;


                fun do_mom (xc::ETC_RESIZE (xg::BOX { wide, high, ... } ), me)
                        =>
                        {   size =  xg::SIZE { wide, high };

                            if (#1 me)
                                #
                                xc::move_and_resize_window  cwin  (child_box size);
                            fi;
                            (#1 me, #2 me, drawfn (dr, size, result));
                        };

                    do_mom (xc::ETC_REDRAW _, me as (is_open, down, drawfn))
                        =>
                        { drawfn (TRUE, is_open, down); me;};

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


                fun do_plea (GET_SIZE_CONSTRAINT reply_1shot, is_open)
                        => 
                        put_in_oneshot  (reply_1shot,  bounds (result, is_open));

                    do_plea _ => ();
                end;


                fun handle_mouse_event (MOUSE_EVENT_DOWN, (is_open, _, drawfn))
                        =>
                        {   drawfn (FALSE, is_open, TRUE);
                            #
                            (is_open, TRUE, drawfn);
                        };

                    handle_mouse_event (MOUSE_EVENT_UP TRUE, (is_open, _, drawfn))
                        =>
                        {   if is_open  xc::hide_window  cwin;
                            else        xc::show_window  cwin;
                            fi; 

                            block_until_mailop_fires  (myco  xc::REQ_RESIZE);

                            drawfn (FALSE, not is_open, FALSE);

                            (not is_open, FALSE, drawfn);
                        };

                    handle_mouse_event (MOUSE_EVENT_UP FALSE, (is_open, _, drawfn))
                        =>
                        {   drawfn (FALSE, is_open, FALSE);

                            (is_open, FALSE, drawfn);
                        };
                end;


                fun main me
                    =
                    do_one_mailop [
                        plea'       ==>  (fn r        =  { do_plea (r,#1 me);  main me;}),
                        from_other' ==>  (fn envelope =    main (do_mom (xc::envelope_contents envelope, me))),
                        rcvm        ==>  (fn m        =    main (handle_mouse_event (m, me))),
                        childco     ==>  (fn c        =  { handle_co (c,#1 me); main me;})
                    ];

                    make_thread "iconifiable_widget" .{
                        #
                        mouse_p (from_mouse', mslot);
                    };

                    mr::route_pair (kidplug, momplug, cmomplug);

                    wg::realize_fn

                        result.child

                        { kidplug     =>  ckidplug, 
                          window      =>  cwin,
                          window_size =>  xg::box::size  crect
                        };

                    main (FALSE, FALSE, drawfn (dr, window_size, result));
              };

        fun init (result:  Result, plea')
            =
            loop ()
            where
                fun do_plea (GET_SIZE_CONSTRAINT reply_1shot) =>   put_in_oneshot (reply_1shot, bounds (result, FALSE));
                    do_plea (DO_REALIZE arg                 ) =>   realize (arg, result, plea');
                end;

                fun loop ()
                    =
                    for (;;) {
                        do_plea  (block_until_mailop_fires  plea');
                    };
            end;

        fun make_iconifiable_widget (root_window, view, args) widget
            =
            {   plea_slot =  make_mailslot ();
                result    =  make_result (root_window, view, args) widget;

                fun size_preference_thunk_of ()
                    =
                    {   reply_1shot =  make_oneshot_maildrop ();
                        #
                        put_in_mailslot (plea_slot, GET_SIZE_CONSTRAINT reply_1shot);

                        take_from_oneshot  reply_1shot;
                    };

                w = wg::make_widget {
                          root_window,
                          size_preference_thunk_of,
                          args    =>  fn ()  =  { background => THE result.bg },
                          realize =>  fn arg =  put_in_mailslot (plea_slot, DO_REALIZE arg)
                        };

                make_thread "iconifiable_widget init" .{
                    #
                    init  (result,  take_from_mailslot' plea_slot);
                };

                ICONIFIABLE_WIDGET { widget=>w, plea_slot };
            };

        fun as_widget (ICONIFIABLE_WIDGET { widget, ... } )
            =
            widget;

    };                  # package iconifiable_widget

end;


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext