## 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 macro_expand 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 package threadkit; # threadkit is from src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.pkg #
package g2d= geometry2d; # geometry2d is from src/lib/std/2d/geometry2d.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/old/wrapper/background.pkg package wg = widget; # widget is from src/lib/x-kit/widget/old/basic/widget.pkg package wa = widget_attribute_old; # widget_attribute_old is from src/lib/x-kit/widget/old/lib/widget-attribute-old.pkgherein
package canvas
: (weak) Canvas # Canvas is from src/lib/x-kit/widget/old/leaf/canvas.api {
Plea_Mail
#
= GET_SIZE Oneshot_Maildrop( g2d::Size )
#
| DO_REALIZE
(
{ kidplug: xc::Kidplug,
window: xc::Window,
window_size: g2d::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
=
{ wide => wg::preferred_length constraints.col_preference,
high => wg::preferred_length constraints.row_preference
};
(xc::make_widget_cable ())
->
{ kidplug => canvas_kidplug,
momplug => xc::MOMPLUG { mouse_sink => om,
keyboard_sink => ok,
other_sink => oci,
from_kid' => oco
}
};
# Realize (make visible) the canvas widget:
#
fun realize { kidplug=>xc::KIDPLUG { from_mouse', from_keyboard', from_other', to_mom },
window,
window_size as { wide, high }
}
=
{ fun ci_imp_loop ()
=
for (;;) {
#
envelope
=
block_until_mailop_fires from_other';
case (xc::get_contents_of_envelope envelope)
#
xc::ETC_RESIZE ({ wide, high, ... }: g2d::Box)
=>
{ new_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_widget arg
=
{ reply_1shot = make_oneshot_maildrop ();
#
put_in_mailslot (plea_slot, DO_REALIZE (arg, reply_1shot));
get_from_oneshot reply_1shot;
};
canvas = CANVAS { plea_slot,
window_1shot,
#
widget => wg::make_widget
{
root_window,
args => \\ () = { background => NULL },
size_preference_thunk_of => \\ () = constraints,
realize_widget
}
};
xlogger::make_thread "canvass::size_thread" size_thread;
(canvas, init_size, canvas_kidplug);
};
fun canvas (root_window, view, args) size_preferences
=
{ (make_canvas root_window size_preferences)
->
(canvas as CANVAS { widget, plea_slot, window_1shot }, size, kidplug);
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);
get_from_oneshot reply_1shot;
};
fun drawable_of (CANVAS { window_1shot, ... } )
=
xc::drawable_of_window (get_from_oneshot window_1shot);
# Set the background color of a canvas:
#
fun set_background_color (CANVAS { window_1shot, ... } ) color
=
xc::set_background_color (get_from_oneshot window_1shot) color;
# Set the cursor of a canvas:
#
fun set_cursor (CANVAS { window_1shot, ... } ) cursor
=
xc::set_cursor (get_from_oneshot window_1shot) cursor;
}; # package canvas
end;