PreviousUpNext

15.4.1370  src/lib/x-kit/widget/fancy/graphviz/text/scroll-viewer.pkg

# scroll-viewer.pkg
#
# An ML viewer with scroll bars.

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

stipulate
    include threadkit;                          # threadkit                     is from   src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.pkg
    #
    package f8b =  eight_byte_float;            # eight_byte_float              is from   src/lib/std/eight-byte-float.pkg
    package xc  =  xclient;                     # xclient                       is from   src/lib/x-kit/xclient/xclient.pkg
    package xtr =  xlogger;                     # xlogger                       is from   src/lib/x-kit/xclient/src/stuff/xlogger.pkg
    #
    package bdr =  border;                      # border                        is from   src/lib/x-kit/widget/wrapper/border.pkg
    package dvd =  divider;                     # divider                       is from   src/lib/x-kit/widget/leaf/divider.pkg
    package low =  line_of_widgets;             # line_of_widgets               is from   src/lib/x-kit/widget/layout/line-of-widgets.pkg
    package sb  =  scrollbar;                   # scrollbar                     is from   src/lib/x-kit/widget/leaf/scrollbar.pkg
    package sl  =  widget_with_scrollbars;      # widget_with_scrollbars        is from   src/lib/x-kit/widget/layout/widget-with-scrollbars.pkg
    package wg  =  widget;                      # widget                        is from   src/lib/x-kit/widget/basic/widget.pkg
    #
    package v   =  ml_source_code_viewer;       # ml_source_code_viewer         is from   src/lib/x-kit/widget/fancy/graphviz/text/ml-source-code-viewer.pkg
herein

    package scroll_viewer {

        fun make_viewer
                root
                (view, init_loc)
            =
            {
                is_bw = case (xc::display_class_of_screen (wg::screen_of root))
                            #   
                            xc::STATIC_GRAY =>  TRUE;
                            xc::GRAY_SCALE  =>  TRUE;
                            _               =>  FALSE;
                        esac;

                vsb = sb::make_vertical_scrollbar  root
                        { color => NULL,
                          size  => 10
                        };

                vsb_widget                              # "vsb" == "vertical scroll bar".
                    =
                    bdr::as_widget
                        (bdr::make_border
                          {
                            color =>  NULL,
                            width =>  1,
                            child =>  sb::as_widget  vsb
                          }
                        );

                view_wid = v::as_widget view;

                fun init_sb ()
                    =
                    {   (v::view_of  view)
                            ->
                            { view_start, view_ht, nlines };

                        r_ht = real view_ht;

                        r_nlines
                            =
                            nlines == 0  ??  r_ht
                                         ::  real nlines;

                        sb::set_scrollbar_thumb  vsb
                          {
                            size =>  THE (r_ht // r_nlines),
                            top  =>  THE (f8b::from_int view_start // r_nlines)
                          };
                    };

                horizontal_scrollbar_change'
                    =
                    sb::scrollbar_change'_of  vsb;

                fun set_top (new_top, nlines)
                    =
                    {   v::scroll_view (view, new_top);
                        #
                        (v::view_of  view)
                            ->
                            { view_start, nlines, ... };

                        sb::set_scrollbar_thumb  vsb
                          {
                            size =>  NULL,
                            top  =>  nlines == 0  ??  THE 0.0
                                                  ::  THE (f8b::from_int view_start // real nlines)
                          };
                    };

                fun smooth r
                    =
                    {   timeout' =  timeout_in'  0.05;
                        #
                        (v::view_of  view)
                            ->
                            { view_start, nlines, ... };

                        r_nlines =  real  nlines;

                        top = floor (r * real nlines);

                        fun do_scrollbar_change i
                            =
                            fn mailop
                                =
                                case mailop
                                    #
                                    sb::SCROLL_MOVE r
                                        =>
                                        {    top' = floor (r * r_nlines);

                                             if (top' != top)   sm (i+1, top');
                                             else               sm (i, top);
                                             fi;
                                        };

                                    sb::SCROLL_END r
                                        =>
                                        {   top' = floor (r * r_nlines);

                                            v::scroll_view (view, top');
                                        };
                                    _   => sm (i, top);
                                esac

                        also
                        fun sm (0, top)
                                =>
                                do_scrollbar_change 0 (block_until_mailop_fires  horizontal_scrollbar_change');

                            sm (7, top)
                                =>
                                {   v::scroll_view (view, top);
                                    sm (0, top);
                                };

                            sm (i, top)
                                =>
                                do_one_mailop [
                                    #
                                    horizontal_scrollbar_change'
                                        ==>
                                        do_scrollbar_change  i,

                                    timeout'
                                        ==>
                                       .{   v::scroll_view (view, top);
                                            sm (0, top);
                                        }
                                ];
                        end;

                        if (top != view_start) 
                            # 
                            v::scroll_view (view, top);
                            sm (0, top);
                        else
                            sm (0, view_start);
                        fi;
                    };

                fun scroller ()
                    =
                    for (;;) {  
                        #
                        case (block_until_mailop_fires  horizontal_scrollbar_change')
                            #
                            sb::SCROLL_UP r
                                =>
                                {   # Move selected line to top:

                                    my { view_start, view_ht, nlines }
                                        =
                                        v::view_of view;

                                    set_top (view_start + floor (real view_ht * r), nlines);
                                };

                            sb::SCROLL_DOWN r
                                =>
                                {   # Move top to selected line:

                                    my { view_start, view_ht, nlines }
                                        =
                                        v::view_of view;

                                    set_top (view_start - floor (real view_ht * r), nlines);
                                };

                            sb::SCROLL_START r
                                =>
                                smooth r;

                            sb::SCROLL_MOVE r
                                => 
                                raise exception  lib_base::IMPOSSIBLE "scroller: move before start";

                            sb::SCROLL_END r
                                =>
                                raise exception  lib_base::IMPOSSIBLE "scroller: end before start";
                        esac;
                    };

                fun scroll_server ()
                    =
                    {     v::scroll_view (view, init_loc);
                        init_sb ();
                         scroller ();
                    };

                layout = if is_bw

                             low::make_line_of_widgets  root
                                 (low::HZ_CENTER
                                   [
                                     low::WIDGET  vsb_widget,

                                     low::WIDGET
                                         (dvd::make_vertical_divider root
                                           {
                                             color =>  NULL,
                                             width =>  1
                                           }
                                         ),

                                     low::WIDGET  view_wid
                                   ]
                                 );
                         else
                             sl::make_widget_with_scrollbars  root
                               {
                                 scrolled_widget      =>  view_wid,
                                 horizontal_scrollbar =>  NULL,

                                 vertical_scrollbar
                                    =>
                                    THE { scrollbar =>  vsb_widget,
                                          pad       =>  0,
                                          left      =>  TRUE
                                        }
                               };
                         fi;

                  xtr::make_thread  "scroll_viewer::scroller"  scroll_server;

                  low::as_widget  layout;
            };

    };                          # package scroll_viewer 

end;


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext