PreviousUpNext

15.4.1433  src/lib/x-kit/widget/wrapper/choice-of-widgets.pkg

## choice-of-widgets.pkg
#
# Manage a list of widgets
# only one of which is visible
# at any given time.

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





###             "The great mystery is not that we should have been
###              thrown down here at random between the profusion
###              of matter and that of the stars;
###
###              it is that from our very prison we should draw,
###              from our own selves, images powerful enough
###              to deny our nothingness."
###
###                                    -- Andre Malraux


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 wg =  widget;                               # widget                is from   src/lib/x-kit/widget/basic/widget.pkg
    package li =  list_indexing;                        # list_indexing         is from   src/lib/x-kit/widget/lib/list-indexing.pkg
    package mr =  xevent_mail_router;                   # xevent_mail_router    is from   src/lib/x-kit/widget/basic/xevent-mail-router.pkg
herein

    package   choice_of_widgets
    : (weak)  Choice_Of_Widgets                         # Choice_Of_Widgets     is from   src/lib/x-kit/widget/wrapper/choice-of-widgets.api
    {
        exception NO_WIDGETS;
        exception BAD_INDEX =  li::BAD_INDEX;

        Plea_Mail
          #
          = SIZE_PREFERENCE
          #
          | DO_REALIZE  {
              kidplug:      xc::Kidplug,
              window:       xc::Window,
              window_size:  xg::Size
            }
          | SHOWING     Mailslot( Null_Or( Int ) )
          | CHILD_COUNT Mailslot( Int )
          | SHOW        Int
          | INSERT     (Int, List( wg::Widget ))
          | DELETE      List( Int )
          ;

        Reply_Mail
          = OKAY
          | ERROR  Exception
          ;

        Choice_Of_Widgets
            =
            CHOICE_OF_WIDGETS
              { widget:      wg::Widget, 
                #
                plea_slot:   Mailslot( Plea_Mail  ),
                reply_slot:  Mailslot( Reply_Mail )
              };

        Child_Widget
            =
            CHILD_WIDGET
              { widget:     wg::Widget, 
                window:     xc::Window,
                to_mom:     Mailop( xc::Mail_To_Mom )
              };

         Choice(X)
          = EMPTY
          | CHOICE  {  
              top:  Int,
              widget:  X,
              wlist:  List(X)
            };

        fun cloop co ()
            =
            {   block_until_mailop_fires co;
                cloop co ();
            };

        fun is_valid (EMPTY, 0) => TRUE;
            is_valid (EMPTY, _) => FALSE;
            is_valid (CHOICE { wlist, ... }, i) => li::is_valid (wlist, i);
        end;

        fun top_index EMPTY => NULL;
            top_index (CHOICE { top, ... } ) => THE top;
        end;

        fun topi EMPTY => raise exception lib_base::IMPOSSIBLE "choice_of_widgets::topi";
            topi (CHOICE { top, ... } ) => top;
        end;

        fun top_widget EMPTY => raise exception lib_base::IMPOSSIBLE "choice_of_widgets::topWidget";
            top_widget (CHOICE { widget, ... } ) => widget;
        end;

        fun top_window EMPTY => raise exception lib_base::IMPOSSIBLE "choice_of_widgets::topWin";
            top_window (CHOICE { widget=>CHILD_WIDGET { window, ... }, ... } ) => window;
        end;

        fun child_count EMPTY => 0;
            child_count (CHOICE { wlist, ... } ) => length wlist;
        end;



        stipulate

            default_length_preference
                =
                wg::INT_PREFERENCE
                  {
                    start_at =>  1,
                    step_by  =>  1,
                    #
                    min_steps   =>  0,
                    ideal_steps =>  0,
                    max_steps   =>  NULL
                  };
        herein

            default_size_preference
                =
                { col_preference =>  default_length_preference,
                  row_preference =>  default_length_preference
                };
        end;



        fun size_preference  f  (CHOICE { widget, ... } ) =>  f widget;
            size_preference  f   EMPTY                    =>  default_size_preference;
        end;

        fun delete_w (EMPTY, _)
                =>
                raise exception BAD_INDEX;

            delete_w (CHOICE { wlist, top, widget }, indices)
                =>
                {
                    indices = li::check_sort indices;

                    case (li::delete (wlist, indices))

                         ([], dlist)
                             =>
                             (EMPTY, dlist);

                         (wlist', dlist)
                             =>
                             case (li::pre_indices (top, indices) )
                                 #                         
                                 NULL  => (CHOICE { wlist=>wlist', top=> 0,     widget => head wlist'}, dlist);
                                 THE j => (CHOICE { wlist=>wlist', top=> top-j, widget               }, dlist);
                             esac;
                    esac;
                }
                except
                    _ = raise exception BAD_INDEX;
        end;

        # insert_w:
        # Assume wl != []
        #
        fun insert_w (EMPTY, 0, wl)
                =>
                CHOICE { wlist=>wl, top=>0, widget=> head wl };

            insert_w (EMPTY, _, _)
                =>
                raise exception BAD_INDEX;

            insert_w (CHOICE { wlist, top, widget }, index, wl)
                =>
                {   wlist' = li::set (wlist, index, wl);

                    top' =   index <= top   ??  top + (length wl)
                                            ::  top;

                    CHOICE { wlist=>wlist', top=>top', widget }; 
                }
                except
                    _ = raise exception BAD_INDEX;
        end;

        fun make_vis (EMPTY, _)
                =>
                raise exception BAD_INDEX;

            make_vis (CHOICE { wlist, ... }, i)
                =>
                {   w = list::nth (wlist, i);

                    (CHOICE { wlist, top=>i, widget=>w }, w); 
                }
                except
                    _ = raise exception BAD_INDEX;
        end;

        fun make_real (mkr, EMPTY)
                =>
                EMPTY;

            make_real (mkr, CHOICE { top, widget, wlist } )
                =>
                {   wl = map mkr wlist;

                    CHOICE { top, wlist => wl, widget => list::nth (wl, top) };
                };
        end;

        fun destroy (CHILD_WIDGET { window, to_mom, ... } )
            =
            {   xc::destroy_window window;

                make_thread "choice_of_widgets destroy" (cloop to_mom);

                ();
            };

        fun make_choice_of_widgets  root_window  widgets
            =
            {   reply_slot =  make_mailslot ();
                plea_slot  =  make_mailslot ();
                size_slot  =  make_mailslot ();

                plea'      = take_from_mailslot'  plea_slot;


                fun make_coevt EMPTY
                        =>
                        cat_mailops [];

                    make_coevt (CHOICE { wlist, ... } )
                        =>
                        cat_mailops (make_l (wlist, 0))
                        where
                            fun make_mailop (CHILD_WIDGET { to_mom, ... }, i)
                                =
                                to_mom  ==>  .{  (i, #mailop);  };

                            fun make_l ([], _)     =>   [];
                                make_l (w ! wl, i) =>   (make_mailop (w, i)) ! (make_l (wl, i+1));
                            end;
                        end;
                end;


                fun realize
                    { kidplug => kidplug as xc::KIDPLUG { to_mom, ... },
                      window,
                      window_size => given_size
                    }
                    widgets
                    =
                    {   me = make_real (make_real' given_size, widgets);

                        {   (top_widget me)                                     # Dr David Benson's resize bugfix (SML/NJ 110.59).
                                ->
                                CHILD_WIDGET { window, widget, ... };

                            xc::configure_window   window
                              [
                                xc::c::STACK_MODE  xc::ABOVE,
                                xc::c::SIZE        given_size
                              ];

                            if (not (wg::okay_size (widget, given_size)))
                                #
                                block_until_mailop_fires (to_mom  xc::REQ_RESIZE);
                            fi;
                        };

                        main (given_size, me);
                    } 
                    where

                        (xc::make_widget_cable ())
                            ->
                            { kidplug => my_kidplug,
                              momplug => my_momplug
                            };

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

                        router  = mr::make_xevent_mail_router (kidplug, my_momplug, []);

                        size_preference'
                            =
                            size_preference
                                (fn CHILD_WIDGET { widget, ... }
                                    =
                                    wg::size_preference_of  widget
                                );

                        fun make_real' window_size
                            =
                            {   box = xg::box::make (xg::point::zero, window_size);

                                fn widget
                                    =
                                    {   cwin = wg::make_child_window (window, box, wg::args_of widget); 

                                        (xc::make_widget_cable ())
                                            ->
                                            { kidplug => ckidplug,
                                              momplug => cmomplug as xc::MOMPLUG { from_kid', ... }
                                            };

                                        mr::add_child router (cwin, cmomplug);

                                        xc::configure_window  cwin  [xc::c::STACK_MODE  xc::BELOW];

                                        wg::realize_fn widget { kidplug=>ckidplug, window=>cwin, window_size };

                                        xc::show_window  cwin;

                                        CHILD_WIDGET {
                                          widget,
                                          window => cwin,
                                          to_mom => from_kid'
                                        };
                                    };
                              };

                        fun zombie me
                            =
                            loop()
                            where

                                childco = make_coevt me;

                                fun do_plea (SHOWING     rslot) =>  put_in_mailslot (rslot, top_index   me);
                                    do_plea (CHILD_COUNT rslot) =>  put_in_mailslot (rslot, child_count me);
                                    do_plea SIZE_PREFERENCE     =>  put_in_mailslot (size_slot, size_preference' me);
                                    do_plea _                   =>  ();
                                end;

                                fun loop ()
                                    =
                                    for (;;) {
                                        do_one_mailop [
                                            plea'       ==>  do_plea,
                                            from_other' ==>  (fn _ = ()),
                                            childco     ==>  (fn _ = ())
                                        ];
                                    };
                            end;

                        # FIX child pleads for own death   XXX BUGGO FIXME
                        #
                        fun handle_co (me, i, xc::REQ_RESIZE)
                                =>
                                case (top_index me)

                                    THE j =>  if (i == j)  block_until_mailop_fires (to_mom  xc::REQ_RESIZE);  fi;
                                    NULL  =>  ();
                                esac;

                            handle_co (_, _, xc::REQ_DESTRUCTION)
                                =>
                                ();
                        end;


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

                                    {   window = top_window  me;

                                        xc::resize_window  window  size;
                                    }
                                    except
                                        _ = ();

                                    main (size, me);
                                };

                            do_mom (_,  xc::ETC_CHILD_DEATH w) => mr::del_child router w;
                            do_mom (me, xc::ETC_OWN_DEATH)     => zombie me;
                            do_mom _ => ();
                        end 

                        also
                        fun main (given_size, me)
                            =
                            loop ()
                            where
                                childco = make_coevt me;

                                fun do_plea (SHOWING     reply_slot) =>  put_in_mailslot (reply_slot, top_index   me);
                                    do_plea (CHILD_COUNT reply_slot) =>  put_in_mailslot (reply_slot, child_count me);
                                    do_plea SIZE_PREFERENCE          =>  put_in_mailslot ( size_slot,     size_preference' me);

                                    do_plea (SHOW i)
                                        =>
                                        {   my (me', CHILD_WIDGET { window, widget, ... } )
                                                =
                                                make_vis (me, i);

                                            xc::configure_window window [xc::c::STACK_MODE xc::ABOVE, xc::c::SIZE given_size];

                                            if (not (wg::okay_size (widget, given_size)))
                                                #
                                                block_until_mailop_fires (to_mom  xc::REQ_RESIZE);
                                            fi;

                                            put_in_mailslot (reply_slot, OKAY);

                                            main (given_size, me');
                                        }
                                        except  e = put_in_mailslot (reply_slot, ERROR e);


                                    do_plea (DELETE indices)
                                        =>
                                        {   my (me', dlist)
                                                =
                                                delete_w (me, indices);

                                            my CHILD_WIDGET { window, ... }
                                                =
                                                top_widget me;

                                            put_in_mailslot (reply_slot, OKAY);

                                            {   my CHILD_WIDGET { window=>window', widget, ... }
                                                    =
                                                    top_widget me'; 

                                                if (not (xc::same_window (window, window')))

                                                    xc::configure_window window' [xc::c::STACK_MODE xc::ABOVE, xc::c::SIZE given_size];

                                                    if (not (wg::okay_size (widget, given_size)))
                                                        #
                                                        block_until_mailop_fires (to_mom  xc::REQ_RESIZE);
                                                    fi;
                                                fi;
                                            }
                                            except _ = block_until_mailop_fires (to_mom  xc::REQ_RESIZE);

                                            apply destroy dlist;

                                            main (given_size, me');
                                       }
                                       except  e = put_in_mailslot (reply_slot, ERROR e);


                                    do_plea (INSERT (index, wl))
                                        =>
                                        if (is_valid (me, index)) 
                                            #
                                            case (top_index me)   
                                                #
                                                NULL =>
                                                    {   size' =  wg::preferred_size  (head wl);

                                                        me'   = insert_w (me, index, map (make_real' size') wl);

                                                        put_in_mailslot (reply_slot, OKAY);
                                                        block_until_mailop_fires (to_mom  xc::REQ_RESIZE);
                                                        main (size', me');
                                                    };

                                               _ => {   me' = insert_w (me, index, map (make_real' given_size) wl);

                                                        put_in_mailslot (reply_slot, OKAY);
                                                        main (given_size, me');
                                                    }
                                                    except  e = put_in_mailslot (reply_slot, ERROR e);
                                            esac;
                                       else
                                            put_in_mailslot (reply_slot, ERROR BAD_INDEX);
                                       fi
                                       except  e = put_in_mailslot (reply_slot, ERROR e);

                                    do_plea _ => ();
                                end;

                                fun loop ()
                                    =
                                    for (;;) {
                                        do_one_mailop [
                                            plea'       ==>  do_plea,
                                            from_other' ==>  (fn mail = do_mom (me, xc::envelope_contents mail)),
                                            childco     ==>  (fn (child, cevt) = handle_co (me, child, cevt))
                                        ];
                                    };
                            end;

                      end;                      # fun realize

                size_preference'
                    =
                    size_preference
                        (fn widget
                            =
                            wg::size_preference_of  widget
                        );


                fun init_loop  me
                    =
                    {   case (take_from_mailslot  plea_slot)
                            #                      
                            SHOWING     reply_slot =>  put_in_mailslot (reply_slot, top_index        me);
                            CHILD_COUNT reply_slot =>  put_in_mailslot (reply_slot, child_count      me);
                            SIZE_PREFERENCE        =>  put_in_mailslot ( size_slot, size_preference' me);

                            DO_REALIZE arg
                                =>
                                realize arg me;

                            SHOW i
                                =>
                                {   my (me', _) = make_vis (me, i);

                                    put_in_mailslot (reply_slot, OKAY);

                                    init_loop me';
                                }
                                except  e = put_in_mailslot (reply_slot, ERROR e);

                            INSERT (index, wl)
                                =>
                                {   me' = insert_w (me, index, wl);

                                    put_in_mailslot (reply_slot, OKAY);

                                    init_loop me';
                                }
                                except  e = put_in_mailslot (reply_slot, ERROR e);

                            DELETE indices
                                =>
                                {   me' = #1 (delete_w (me, indices));

                                    put_in_mailslot (reply_slot, OKAY);
                                    init_loop me';
                                }
                                except  e = put_in_mailslot (reply_slot, ERROR e);
                        esac;

                        init_loop me;
                    };

                  case widgets
                      #                
                      []    =>  make_thread "choice_of_widgets init 1" .{ init_loop EMPTY; };
                      w ! _ =>  make_thread "choice_of_widgets init 2" .{ init_loop (CHOICE { top=>0, widget=>w, wlist=>widgets } ); };
                  esac;

                  CHOICE_OF_WIDGETS
                    {
                      reply_slot,
                      plea_slot,
                      # 
                      widget
                          =>
                          wg::make_widget {
                              root_window,
                              args                     =>  fn ()  = { background => NULL },
                              size_preference_thunk_of =>  fn ()  = { put_in_mailslot (plea_slot, SIZE_PREFERENCE);  take_from_mailslot size_slot;},
                              realize                  =>  fn arg =   put_in_mailslot (plea_slot, DO_REALIZE arg)
                          }
                  };
            };


        fun choice_of_widgets (root_window, view, _) widgets
            =
            make_choice_of_widgets  root_window  widgets;


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


        fun showing (CHOICE_OF_WIDGETS { plea_slot, ... } )
            =
            {   reply_slot = make_mailslot ();

                put_in_mailslot (plea_slot, SHOWING reply_slot);

                case (take_from_mailslot  reply_slot)   
                    #
                    THE i => i;
                    NULL  => raise exception NO_WIDGETS;
                esac;
            };


        fun child_count (CHOICE_OF_WIDGETS { plea_slot, ... } )
            =
            {   reply_slot = make_mailslot ();

                put_in_mailslot (plea_slot, CHILD_COUNT reply_slot);
                take_from_mailslot reply_slot;
            };


        stipulate

            fun command wrapfn (CHOICE_OF_WIDGETS { plea_slot, reply_slot, ... } )
                =
                fn arg =    {   put_in_mailslot  (plea_slot,  wrapfn arg);
                                #
                                case (take_from_mailslot  reply_slot)
                                    #
                                    OKAY    =>  ();
                                    ERROR e =>  raise exception e;
                                esac;
                            };
        herein

            show = command SHOW;

            insert' = command INSERT;

            fun insert choice_of_widgets (i,[]) => ();
                insert choice_of_widgets arg    => insert' choice_of_widgets arg;
            end;

            fun append choice_of_widgets (i, bl)
                =
                insert choice_of_widgets (i+1, bl);

            delete' = command DELETE;

            fun delete choice_of_widgets []  =>  ();
                delete choice_of_widgets arg =>  delete' choice_of_widgets arg;
            end;

        end;
    };                  # package choice_of_widgets 

end;


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext