15.4.1364  src/lib/x-kit/widget/basic/widget-base.pkg

## widget-base.pkg
#
# Definitions for basic widget types.

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






###                 "Programming graphics in X is like
###                  finding sqrt (pi) using Roman numerals."
###
###                                    - Henry Spencer

stipulate
    include threadkit;                                  # threadkit     is from   src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.pkg
    #
    package si =  shade_imp;                            # shade_imp     is from   src/lib/x-kit/widget/lib/shade-imp.pkg
    package xc =  xclient;                              # xclient       is from   src/lib/x-kit/xclient/xclient.pkg
    package xg =  xgeometry;                            # xgeometry     is from   src/lib/std/2d/xgeometry.pkg
herein

    package   widget_base
    : (weak)  Widget_Base                               # Widget_Base   is from   src/lib/x-kit/widget/basic/widget-base.api
    {
        Shades = si::Shades;

        exception BAD_STEP;

        Int_Preference
            =
            INT_PREFERENCE
              {
                start_at:     Int,
                step_by:      Int,
                #
                min_steps:    Int,
                max_steps:    Null_Or(Int),
                ideal_steps:  Int
              };

        Widget_Size_Preference
            =
            { col_preference:  Int_Preference,
              row_preference:  Int_Preference
            };

        # This is apparently nowhere called at present:
        #
        fun make_widget_size_preference  x
            =
            x;

        fun tight_preference x =  INT_PREFERENCE { start_at => x, step_by => 1, min_steps => 0, ideal_steps => 0, max_steps => THE 0 };
        fun loose_preference x =  INT_PREFERENCE { start_at => x, step_by => 1, min_steps => 0, ideal_steps => 0, max_steps => NULL  };

        fun preferred_length (INT_PREFERENCE { start_at, step_by, ideal_steps, ... } ) =  start_at + step_by*ideal_steps;
        fun minimum_length   (INT_PREFERENCE { start_at, step_by,   min_steps, ... } ) =  start_at + step_by*min_steps;

        fun maximum_length   (INT_PREFERENCE { start_at, step_by, max_steps=>NULL,    ... } ) =>  NULL;
            maximum_length   (INT_PREFERENCE { start_at, step_by, max_steps=>THE max, ... } ) =>  THE (start_at + step_by*max);
        end;

        fun make_tight_size_preference (x, y)
            =
            { col_preference => tight_preference x,
              row_preference => tight_preference y
            };

        fun is_between_length_limits (dim, v)
            =
            minimum_length dim <= v
            and
            case (maximum_length dim)   
                #
                THE max =>  v <= max;
                NULL    =>  TRUE;
            esac;

        fun is_within_size_limits
            ( { col_preference, row_preference }:   Widget_Size_Preference,
              xg::SIZE { wide, high }
            )
            =
            is_between_length_limits (col_preference, wide)  and
            is_between_length_limits (row_preference, high);

        Window_Args
            =
            { background:  Null_Or( xc::Rgb ) };


        fun make_child_window
            ( parent_window,
              box,
              args:  Window_Args
            )
            =
            {   my  xg::SIZE { wide, high }
                    =
                    xg::box::size  box;

                if (wide <= 0  or  high <= 0) 
                    #
                    lib_base::failure
                        {
                            module => "Widget",
                            func   => "wrapCreate",
                            msg    => "invalid size"
                        };
                fi;

                xc::make_simple_subwindow  parent_window
                  {
                    background_color =>  case args.background  THE rgb => THE (xc::rgb8_from_rgb rgb); NULL => NULL; esac,
                    border_color     =>  NULL,          # Not used.
                    #   
                    site =>  xg::WINDOW_SITE
                               { upperleft    =>  xg::box::upperleft  box,
                                 size         =>  xg::box::size       box,
                                 border_thickness =>  0
                               }
                  };
              };

        # Wrap a queue around given input mailop,
        # converting it from synchronous to asynchronous:
        #
        fun wrap_queue ine                      # "ine" may be "input_event"
            =
            {   out_slot
                    =
                    make_mailslot ();


                fun loop ([],[])
                        =>
                        loop ([do_mailop ine],[]);

                    loop ([], l)
                        =>
                        loop (reverse l,[]);

                    loop (l as e ! tl, rest)
                        => 
                        loop (
                            select [

                                give'  (out_slot,  e)
                                    ==>
                                    .{   (tl, rest);  },

                                ine
                                    ==>
                                    .{   (l, #e ! rest);  }
                            ]
                        );
                end;


                make_thread "widget_base" .{
                    loop ([],[]);
                };

                take'  out_slot;
            };

    };                          # package widget_base 

end;