PreviousUpNext

15.4.1377  src/lib/x-kit/widget/layout/scrolled-widget.pkg

## scrolled-widget.pkg

# Compare with:
#     widget_with_scrollbars, designed to be harder to use but more flexible:
#         src/lib/x-kit/widget/layout/widget-with-scrollbars.pkg
#
# See also:
#     viewport, which provides a window onto a larger widget,
#     typically panned using scrollbars:
#         src/lib/x-kit/widget/layout/viewport.pkg

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


# scrolled_widget widget, for panning over a child widget
# using scrollbars.
#
# TODO:
#   granularity         XXX BUGGO FIXME



###               "Life obliges me to do something, so I paint."
###
###                                -- Rene Magritte


stipulate
    include threadkit;                                  # threadkit             is from   src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.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
    #
    package bdr =  border;                              # border                is from   src/lib/x-kit/widget/wrapper/border.pkg
    package lw  =  line_of_widgets;                     # line_of_widgets       is from   src/lib/x-kit/widget/layout/line-of-widgets.pkg
    package vp  =  viewport;                            # viewport              is from   src/lib/x-kit/widget/layout/viewport.pkg
    package sb  =  scrollbar;                           # scrollbar             is from   src/lib/x-kit/widget/leaf/scrollbar.pkg
    package qk  =  quark;                               # quark                 is from   src/lib/x-kit/style/quark.pkg
    #
    package xg  =  xgeometry;                           # xgeometry             is from   src/lib/std/2d/xgeometry.pkg
herein

    package   scrolled_widget
    : (weak)  Scrolled_Widget                           # Scrolled_Widget       is from   src/lib/x-kit/widget/layout/scrolled-widget.api
    {
        Scrolled_Widget
            =
            SCROLLED_WIDGET  { scrolled_widget:  wg::Widget };

        fun monitor (continuous, scrollbar, sw, setview, geometry_mailop) ()
            =
            {   set = sb::set_scrollbar_thumb   scrollbar;

                scrollbar_change'
                    =
                    sb::scrollbar_change'_of
                        scrollbar;

                fun init is_on (origin, size, total)
                    =
                    {   r_total = real total;
                        r_size  = real size;

                        maxo = total - size;

                        fun shift_up (r, y)
                            =
                            {   y' = y + int::min (maxo-y, trunc((1.0-r)*r_size));

                                if (y == y')

                                     y;
                                else
                                     {   setview y';
                                         set { top => THE((real y')//r_total), size => NULL };
                                         y';
                                     }
                                     except _ = y;
                                fi;
                            };

                        fun shift_down (r, y)
                            =
                            {   y' = int::max (0, y-trunc (r*r_size));

                                if (y == y')

                                     y;
                                else
                                     {   setview y';
                                         set { top => THE((real y')//r_total), size => NULL };
                                         y';
                                     } 
                                     except _ = y;
                                fi;
                            };

                        fun adjust (r, y)
                            =
                            {   y' = trunc (r*r_total);

                                if (y == y')

                                     y;
                                else
                                     {   setview y';
                                         y';
                                     }
                                     except _ = y;
                                fi;
                            };

                        fun do_scrollbar_change  adjust_fn  arg
                            =
                            case arg
                                #
                                (sb::SCROLL_START r, y) => adjust_fn  (r, y);
                                (sb::SCROLL_UP    r, y) => shift_up   (r, y);
                                (sb::SCROLL_DOWN  r, y) => shift_down (r, y);
                                (sb::SCROLL_MOVE  r, y) => adjust_fn  (r, y);
                                (sb::SCROLL_END   r, y) => adjust     (r, y);
                            esac;


                        do_scrollbar_change
                            =
                            continuous  ??  do_scrollbar_change  adjust
                                        ::  do_scrollbar_change  (fn (_, y) = y);

                        fun onloop origin
                            =
                            do_one_mailop [
                                #
                                scrollbar_change' ==>  (fn adjust_fn =  onloop (do_scrollbar_change (adjust_fn, origin))),
                                geometry_mailop   ==>  init TRUE
                            ];

                        fun offloop ()
                            =
                            init FALSE (block_until_mailop_fires geometry_mailop);


                          if (maxo <= 0)

                              if is_on   sw FALSE; fi;

                              offloop ();
                          else
                              size = r_size//r_total;
                              top = (real origin)//r_total;

                              set { size => THE size, top => THE top };
                              if (not is_on) sw TRUE; fi;
                              onloop origin;
                          fi;
                      };                                # fun init 

                  init FALSE (0, 1, 1);
              };                                        # fun monitor 

        fun main (viewport, vf, hf)
            =
            loop ()
            where
                viewport_configuration_change'
                    =
                    vp::get_viewport_configuration_change_mailop
                        viewport;

                fun loop ()
                    =
                    for (;;) {

                        my  { box       =>  xg::BOX { col, row, wide, high }, 
                             child_size =>  xg::SIZE size
                            }
                            =
                            block_until_mailop_fires  viewport_configuration_change';

                        vf (row, high, size.high);
                        hf (col, wide, size.wide);
                    };
            end;                        # fun main 

        attribute_continuous =  qk::quark "continuous";
        attribute_hsb        =  qk::quark "hsb";
        attribute_vsb        =  qk::quark "vsb";

        attributes
            =
            [ (wa::background,        wa::COLOR,    wa::STRING_VAL "white"),
              (attribute_continuous,  wa::BOOL,     wa::BOOL_VAL FALSE),
              (attribute_hsb,         wa::BOOL,     wa::NO_VAL),
              (attribute_vsb,         wa::BOOL,     wa::NO_VAL)
            ];

        fun do_layout (w, THE top, THE left, view as (name, style))
                =>
                (b, THE (hsb, hsw), THE (vsb, vsw))
                where

                    root_window =  wg::root_window_of  w;

                    hview = (wy::extend_view (name, "hscrollbar"), style);

                    hsb = sb::make_horizontal_scrollbar' (root_window, hview,[]);

                    hfr = bdr::border (root_window, hview,[]) (sb::as_widget hsb);

                    b1 =  top   ??   lw::line_of_widgets (root_window, view, []) (lw::VT_CENTER [lw::WIDGET (bdr::as_widget hfr), lw::WIDGET w])
                                ::   lw::line_of_widgets (root_window, view, []) (lw::VT_CENTER [lw::WIDGET w, lw::WIDGET (bdr::as_widget hfr)]);

                    vview = (wy::extend_view (name, "vscrollbar"), style);
                    vsb   = sb::make_vertical_scrollbar' (root_window, vview,[]);
                    vfr   = bdr::border (root_window, vview,[]) (sb::as_widget vsb);

                    (wg::size_preference_of (bdr::as_widget  hfr))
                        ->
                        { row_preference => wg::INT_PREFERENCE { start_at, step_by, min_steps, ideal_steps, max_steps }, ... };

                    g = lw::SPACER
                          { min_size   => start_at + step_by*min_steps,
                            ideal_size => start_at + step_by*ideal_steps,
                            #
                            max_size   => case max_steps
                                              #
                                              THE mx =>  THE (start_at + step_by*mx);
                                              NULL   =>  NULL;
                                          esac
                          };

                    b2 =  top   ??   lw::line_of_widgets (root_window, view,[]) (lw::VT_CENTER [g, lw::WIDGET (bdr::as_widget vfr)   ])
                                ::   lw::line_of_widgets (root_window, view,[]) (lw::VT_CENTER    [lw::WIDGET (bdr::as_widget vfr), g]);

                    hnum =    top  ?? 0 :: 1;
                    vnum =    left ?? 0 :: 1;

                    b = if   left 

                             lw::line_of_widgets
                                 (root_window, view, [])
                                 (lw::HZ_CENTER [ lw::WIDGET (lw::as_widget b2),
                                                  lw::WIDGET (lw::as_widget b1)
                                                ]
                                 );
                        else
                             lw::line_of_widgets
                                 (root_window, view, [])
                                 (lw::HZ_CENTER [ lw::WIDGET (lw::as_widget b1),
                                                  lw::WIDGET (lw::as_widget b2)
                                                ]
                                 );
                        fi;

                    fun vsw TRUE  =>  lw::show b [vnum];
                        vsw FALSE =>  lw::hide b [vnum];
                    end;

                    fun hsw TRUE  => { lw::show b1 [hnum];   lw::show b2 [hnum]; };
                        hsw FALSE => { lw::hide b1 [hnum];   lw::hide b2 [hnum]; };
                    end;

                    hsw FALSE;
                    vsw FALSE;
               end;

            do_layout (w, THE top, NULL, view as (name, style))
                =>
                (box, THE (hsb, hsw), NULL)
                where

                    root_window  =  wg::root_window_of  w;

                    hview =  (wy::extend_view (name, "hscrollbar"), style);

                    hsb   =  sb::make_horizontal_scrollbar' (root_window, hview,[]);

                    fr = bdr::border (root_window, hview,[]) (sb::as_widget hsb);

                    box  =  top   ??  lw::line_of_widgets (root_window, view,[]) (lw::VT_CENTER [lw::WIDGET (bdr::as_widget fr), lw::WIDGET w])
                                  ::  lw::line_of_widgets (root_window, view,[]) (lw::VT_CENTER [lw::WIDGET w, lw::WIDGET (bdr::as_widget fr)]);

                    hnum =  top ?? 0 :: 1;

                    fun hsw TRUE  =>  lw::show box [hnum];
                        hsw FALSE =>  lw::hide box [hnum];
                    end;

                    hsw FALSE;
                end;

            do_layout (w, NULL, THE left, view as (name, style))
                =>
                (box, NULL, THE (vsb, vsw))
                where

                    root_window =  wg::root_window_of  w;

                    vview = (wy::extend_view (name, "vscrollbar"), style);

                    vsb = sb::make_vertical_scrollbar' (root_window, vview,[]);

                    fr = bdr::border (root_window, vview,[]) (sb::as_widget vsb);

                    box =  left  ??  lw::line_of_widgets (root_window, view,[]) (lw::HZ_CENTER [lw::WIDGET (bdr::as_widget fr), lw::WIDGET w])
                                 ::  lw::line_of_widgets (root_window, view,[]) (lw::HZ_CENTER [lw::WIDGET w, lw::WIDGET (bdr::as_widget fr)]);

                    vnum =  left ?? 0 :: 1;

                    fun vsw TRUE  =>   lw::show box [vnum];
                        vsw FALSE => lw::hide box [vnum];
                    end;

                    vsw FALSE;
                end;

            do_layout (w, NULL, NULL, view)
                => 
                (lw::line_of_widgets (wg::root_window_of w, view,[]) (lw::WIDGET w), NULL, NULL);
        end;


        fun scrolled_widget (root_window, view as (name, style), args) widget
            =
            {   attributes
                    =
                    wg::find_attribute
                        (wg::attributes (view, attributes, args));

                color      = wa::get_color (attributes wa::background);
                continuous = wa::get_bool  (attributes attribute_continuous);

                hsb = wa::get_bool_opt (attributes attribute_hsb);
                vsb = wa::get_bool_opt (attributes attribute_vsb);

                vview = (wy::extend_view (name, "viewport"), style);
                viewport = vp::viewport (root_window, vview, args) widget;

                fr = bdr::border (root_window, vview, args) (vp::as_widget viewport);

                my (box, hsb, vsb)
                    =
                    do_layout (bdr::as_widget fr, hsb, vsb, view);

                fun realize arg
                    =
                    {   fun do_monitor (_, NULL)
                                =>
                                (fn _ = ());

                            do_monitor (sv, THE (sb, sw))
                                =>
                                {   slot = make_mailslot ();
                                    #
                                    make_thread "scrollport monitor" (monitor (continuous, sb, sw, sv, take_from_mailslot' slot));

                                    fn arg =  put_in_mailslot (slot, arg);
                                };
                        end;

                        vf = do_monitor (vp::set_vertical_position    viewport, vsb);
                        hf = do_monitor (vp::set_horizontal_position  viewport, hsb);

                        make_thread "scrolled-widget" .{
                            #
                            main (viewport, vf, hf);
                        };

                        wg::realize_fn (lw::as_widget box) arg;
                    };

                SCROLLED_WIDGET
                  {
                    scrolled_widget
                        =>
                        wg::make_widget
                          {
                            root_window =>  wg::root_window_of  widget, 
                            #   
                            args        =>  fn () =  { background => THE color },
                            realize,

                            size_preference_thunk_of
                                =>
                                wg::size_preference_thunk_of
                                    #
                                    (lw::as_widget  box)
                          }
                  };
              };


        fun make_scrolled_widget { scrolled_widget=>scrolled_widget', smooth_scrolling, color, horizontal_scrollbar, vertical_scrollbar }
            =
            {   root_window =  wg::root_window_of  scrolled_widget';

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

                horizontal_scrollbar =   case horizontal_scrollbar    NULL => NULL;    THE { top  } => THE top;    esac;
                vertical_scrollbar   =   case vertical_scrollbar      NULL => NULL;    THE { left } => THE left;   esac;

                fun add (label, THE b, l) =>  (label, wa::BOOL_VAL b) ! l;
                    add (_,     NULL,  l) =>  l;
                end;

                args = add (attribute_hsb, horizontal_scrollbar,
                       add (attribute_vsb, vertical_scrollbar,
                       add (attribute_continuous, THE smooth_scrolling,
                            [])));

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

                scrolled_widget
                  #
                  ( root_window,
                    (name,   wg::style_of  root_window),
                    args
                  )
                  #
                  scrolled_widget';
            };


        fun as_widget (SCROLLED_WIDGET { scrolled_widget, ... } )
            =
            scrolled_widget;

    };                  #  scrolled_widget 

end;


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext