## triangle-app.pkg
#
# This app displays a drawing window and a RESET button.
# It puts a triangle wherever the user clicks in the drawing window;
# It clears the drawing window when the RESET button is clicked.
#
# One way to run this app from the base-directory commandline is:
#
# linux% my
# eval: make "src/lib/x-kit/tut/triangle/triangle-app.lib";
# eval: triangle_app::do_it "";
# Compiled by:
# src/lib/x-kit/tut/triangle/triangle-app.libstipulate
include package makelib::scripting_globals;
include package threadkit; # threadkit is from src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.pkg package cmd = commandline; # commandline is from src/lib/std/commandline.pkg #
package fil = file__premicrothread; # file__premicrothread is from src/lib/std/src/posix/file--premicrothread.pkg package mps = microthread_preemptive_scheduler; # microthread_preemptive_scheduler is from src/lib/src/lib/thread-kit/src/core-thread-kit/microthread-preemptive-scheduler.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 xtr = xlogger; # xlogger is from src/lib/x-kit/xclient/src/stuff/xlogger.pkg #
package che = cartouche; # cartouche is from src/lib/x-kit/draw/cartouche.pkg #
package ib = icon_bitmap; # icon_bitmap is from src/lib/x-kit/tut/triangle/icon-bitmap.pkg #
tracefile = "triangle-app.trace.log";
tracing = logger::make_logtree_leaf { parent => xlogger::xkit_logging, name => "triangle_app::tracing", default => FALSE };
trace = xtr::log_if tracing 0; # Conditionally write strings to tracing.log or whatever.
#
# To debug via tracelogging, annotate the code with lines like
#
# trace {. sprintf "foo/top: bar d=%d" bar; };
#
# and then set write_tracelog = TRUE; below.
herein
package triangle_app
: Triangle_App # Triangle_App is from src/lib/x-kit/tut/triangle/triangle-app.api {
write_tracelog = FALSE;
min_wide = 300;
min_high = 300;
min_sz = { wide => min_wide,
high => min_high
};
button_wide = 100;
button_high = 30;
button_corner_radius = 8;
done_first_drawing_window_redraw # This is a hack allowing selfcheck code
= # to wait until first drawing window redraw
make_oneshot_maildrop () # has happened, so as to start up in a
: # known state.
Oneshot_Maildrop(Void); #
######## Begin mutable selfcheck globals ########
#
run_selfcheck = REF FALSE;
add_triangle_watcher_slot # This is a hack to support selfcheck;
= # if it is set non-NULL, drawing_window_loop
REF NULL # will 'give' the displayed triangle list
: # to this slot each time it changes:
Ref (Null_Or( Mailslot( List( g2d::Point )))); #
drawing_window_''do_reset''_watcher_slot # This is another hack to support selfcheck;
= # if it is set non-NULL, drawing_window_loop
REF NULL # will 'give' () to the slot each time it
: # does a reset:
Ref (Null_Or( Mailslot(Void))); #
selfcheck_tests_passed = REF 0;
selfcheck_tests_failed = REF 0;
#
######## End mutable selfcheck globals ########
app_task = REF (NULL: Null_Or(Apptask));
fun sprint_thread thread # A little debug-support hack.
=
{ (get_thread's_name thread) -> thread_name;
(get_thread's_id thread) -> thread_id;
(get_thread's_task thread) -> task;
(get_task's_id task) -> task_id;
(get_task's_name task) -> task_name;
sprintf "thread %d(%s) in task \t%d(%s)" thread_id thread_name task_id task_name;
};
fun print_thread thread # A little debug-support hack.
=
printf "Created %s\n" (sprint_thread thread);
fun reset_global_mutable_state () # Reset above state variables to load-time values.
= # This will be needed if (say) we get run multiple times interactively without being reloaded.
{ run_selfcheck := FALSE;
#
add_triangle_watcher_slot := NULL;
drawing_window_''do_reset''_watcher_slot := NULL;
#
app_task := (NULL: Null_Or(Apptask));
#
selfcheck_tests_passed := 0;
selfcheck_tests_failed := 0;
};
fun test_passed () = selfcheck_tests_passed := *selfcheck_tests_passed + 1;
fun test_failed () = selfcheck_tests_failed := *selfcheck_tests_failed + 1;
#
fun assert bool = if bool test_passed ();
else test_failed ();
fi;
#
fun test_stats ()
=
{ passed => *selfcheck_tests_passed,
failed => *selfcheck_tests_failed
};
fun kill_triangle_app ()
=
{
kill_task { success => TRUE, task => (the *app_task) };
};
fun wait_for_app_task_done ()
=
{
task = the *app_task;
#
task_finished' = task_done__mailop task;
block_until_mailop_fires task_finished';
success = get_task's_state task == state::SUCCESS;
assert (success);
};
# Put reset button window at bottom left of hostwindow:
#
fun reset_button_window_site (hostwindow_size as { wide => hostwindow_wide, high => hostwindow_high })
=
{ # We put the reset and exit buttons ten pixels
# above the bottom of the hostwindow, side by side,
# splitting the remaining horizontal space evenly
# around them (right/center/left):
#
remaining_horizontal_space = hostwindow_wide - 2*button_wide;
gap = remaining_horizontal_space / 3;
{
upperleft => { col => gap,
row => (hostwindow_high - (button_high+10))
},
size => { wide => button_wide,
high => button_high
},
border_thickness => 0
}
: g2d::Window_Site;
};
# Put exit button window at bottom right of hostwindow:
#
fun exit_button_window_site (hostwindow_size as { wide => hostwindow_wide, high => hostwindow_high })
=
{ # We put the reset and exit buttons ten pixels
# above the bottom of the hostwindow, side by side,
# splitting the remaining horizontal space evenly
# around them (right/center/left):
#
remaining_horizontal_space = hostwindow_wide - 2*button_wide;
gap = remaining_horizontal_space / 3;
{
upperleft => { col => 2*gap + button_wide,
row => (hostwindow_high - (button_high+10))
},
size => { wide => button_wide,
high => button_high
},
border_thickness => 0
}
: g2d::Window_Site;
};
# Let drawing window fill the rest of hostwindow:
#
fun drawing_window_site (hostwindow_size as { wide: Int, high: Int })
=
{
border_thickness => 1,
upperleft => { col => 5, row => 5 },
#
size => { wide => wide - 10,
high => high - (button_high+25)
}
}
: g2d::Window_Site;
# Thread to exercise the app by simulating user
# mouseclicks and verifying their effects:
#
fun make_selfcheck_thread
{ xsession: xc::Xsession,
hostwindow: xc::Window,
drawing_window: xc::Window,
exit_button_window: xc::Window,
reset_button_window: xc::Window
}
=
{ fun get_''seen_first_expose''_oneshot
window
=
case (xc::get_''seen_first_expose''_oneshot_of window)
#
THE oneshot => oneshot;
NULL => get_''seen_first_expose''_oneshot window; # Cannot actually happen.
esac;
fun selfcheck ()
=
{
check_periodic_asynchronous_operation ();
check_get_set_of_mouse_pointer ();
wait_until_gui_is_stable { drawing_window };
(check_drawing_window_triangle_draw { }) -> { antedraw_midwindow_image };
check_reset_button_operation { antedraw_midwindow_image };
check_exit_button_operation { };
}
where
# Try sleep/work loop. This actually wasn't
# working at one point due to blocking on the
# X server socket, so it is worth checking:
#
fun check_periodic_asynchronous_operation ()
=
{ # Set up a counter which will be
# shared between our two threads:
#
counter = REF 0;
# Spin off a thread which increments
# the counter at 50Hz or so. (The
# thread scheduler is normally run
# off a 50Hz SIGALRM signal, so we
# cannot count on shorter sleeps.)
#
xtr::make_thread "count slowly" count_slowly
where
fun count_slowly ()
=
for (i = 0; i < 50; ++i) {
# We currently run SIGALRM at 50HZ, so
# we cannot usefully sleep less than 20ms
# at a go:
#
sleep_for 0.02;
counter := *counter + 1;
};
end;
# Sleep a fifth of a second. This is
# long enough to get significant results
# but short enough not to slow down our
# "make check" runs noticably:
#
sleep_for 0.2;
# In a perfect world the counter would be at 10 now;
# in practice we will settle for anything between 5 and 15:
#
count = *counter;
#
success = (count >= 5 and count <= 15);
if !success printf "\nAssert failing -- check_periodic_asynchronous_operation\n"; fi;
assert (success);
};
# Originally I thought we'd have to move the
# mouse pointer around to generate simulated
# mouseclicks on buttons. Then I discovered
# that the X protocol SendEvent request allows
# arbitrary events to be simulated for test
# purposes without moving the real mouse pointer,
# so I didn't use it. But this is still a
# potentially useful facility, so we might as
# well unit-test it to defend it against bitrot:
#
fun check_get_set_of_mouse_pointer ()
=
{ # Note current mouse position, then move it to the origin:
#
(xc::get_mouse_location xsession) -> { row => initial_row, col => initial_col } ;
xc::set_mouse_location xsession ({ row => 0, col => 0 });
(xc::get_mouse_location xsession) -> { row, col } ;
#
success = (row == 0 and col == 0);
if !success printf "\nAssert failing -- check_get_set_of_mouse_pointer\n"; fi;
assert (success);
# Return mouse to its original location,
# with luck before the user notices:
#
xc::set_mouse_location xsession ({ row => initial_row, col => initial_col });
(xc::get_mouse_location xsession) -> { row, col };
#
success = (row == initial_row
and col == initial_col);
if !success printf "\nAssert failing -- check_get_set_of_mouse_pointer II\n"; fi;
assert (success);
};
# Wait for drawing window to
# get its first EXPOSE x event:
#
fun wait_for_first_drawing_window_expose ()
=
{
# Normally we would use the
#
# seen_first_redraw_oneshot_of
#
# from
#
# src/lib/x-kit/widget/old/basic/widget.api #
# but the logic here doesn't use the widget
# support (I'm guessing this app predates
# the widget layer) so we have to use the
# following call instead:
#
#
seen_first_drawing_window_expose_oneshot
=
get_''seen_first_expose''_oneshot
#
drawing_window;
get_from_oneshot seen_first_drawing_window_expose_oneshot;
};
# Figure midpoint of window and also
# a small box centered on the midpoint:
#
fun midwindow window
=
{ # Get size of drawing window:
#
(xc::get_window_site window)
->
{ row, col, high, wide };
# Define midpoint of drawing window,
# and a 9x9 box enclosing it:
#
stipulate
row = high / 2;
col = wide / 2;
herein
midpoint = { row, col };
midbox = { row => row - 4, col => col - 4, high => 9, wide => 9 };
end;
(midpoint, midbox);
};
# We do not want to start running the
# selfcheck code until the application
# is ready to respond:
#
fun wait_until_gui_is_stable { drawing_window }
=
{ # First order of business is to wait
# until things are up and running.
#
# This may actually not be needed now
# that we wait on
# done_first_drawing_window_redraw
# in below logic, but exercising the
# facility is useful anyhow:
#
wait_for_first_drawing_window_expose ();
# Wait until first redraw is done:
#
get_from_oneshot done_first_drawing_window_redraw;
};
fun check_drawing_window_triangle_draw { }
=
{
(midwindow drawing_window) -> ( drawing_window_midpoint, drawing_window_midbox);
(midwindow exit_button_window) -> ( exit_button_window_midpoint, _ );
(midwindow reset_button_window) -> (reset_button_window_midpoint, _ );
# Fetch from X server the mid-window pixels
# over which we are about to draw a triangle.
# These should all be all background color (black)
# at the moment:
#
# Introduced the following three sleep_for calls because checks
# 7 and 8 were failing after switchover to redirected socket calls.
# I suspect some race condition. The problem comes and goes;
# at the moment I'm not sure if these waits 'fixed' the problem or if
# it is just in spontaneous remission. If the problem *is* 'fixed',
# maybe only the first sleep is actually needed? The sleep time is
# also a pure-guesswork first try. -- 2012-12-24 CrT
sleep_for 0.2;
antedraw_midwindow_image = xc::make_clientside_pixmap_from_window (drawing_window_midbox, drawing_window);
# Do it again, verify that they compare equal:
#
{
# sleep_for 0.2;
antedraw_midwindow_image2 = xc::make_clientside_pixmap_from_window (drawing_window_midbox, drawing_window);
#
# sleep_for 0.2;
success = xc::same_cs_pixmap (antedraw_midwindow_image, antedraw_midwindow_image2);
if !success printf "\nAssert failing -- check_drawing_window_triangle_draw\n"; fi;
assert (success);
};
# Set up a hook to detect when
#
# add_triangle ()
#
# runs. To avoid race conditions, we must
# do this BEFORE sending the below simulated
# mouseclicks. (I forgot this at first, and
# in fact got bitten.)
#
triangle_list_slot = make_mailslot ();
#
add_triangle_watcher_slot := THE triangle_list_slot;
# Simulate a mouseclick in center of drawing window:
#
xc::send_fake_mousebutton_press_xevent
{ window => drawing_window,
button => xc::MOUSEBUTTON 1,
point => drawing_window_midpoint
};
#
xc::send_fake_mousebutton_release_xevent
{ window => drawing_window,
button => xc::MOUSEBUTTON 1,
point => drawing_window_midpoint
};
#
do_one_mailop [
take_from_mailslot' triangle_list_slot ==> check_triangle_list1,
timeout' ==> do_timeout1
]
where
timeout' = timeout_in' 5.0;
fun check_triangle_list1 [ point ]
=>
{
success = g2d::point::eq (point, drawing_window_midpoint);
if !success printf "\nAssert failing -- check_triangle_list1\n"; fi;
assert (success);
add_triangle_watcher_slot := NULL;
};
check_triangle_list1 []
=>
{
printf "\ncalling test_failed -- check_triangle_list1 []\n";
test_failed ();
add_triangle_watcher_slot := NULL;
};
check_triangle_list1 triangles
=>
{
printf "\ncalling test_failed -- check_triangle_list1 triangles\n";
test_failed ();
add_triangle_watcher_slot := NULL;
};
end;
fun do_timeout1 ()
=
{ test_failed ();
#
add_triangle_watcher_slot := NULL;
};
end;
# Fetch from X server the mid-window pixels
# over which we should have drawn a triangle.
#
# Verify that they differ from our original
# all-black image of the same area:
#
{ postdraw_midwindow_image = xc::make_clientside_pixmap_from_window (drawing_window_midbox, drawing_window);
#
# 2010-08-31 CrT: This was working on maw (4-core opteron running X over net);
# it is currently failing on al (new 6-core Phenom II running X direct to screen);
# This is probably a race condition; I'm not motivated to track it down just
# now, so I'm just commenting out the offending test: XXX BUGGO FIXME
# assert (not (xc::same_cs_pixmap (antedraw_midwindow_image, postdraw_midwindow_image)));
};
{ antedraw_midwindow_image };
};
fun check_reset_button_operation { antedraw_midwindow_image }
=
{
(midwindow drawing_window) -> ( drawing_window_midpoint, drawing_window_midbox);
(midwindow exit_button_window) -> ( exit_button_window_midpoint, _ );
(midwindow reset_button_window) -> (reset_button_window_midpoint, _ );
# Set up a hook to detect when drawing_window_loop
#
# do_reset ()
#
# runs. To avoid race conditions, we must
# do this BEFORE sending the below simulated
# mouseclicks. (I forgot this at first, and
# in fact got bitten.)
#
drawing_window_''do_reset''_slot = make_mailslot ();
#
drawing_window_''do_reset''_watcher_slot := THE drawing_window_''do_reset''_slot;
# Simulate a mouseclick in center of reset button:
#
xc::send_fake_mousebutton_press_xevent
{ window => reset_button_window,
button => xc::MOUSEBUTTON 1,
point => reset_button_window_midpoint
};
#
xc::send_fake_mousebutton_release_xevent
{ window => reset_button_window,
button => xc::MOUSEBUTTON 1,
point => reset_button_window_midpoint
};
#
do_one_mailop [
take_from_mailslot' drawing_window_''do_reset''_slot ==> check_reset,
timeout' ==> do_timeout2
]
where
timeout' = timeout_in' 5.0;
#
fun check_reset ()
=
{ drawing_window_''do_reset''_watcher_slot := NULL;
#
test_passed ();
};
fun do_timeout2 ()
=
{ drawing_window_''do_reset''_watcher_slot := NULL;
#
test_failed ();
};
end;
# Fetch from X server the mid-window pixels
# over which we drew the triangle.
#
# Verify that they match our original
# all-black image of the same area:
#
{ postreset_midwindow_image = xc::make_clientside_pixmap_from_window (drawing_window_midbox, drawing_window);
#
success = xc::same_cs_pixmap (antedraw_midwindow_image, postreset_midwindow_image);
if !success printf "\nAssert failing -- check_reset_button_operation\n"; fi;
assert (success);
};
};
fun check_exit_button_operation { }
=
{
(midwindow exit_button_window)
->
(exit_button_window_midpoint, _);
# Simulate a mouseclick in center of exit button:
#
xc::send_fake_mousebutton_press_xevent
{ window => exit_button_window,
button => xc::MOUSEBUTTON 1,
point => exit_button_window_midpoint
};
#
xc::send_fake_mousebutton_release_xevent
{ window => exit_button_window,
button => xc::MOUSEBUTTON 1,
point => exit_button_window_midpoint
};
};
end; # fun selfcheck
xtr::make_thread "tri-app selfcheck" selfcheck;
};
fun make_hostwindow xdisplay xauthentication
=
( xsession,
screen,
window,
kidplug
)
where
xsession = xc::open_xsession (xdisplay, xauthentication);
screen = xc::default_screen_of xsession;
window_size = { wide => 450, high => 400 };
my (window, kidplug, delete_slot) # 2009-12-10 CrT: Had to add 'delete_slot' so it would compile.
=
xc::make_simple_top_window screen
{
site => { upperleft => { col=>0, row=>0 },
size => window_size, border_thickness=>1
}
: g2d::Window_Site,
#
border_color => xc::black,
background_color => xc::rgb8_white
};
icon_ro_pixmap # serverside
=
xc::make_readonly_pixmap_from_clientside_pixmap
screen
ib::icon_bitmap; # clientside
xc::set_window_manager_properties window
{
window_name => THE "Triangle",
icon_name => THE "triangle",
#
size_hints =>
[
xc::HINT_PPOSITION,
xc::HINT_PSIZE,
xc::HINT_PMIN_SIZE min_sz
],
#
nonsize_hints => [ xc::HINT_ICON_RO_PIXMAP icon_ro_pixmap ],
#
class_hints => THE { resource_name => "triangle",
resource_class => "Triangle"
},
#
commandline_arguments => cmd::get_commandline_arguments ()
};
xc::show_window window;
end;
# Divide the hostwindow into a drawing window
# over two button windows:
#
fun make_drawing_and_button_windows (screen, hostwindow, top_kidplug)
=
{ (xc::size_of_window hostwindow)
->
hostwindow_size;
drawing_window
=
xc::make_simple_subwindow hostwindow
{
site => drawing_window_site hostwindow_size,
#
border_color => THE xc::black,
background_color => THE xc::rgb8_color0
};
xc::note_''seen_first_expose''_oneshot
drawing_window
(make_oneshot_maildrop ());
reset_button_window
=
xc::make_simple_subwindow hostwindow
{
site => reset_button_window_site hostwindow_size,
#
border_color => NULL,
background_color => THE xc::rgb8_white
};
exit_button_window
=
xc::make_simple_subwindow hostwindow
{
site => exit_button_window_site hostwindow_size,
#
border_color => NULL,
background_color => THE xc::rgb8_white
};
xc::note_''seen_first_expose''_oneshot
reset_button_window
(make_oneshot_maildrop ());
xc::show_window drawing_window;
xc::show_window exit_button_window;
xc::show_window reset_button_window;
{ hostwindow,
top_kidplug,
drawing_window,
reset_button_window,
exit_button_window
};
};
fun make_reset_button_thread (reset_button_window, reset_button_kidplug)
=
{ xtr::make_thread "reset button" loop;
#
take_from_mailslot' reset_slot; # Return a mailop which may be used to detect clicks on the reset button.
}
where
# Define a function to re/draw the
# reset button as "RESET" inside a cartouche:
#
fun redraw ()
=
{
draw_cartouche
{
corner_radius => button_corner_radius,
#
box => { col => 0,
row => 0,
#
high => button_high - 1,
wide => button_wide - 1
}
};
draw_string (text_point, text);
}
where
drawable = xc::drawable_of_window reset_button_window;
pen = xc::make_pen
[
xc::p::FUNCTION xc::OP_COPY,
xc::p::FOREGROUND xc::rgb8_black
];
draw_cartouche
=
che::draw_cartouche drawable pen;
text = "RESET";
font = xc::find_else_open_font
#
(xc::xsession_of_window reset_button_window)
#
"9x15";
text_point
=
{ text_width = xc::text_width font text;
#
(xc::font_high font) -> { ascent, descent };
{ col => ( button_wide - text_width) / 2,
row => ((button_high - (ascent + descent)) / 2) + ascent
};
};
draw_string
=
xc::draw_transparent_string drawable pen font;
end;
# Define the main thread loop animating the button.
# We respond to ETC_REDRAW by redrawing our button;
# we respond to a click by resetting the draw thread:
#
(xc::ignore_keyboard reset_button_kidplug)
->
xc::KIDPLUG { from_mouse', from_other', ... };
from_mouse'' = from_mouse' ==> xc::get_contents_of_envelope;
from_other'' = from_other' ==> xc::get_contents_of_envelope;
reset_slot = make_mailslot ();
fun loop ()
=
{ fun do_mouse (xc::MOUSE_FIRST_DOWN _)
=>
put_in_mailslot (reset_slot, ());
do_mouse _
=>
();
end;
fun do_other (xc::ETC_REDRAW _) => redraw ();
do_other xc::ETC_OWN_DEATH => ();
do_other _ => ();
end;
for (;;) {
#
do_one_mailop [
from_mouse'' ==> do_mouse,
from_other'' ==> do_other
];
};
};
end; # fun make_reset_button_thread
fun make_exit_button_thread (exit_button_window, exit_button_kidplug)
=
{ xtr::make_thread "exit button" loop;
#
take_from_mailslot' exit_slot; # Return a mailop which can be used to detect clicks on the exit button.
}
where
# Define a function to re/draw the
# exit button as "EXIT" inside a cartouche:
#
fun redraw ()
=
{
draw_cartouche
{
corner_radius => button_corner_radius,
#
box => { col => 0,
row => 0,
#
high => button_high - 1,
wide => button_wide - 1
}
};
draw_string (text_point, text);
}
where
drawable = xc::drawable_of_window exit_button_window;
pen = xc::make_pen
[
xc::p::FUNCTION xc::OP_COPY,
xc::p::FOREGROUND xc::rgb8_black
];
draw_cartouche
=
che::draw_cartouche drawable pen;
text = "EXIT";
font = xc::find_else_open_font
#
(xc::xsession_of_window exit_button_window)
#
"9x15";
text_point
=
{ text_width = xc::text_width font text;
(xc::font_high font)
->
{ ascent, descent };
{
col => ( button_wide - text_width) / 2,
row => ((button_high - (ascent + descent)) / 2) + ascent
};
};
draw_string
=
xc::draw_transparent_string drawable pen font;
end;
# Define the main thread loop animating the button.
# We respond to ETC_REDRAW by redrawing our button;
# we respond to a click by exiting the program:
#
(xc::ignore_keyboard exit_button_kidplug)
->
xc::KIDPLUG { from_mouse', from_other', ... };
from_mouse'' = from_mouse' ==> xc::get_contents_of_envelope;
from_other'' = from_other' ==> xc::get_contents_of_envelope;
exit_slot = make_mailslot ();
fun loop ()
=
{ fun do_mouse (xc::MOUSE_FIRST_DOWN _)
=>
put_in_mailslot (exit_slot, ());
do_mouse _
=>
();
end;
fun do_other (xc::ETC_REDRAW _) => redraw ();
do_other xc::ETC_OWN_DEATH => ();
do_other _ => ();
end;
for (;;) {
#
do_one_mailop [
from_mouse'' ==> do_mouse,
from_other'' ==> do_other
];
};
};
end; # fun make_exit_button_thread
# Define drawing_window logic to put
# a triangle at each spot the user
# clicks on:
#
stipulate
done_first_redraw = REF FALSE;
herein
fun make_drawing_window_threads (xsession, drawing_window, exit', reset', draw_kidplug)
=
{ xtr::make_thread "drawing window mouse" mouse_loop;
xtr::make_thread "drawing window" {. drawing_window_loop []; };
();
}
where
my xc::KIDPLUG { from_mouse', from_other', ... }
=
xc::ignore_keyboard draw_kidplug;
mouse' = from_mouse' ==> xc::get_contents_of_envelope;
other' = from_other' ==> xc::get_contents_of_envelope;
add_triangle_slot = make_mailslot ();
fun mouse_loop ()
=
for (;;) {
#
case (block_until_mailop_fires mouse')
#
xc::MOUSE_FIRST_DOWN { window_point, ... }
=>
put_in_mailslot (add_triangle_slot, window_point);
#
_ => ();
esac;
};
add_triangle' = take_from_mailslot' add_triangle_slot;
drawable = xc::drawable_of_window drawing_window;
pen = xc::make_pen
[
xc::p::FUNCTION xc::OP_COPY,
xc::p::FOREGROUND xc::rgb8_green
];
draw = xc::fill_polygon drawable pen;
fun draw_triangle ({ col, row } )
=
draw
{
shape => xc::CONVEX_SHAPE,
#
verts => [ { col => col, row => row - 10 },
{ col => col - 8, row => row + 6 },
{ col => col + 8, row => row + 6 }
]
};
# "triangles" is the list of points at which we
# show triangles in the drawing window:
#
fun drawing_window_loop triangles
=
{ fun do_exit ()
=
{
xc::close_xsession xsession;
sleep_for 0.2; # I think close_xsession returns before everything has shut down. Need something cleaner here. XXX SUCKO FIXME.
kill_triangle_app ();
# shut_down_thread_scheduler winix__premicrothread::process::success; # Starting with 6.3, this is no longer the way to shut down an app. :-)
};
fun do_reset ()
=
{
xc::clear_drawable drawable;
case *drawing_window_''do_reset''_watcher_slot
#
THE slot => put_in_mailslot (slot, ());
NULL => ();
esac;
drawing_window_loop [];
};
fun do_other (xc::ETC_REDRAW _)
=>
{ xc::clear_drawable drawable;
#
apply draw_triangle triangles;
# Selfcheck code waits for us to do first redraw
# before starting tests. If this is our first
# redraw, give it the green light:
#
if (not *done_first_redraw)
#
done_first_redraw := TRUE;
put_in_oneshot (done_first_drawing_window_redraw, ());
fi;
drawing_window_loop triangles;
};
do_other xc::ETC_OWN_DEATH
=>
{
();
};
do_other _
=>
{
drawing_window_loop triangles;
};
end;
# In response to a mouse downclick at a point,
# add a triangle to our list and draw it:
#
fun add_triangle point
=
{ draw_triangle point;
case *add_triangle_watcher_slot
#
THE slot => put_in_mailslot (slot, (point ! triangles));
NULL => ();
esac;
drawing_window_loop (point ! triangles);
};
do_one_mailop [
#
exit' ==> do_exit,
reset' ==> do_reset,
other' ==> do_other,
add_triangle' ==> add_triangle
];
}; # fun drawing_window_loop
end; # fun make_drawing_window_threads
end; # stipulate
fun make_toplevel_threads
{
hostwindow,
top_kidplug => xc::KIDPLUG { from_keyboard', from_mouse', from_other', ... },
exit_button_window,
reset_button_window,
drawing_window
}
=
{ xtr::make_thread "triangle router" router;
#
{ exit_button_kidplug,
reset_button_kidplug,
draw_kidplug
};
}
where
(xc::make_widget_cable ()) -> { kidplug => exit_button_kidplug, momplug => exit_button_momplug };
(xc::make_widget_cable ()) -> { kidplug => reset_button_kidplug, momplug => reset_button_momplug };
(xc::make_widget_cable ()) -> { kidplug => draw_kidplug, momplug => draw_momplug };
(xc::make_widget_cable ()) -> { kidplug, momplug };
kidplug = xc::ignore_all kidplug;
fun find_cable envelope
=
case (xc::route_envelope envelope)
#
xc::TO_SELF _ # Envelope has reached its destination window/widget.
=>
momplug;
xc::TO_CHILD msg' # Envelope needs to be passed on down the widget hierarchy.
=>
if (xc::to_window (msg', drawing_window)) draw_momplug;
elif (xc::to_window (msg', exit_button_window)) exit_button_momplug;
elif (xc::to_window (msg', reset_button_window)) reset_button_momplug;
else raise exception DIE "find_cable";
fi;
esac;
fun do_keyboard envelope
=
{ (find_cable envelope)
->
xc::MOMPLUG { keyboard_sink, ... };
block_until_mailop_fires (keyboard_sink envelope);
};
fun do_mouse envelope
=
{ (find_cable envelope)
->
xc::MOMPLUG { mouse_sink, ... };
block_until_mailop_fires (mouse_sink envelope);
};
fun do_other envelope
=
{ (find_cable envelope)
->
xc::MOMPLUG { other_sink, ... };
block_until_mailop_fires (other_sink envelope);
};
fun router ()
=
for (;;) {
#
do_one_mailop [
#
from_keyboard' ==> do_keyboard,
from_mouse' ==> do_mouse,
from_other' ==> do_other
];
};
end; # fun make_toplevel_threads
fun run_triangle_app xdisplay xauthentication
=
{
(make_hostwindow xdisplay xauthentication)
->
( xsession,
screen,
hostwindow,
kidplug
);
(make_drawing_and_button_windows (screen, hostwindow, kidplug))
->
(x as { drawing_window, exit_button_window, reset_button_window, ... } );
(make_toplevel_threads x)
->
{ exit_button_kidplug, reset_button_kidplug, draw_kidplug };
make_drawing_window_threads
( xsession,
drawing_window,
make_exit_button_thread ( exit_button_window, exit_button_kidplug),
make_reset_button_thread (reset_button_window, reset_button_kidplug),
draw_kidplug
);
if *run_selfcheck
#
make_selfcheck_thread { xsession, hostwindow, drawing_window, exit_button_window, reset_button_window };
();
fi;
};
fun do_it' (flgs, display_name)
=
{
xtr::init flgs;
if write_tracelog
#
# Open tracelog file and select tracing level.
# We don't need to truncate any existing file
# because that is already done by the logic in
# src/lib/std/src/posix/winix-text-file-io-driver-for-posix--premicrothread.pkg #
include package logger; # logger is from src/lib/src/lib/thread-kit/src/lib/logger.pkg #
set_logger_to (fil::LOG_TO_FILE tracefile);
#
# enable fil::all_logging; # Gross overkill.
fi;
display_name' = case display_name
#
"" => NULL;
_ => THE display_name;
esac;
(xc::get_xdisplay_string_and_xauthentication display_name')
->
( xdisplay, # Typically from $DISPLAY environment variable.
xauthentication: Null_Or(xc::Xauthentication) # Typically from ~/.Xauthority
);
triangle_app_task
=
make_task "triangle app" [];
app_task := THE triangle_app_task;
xtr::make_thread' [ THREAD_NAME "triangle app",
THREAD_TASK triangle_app_task
]
{. run_triangle_app xdisplay xauthentication; }
();
sleep_for 0.3; # Give threads long enough to be created.
wait_for_app_task_done ();
winix__premicrothread::process::success;
};
fun do_it s
=
do_it' ([], s);
fun selfcheck ()
=
{
reset_global_mutable_state (); # Don't depend on load-time state initialization -- we might get run multiple times interactively, say.
run_selfcheck := TRUE;
do_it' ([], "");
test_stats (); # We return { passed, failed } to caller.
};
fun main (program, server ! _) => do_it server;
main _ => do_it "";
end;
}; # package main
end;