PreviousUpNext

15.4.1388  src/lib/x-kit/widget/leaf/canvas.pkg

## canvas.pkg

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




# Simple canvas widget, serving as a template for
# an application-dependent widget.
#
# NOTE: this probably needs rewriting.  It would be nice to avoid the extra
# threads on the input streams, and the macroExpand function should be called
# directly.         XXX BUGGO FIXME



###            "There is no reason for any individual
###             to have a computer in his home."
###
###                        -- Ken Olson,
###                           CEO of Digital Equipment Corporation

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 bg =  background;                   # background            is from   src/lib/x-kit/widget/wrapper/background.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
herein

    package   canvas
    : (weak)  Canvas                            # Canvas                is from   src/lib/x-kit/widget/leaf/canvas.api
    {
        Plea_Mail
          #     
          = GET_SIZE  Oneshot_Maildrop( xg::Size )
          #
          | DO_REALIZE
              (
                { kidplug:     xc::Kidplug,
                  window:      xc::Window,
                  window_size: xg::Size
                },

                Oneshot_Maildrop( Void )
              )
          ;

        Canvas
            =
            CANVAS
              { widget:         wg::Widget,
                plea_slot:   Mailslot( Plea_Mail ),
                window_1shot:   Oneshot_Maildrop( xc::Window )
              };

        attributes
            =
            [ (wa::background,     wa::COLOR,    wa::NO_VAL) ];

        fun make_canvas root_window constraints
            =
            {   plea_slot  =  make_mailslot ();
                new_size_slot =  make_mailslot ();

                window_1shot  =  make_oneshot_maildrop ();

                init_size
                    =
                    xg::SIZE
                      { wide => wg::preferred_length  constraints.col_preference,
                        high => wg::preferred_length  constraints.row_preference
                      };

                my  { kidplug => canvas_kidplug,
                      momplug => xc::MOMPLUG { mouse_sink    => om,
                                              keyboard_sink => ok,
                                              other_sink    => oci,
                                              from_kid'     => oco
                                            }
                    }
                    =
                    xc::make_widget_cable ();

                # Realize (make visible) the canvas widget: 
                #
                fun realize { kidplug=>xc::KIDPLUG { from_mouse', from_keyboard', from_other', to_mom }, 
                              window,
                              window_size as xg::SIZE { wide, high }
                            }
                    =
                    {   fun ci_imp_loop ()
                            =
                            for (;;) {
                                #
                                envelope
                                    =
                                    block_until_mailop_fires  from_other';

                                case (xc::envelope_contents  envelope)
                                    #
                                    xc::ETC_RESIZE (xg::BOX { wide, high, ... } )
                                        =>
                                        {   new_size = xg::SIZE { wide, high };

                                            put_in_mailslot  (new_size_slot,  new_size);

                                            block_until_mailop_fires (oci envelope);
                                        };

                                    _   =>  block_until_mailop_fires (oci envelope);
                                esac;
                            };

                        fun make_pipe (in_slot, out_slot)
                            =
                            {   fun loop ()
                                    =
                                    loop (block_until_mailop_fires (out_slot (block_until_mailop_fires in_slot)));

                                xlogger::make_thread  "canvass::make_pipe"  loop;
                            };

                        make_pipe (from_mouse',    om);
                        make_pipe (from_keyboard', ok);
                        make_pipe (oco, to_mom);

                        put_in_oneshot (window_1shot, window);

                        make_thread  "canvas"  ci_imp_loop;
                    };                          # fun realize

                # The thread that manages
                # the window's size state:
                #
                fun size_thread ()
                    =
                    init_loop ()
                    where
                        plea'     =  take_from_mailslot'  plea_slot;
                        new_size' =  take_from_mailslot'  new_size_slot;

                        fun loop size
                            =
                            {   fun do_plea (DO_REALIZE _)         =>  size;
                                    do_plea (GET_SIZE reply_1shot) =>  {   put_in_oneshot (reply_1shot, size);   size;   };
                                end;

                                loop (
                                    do_one_mailop [
                                        plea'  ==>  do_plea,
                                        new_size'
                                    ]
                                );
                            };

                        fun init_loop ()
                            =
                            case (take_from_mailslot  plea_slot)
                                #
                                GET_SIZE reply_1shot
                                    =>
                                    {   put_in_oneshot (reply_1shot, init_size);
                                        #
                                        init_loop ();
                                    };

                                DO_REALIZE (arg, reply_1shot)
                                    =>
                                    {   realize arg;
                                        #
                                        put_in_oneshot (reply_1shot, ());

                                        loop  arg.window_size;
                                    };
                            esac;
                    end;

                fun realize arg
                    =
                    {   reply_1shot =  make_oneshot_maildrop ();
                        #
                        put_in_mailslot  (plea_slot,  DO_REALIZE (arg, reply_1shot));

                        take_from_oneshot  reply_1shot;
                    };

                canvas
                    =
                    CANVAS
                      {
                        plea_slot,
                        window_1shot,

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

                  xlogger::make_thread  "canvass::size_thread"  size_thread;

                  (canvas, init_size, canvas_kidplug);
              };


        fun canvas (root_window, view, args) size_preferences
            =
            {   my (canvas as CANVAS { widget, plea_slot, window_1shot }, size, kidplug)
                    =
                    make_canvas root_window size_preferences;

                canvas' = CANVAS {
                        widget => bg::background (root_window, view, args) widget,
                        plea_slot,
                        window_1shot
                      };

                  (canvas', size, kidplug);
              };


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


        fun size_of (CANVAS { plea_slot, ... } )
            =
            {   reply_1shot =  make_oneshot_maildrop ();
                #
                put_in_mailslot (plea_slot, GET_SIZE reply_1shot);

                take_from_oneshot  reply_1shot;
            };


        fun drawable_of (CANVAS { window_1shot, ... } )
            =
            xc::drawable_of_window  (take_from_oneshot  window_1shot);


        # Set the background color of a canvas:
        #
        fun set_background_color (CANVAS { window_1shot, ... } ) color
            =
            xc::set_background_color  (take_from_oneshot  window_1shot)  color;


        # Set the cursor of a canvas:
        #
        fun set_cursor (CANVAS { window_1shot, ... } ) cursor
            =
            xc::set_cursor  (take_from_oneshot  window_1shot)  cursor;

    };                                                  # package canvas 

end;


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext