PreviousUpNext

15.4.1432  src/lib/x-kit/widget/wrapper/border.pkg

## border.pkg
#
# Border widget -- draws a border around its child.

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


###             "Doubt is not a pleasant condition,
###              but certainty is absurd."
###                                  -- Voltaire

###             "If users wanted a graphical interface,
###              wouldn't the Macintosh dominate the market?"
###
###                                  -- Bruce Tonkin, 1988



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
    package wy =  widget_style;         # widget_style          is from   src/lib/x-kit/widget/lib/widget-style.pkg
herein

    package   border
    : (weak)  Border                    # Border                is from   src/lib/x-kit/widget/wrapper/border.api
    {
        attributes
            =
            [ (wa::padx,           wa::INT,      wa::INT_VAL 0),
              (wa::pady,           wa::INT,      wa::INT_VAL 0),
              (wa::border_thickness,   wa::INT,      wa::INT_VAL 2),
              (wa::relief,         wa::RELIEF,   wa::RELIEF_VAL (wg::SUNKEN)),
              (wa::background,     wa::COLOR,    wa::NO_VAL)
            ];

        Result = { padx:  Int,
                   pady:  Int,
                   border_thickness:  Int,
                   relief:  wg::Relief,
                   background:  Null_Or( xc::Rgb )
                 };

        Border
            =
            BORDER
              { widget:     wg::Widget,
                plea_slot:  Mailslot(  Null_Or(  xc::Rgb ))
              };

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

                { padx         => wa::get_int       (attributes wa::padx),
                  pady         => wa::get_int       (attributes wa::pady),
                  border_thickness => wa::get_int       (attributes wa::border_thickness),
                  relief       => wa::get_relief    (attributes wa::relief),
                  background   => wa::get_color_opt (attributes wa::background)
                };
            };

        fun border (root_window, view, args) child
            =
            {   result   = make_resources (view, args);

                plea_slot =  make_mailslot ();
                plea'     =  take_from_mailslot' plea_slot;

                realize_1shot
                    =
                    make_oneshot_maildrop ();


                fun fillfn wg::FLAT (d, r, c)
                        =>
                        {   p = xc::make_pen [xc::p::FOREGROUND (xc::rgb8_from_rgb c)];

                            fn () =  xc::fill_box d p r;
                        };

                    fillfn rel (d, r, c)
                        =>
                        {   my shades as { base, ... }
                                =
                                wg::shades root_window c;

                            arg1 = { box=>r, width=> result.border_thickness, relief=>rel };

                            fun fill ()
                                =
                                {   if (result.padx != 0   or  result.pady != 0)
                                        xc::fill_box d base r;
                                    fi;

                                    d3::draw_box d arg1 shades;
                                };
                            fill;
                        };
                end;


                fun size ()
                    =
                    {   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 { col_preference, row_preference }
                            =
                            wg::size_preference_of  child;

                        xextra = 2*(result.padx + result.border_thickness);
                        yextra = 2*(result.pady + result.border_thickness);

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


                fun realize_frame { kidplug as xc::KIDPLUG { to_mom=>myco, ... }, window, window_size } color
                    =
                    {   my  { kidplug, momplug }
                            =
                            xc::make_widget_cable ();

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

                        fun child_box (xg::SIZE { wide, high } )
                            =
                            {   xoff = result.padx + result.border_thickness;
                                yoff = result.pady + result.border_thickness;

                                xg::BOX
                                  { col  => xoff,
                                    row  => yoff,
                                    wide => int::max (1, wide-(2*xoff)),
                                    high => int::max (1, high-(2*yoff))
                                  };
                            };

                        crect = child_box window_size;

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

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

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

                        drawable = xc::drawable_of_window  window;

                        fun make_fill (_, NULL ) =>  (fn _ = xc::clear_drawable drawable);
                            make_fill (r, THE c) =>  fillfn result.relief (drawable, r, c);
                        end;

                        fun main (box, color, update)
                            =
                            {   fill = make_fill (box, color);

                                fun handle_co xc::REQ_RESIZE      =>  block_until_mailop_fires  (myco  xc::REQ_RESIZE);
                                    handle_co xc::REQ_DESTRUCTION =>  xc::destroy_window cwin;
                                end;

                                fun do_mom (xc::ETC_RESIZE (xg::BOX { col, row, wide, high } ))
                                        =>
                                        {   xc::move_and_resize_window cwin 
                                                (child_box (xg::SIZE { wide, high } ));

                                            main (xg::BOX { col=>0, row=>0, wide, high }, color, FALSE);
                                        };

                                    do_mom (xc::ETC_REDRAW _)
                                        =>
                                        fill ();

                                    do_mom _ => ();
                                end;

                                fun loop ()
                                    =
                                    do_one_mailop [
                                        plea'       ==>   (fn c = main (box, c, TRUE)),
                                        from_other' ==>   loop o do_mom o xc::envelope_contents,
                                        childco     ==>   loop o handle_co
                                    ];

                                loop (if update  fill (); fi);
                            };

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

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

                            xc::show_window cwin;

                            main (xg::box::make (xg::point::zero, window_size), color, FALSE);
                        };

                fun init_loop color
                    =
                    do_one_mailop [
                        take_from_oneshot'  realize_1shot
                            ==>
                            .{  realize_frame  #arg  color;  },

                        take_from_mailslot' plea_slot
                            ==>
                            .{  init_loop #c;  }
                    ];

                make_thread "frame" .{
                    #
                    init_loop result.background;
                };

                BORDER
                  {
                    plea_slot,

                    widget => wg::make_widget
                                {
                                  root_window,
                                  args      =>  fn () = { background => NULL },
                                  size_preference_thunk_of =>  size, 

                                  realize   =>  fn arg =  put_in_oneshot (realize_1shot, arg)
                                }
                   };
              };


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


        fun set_color
                (BORDER { plea_slot, ... } )
                color
            =
            put_in_mailslot (plea_slot, color);


        fun make_border { color, width, child }
            =
            {   root_window = wg::root_window_of child;

                name = wy::make_view { name    =>  wy::style_name ["frame"],
                                       aliases =>  []
                                     };

                args =  [ (wa::border_thickness, wa::INT_VAL width) ];

                args =  case color   
                            #
                            THE c => (wa::background,  wa::COLOR_VAL c) ! args;
                            NULL  => args;
                        esac;

                border (root_window, (name, wg::style_of root_window), args)
                     child;
            };
    };
end;


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext