## bouncing-heads-app.pkg
#
# A simple bouncing-icons-in-a-window app which
# exercises our mailcaster facility. The icons
# mostly look like little heads. The heads are
# drawn using XOR and erased by redrawing them
# with XOR; this allows the icons to move through
# each other.
#
# User interaction:
#
# Dragging mouse-button 1 creates a moving head.
# Clicking mouse-button 2 deletes the clicked head, if any.
# Clicking mouse-button 3 brings up a reset/quit menu.
#
# One way to run this app from the base-directory commandline is:
#
# linux% my
# eval: make "src/lib/x-kit/tut/bouncing-heads/bouncing-heads-app.lib";
# eval: bounce_app::do_it ();
# Compiled by:
# src/lib/x-kit/tut/bouncing-heads/bouncing-heads-app.libstipulate
include package threadkit; # threadkit is from src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.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 cmd = commandline; # commandline is from src/lib/std/commandline.pkg #
package f8b = eight_byte_float; # eight_byte_float is from src/lib/std/eight-byte-float.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 bd = bounce_drawmaster; # bounce_drawmaster is from src/lib/x-kit/tut/bouncing-heads/bounce-drawmaster.pkg package bl = bouncing_head; # bouncing_head is from src/lib/x-kit/tut/bouncing-heads/bouncing-head.pkg package hd = head_pixmaps; # head_pixmaps is from src/lib/x-kit/tut/bouncing-heads/head-pixmaps.pkg #
tracefile = "bouncing-heads-app.trace.log";
tracing = logger::make_logtree_leaf { parent => xlogger::xkit_logging, name => "bouncing_heads_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 bouncing_heads_app {
write_tracelog = FALSE;
app_task = REF (NULL: Null_Or( Apptask ));
fun set_up_tracing ()
=
{ # 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.
};
stipulate
selfcheck_tests_passed = REF 0;
selfcheck_tests_failed = REF 0;
herein
run_selfcheck = REF FALSE;
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;
#
app_task := NULL;
#
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_bouncing_heads_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';
assert (get_task's_state task == state::SUCCESS);
};
end;
stipulate
# Create and map the bounce window:
#
fun init_bounce
( xdisplay: String, # Typically from DISPLAY environment variable.
xauthentication: Null_Or( xc::Xauthentication ) # Ultimately from ~/.Xauthority.
)
=
{
xsession = xc::open_xsession (xdisplay, xauthentication);
screen = xc::default_screen_of xsession;
my (hostwindow, in_kidplug, delete_slot) # 2009-12-09 CrT: Added 'mailslot' to make it compile.
=
xc::make_simple_top_window screen
{
border_color => xc::black,
background_color => xc::rgb8_color0, # To get XOR to work.
site => { upperleft => { col=>0, row=>0 },
size => { wide=>400, high=>400 },
border_thickness => 1
}
: g2d::Window_Site
};
my (from_mouse', from_keyboard', from_other')
=
{ (xc::ignore_keyboard in_kidplug)
->
xc::KIDPLUG { from_mouse', from_keyboard', from_other', ... };
( from_mouse' ==> xc::get_contents_of_envelope,
from_keyboard' ==> xc::get_contents_of_envelope,
from_other' ==> xc::get_contents_of_envelope
);
};
icon = xc::make_readonly_pixmap_from_clientside_pixmap
screen
hd::att_data;
xc::set_window_manager_properties hostwindow
{
window_name => THE "Bounce",
icon_name => THE "bounce",
size_hints => [ xc::HINT_PPOSITION,
xc::HINT_PSIZE,
xc::HINT_PMIN_SIZE ({ wide => 200, high => 200 } )
],
nonsize_hints => [ xc::HINT_ICON_RO_PIXMAP icon ],
class_hints => NULL,
commandline_arguments => cmd::get_commandline_arguments ()
};
xc::show_window hostwindow;
# How do we sync on the mapping? Do we need to? XXX BUGGO FIXME
(xsession, hostwindow, from_mouse', from_other');
}; # fun init_bounce
# Thread to exercise the app by simulating user
# mouseclicks and verifying their effects:
#
fun make_selfcheck_thread { hostwindow, xsession }
=
xtr::make_thread "bounce-app selfcheck" selfcheck
where
# 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);
};
# Convert coordinate from from
# scale-independent 0.0 -> 1.0 space
# coordinates to X pixel space:
#
fun convert_coordinate_from_abstract_to_pixel_space (window, x, y)
=
{
# Get size of window:
#
(xc::get_window_site window)
->
{ row, col, high, wide };
{ col => f8b::round (f8b::from_int wide * x),
row => f8b::round (f8b::from_int high * y)
};
};
# Simulate a mouseclick in window.
# The (x,y) coordinates are in an
# abstract space in which window
# width and height both run 0.0 -> 1.0
#
fun click_in_window_at (window, x, y, dx, dy)
=
{ button = xc::MOUSEBUTTON 1;
point1 = convert_coordinate_from_abstract_to_pixel_space (window, x, y);
point1 -> { row, col };
point2 = { row => row+dx, col=>col+dy };
xc::send_fake_mousebutton_press_xevent { window, button, point => point1 };
sleep_for 0.1;
xc::send_fake_mousebutton_release_xevent { window, button, point => point2 };
};
fun selfcheck ()
=
{ # Wait until the widgettree is realized and running:
#
# get (wg::get_''gui_startup_complete''_oneshot_of widgettree); # This idea doesn't seem to be working at present anyhow.
# Fetch from X server the center pixels
# over which we are about to draw:
#
(midwindow hostwindow) -> (_, hostwindow_midbox);
#
antedraw_hostwindow_image
=
xc::make_clientside_pixmap_from_window (hostwindow_midbox, hostwindow);
click_in_window_at (hostwindow, 0.50, 0.50, 1, 1);
click_in_window_at (hostwindow, 0.51, 0.49, -1, -1);
click_in_window_at (hostwindow, 0.51, 0.51, 1, -1);
click_in_window_at (hostwindow, 0.49, 0.59, -1, 1);
click_in_window_at (hostwindow, 0.51, 0.49, 2, 1); # No, there's no rhyme nor reason here. :-)
# Re-fetch center pixels, verify
# that new result differs from original result.
#
# This is dreadfully sloppy, but seems to be
# good enough to verify that there is something
# happening in the window:
#
postdraw_hostwindow_image
=
xc::make_clientside_pixmap_from_window (hostwindow_midbox, hostwindow);
#
assert (not (xc::same_cs_pixmap (antedraw_hostwindow_image, postdraw_hostwindow_image)));
sleep_for 3.0; # Just to let the user watch it.
# All done -- shut everything down:
#
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_bouncing_heads_app ();
# shut_down_thread_scheduler winix__premicrothread::process::success; # We used to do this before 6.3
();
};
end; # fun make_selfcheck_thread
fun run_bounce display_or_null
=
{
# We really should be using run_in_x_window_old here;
# this is probably very old code. # XXX BUGGO FIXME.
(xc::get_xdisplay_string_and_xauthentication display_or_null)
->
( xdisplay, # Typically from $DISPLAY environment variable.
xauthentication: Null_Or(xc::Xauthentication) # Typically from ~/.Xauthority
);
(init_bounce (xdisplay, xauthentication))
->
(xsession, hostwindow, from_mouse', from_other');
window_size = (xc::shape_of_window hostwindow).size;
draw_slot = bd::bounce_dm hostwindow; # "dm" is probably "draw_master"
mailcaster = make_mailcaster ();
fun redraw (seqn, size)
=
{ put_in_mailslot (draw_slot, bd::REDRAW seqn);
transmit (mailcaster, bl::REDRAW_BALL (seqn, size));
};
fun kill pt = transmit (mailcaster, bl::KILL pt);
fun kill_all() = transmit (mailcaster, bl::KILL_ALL);
make_ball = bl::make_ball (hostwindow, mailcaster, draw_slot);
fun make_cursor c
=
{ cursor = xc::get_standard_xcursor xsession c;
#
xc::recolor_cursor
{
cursor,
foreground_rgb => xc::rgb_from_unts (0u65535, 0u65535, 0u655350),
background_rgb => xc::rgb_from_unts (0u0, 0u0, 0u0 )
};
cursor;
};
normal_cursor = make_cursor xc::cursors_old::crosshair;
ball_cursor = make_cursor xc::cursors_old::dot;
fun set_cursor c
=
xc::set_cursor hostwindow (THE c);
fun quit ()
=
{ 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_bouncing_heads_app ();
# shut_down_thread_scheduler
# #
# winix__premicrothread::process::success;
};
popup_menu = menu::popup_menu hostwindow;
# We have two modes:
# wait_loop: Waiting for user to press mouse-button;
# down_loop: Waiting for user to release mouse-button.
fun wait_loop (seqn, window_size)
=
{
fun do_mouse (xc::MOUSE_FIRST_DOWN { mouse_button=>xc::MOUSEBUTTON 1, window_point, timestamp, ... } )
=>
{ set_cursor ball_cursor;
down_loop (seqn, window_size, window_point, timestamp);
};
do_mouse (xc::MOUSE_FIRST_DOWN { mouse_button=>xc::MOUSEBUTTON 2, window_point, timestamp, ... } )
=>
{ kill window_point;
wait_loop (seqn, window_size);
};
do_mouse (xc::MOUSE_FIRST_DOWN { mouse_button as xc::MOUSEBUTTON 3, window_point, timestamp, ... } )
=>
case (block_until_mailop_fires (popup_menu (mouse_button, window_point, timestamp, from_mouse')))
#
NULL =>
wait_loop (seqn, window_size);
THE "Refresh"
=>
{ redraw (seqn+1, window_size);
wait_loop (seqn+1, window_size);
};
THE "Kill All"
=>
{ kill_all ();
wait_loop (seqn, window_size);
};
THE "Quit"
=>
quit ();
_ =>
raise exception lib_base::IMPOSSIBLE "Bounce: menu";
esac;
do_mouse _
=>
wait_loop (seqn, window_size);
end;
fun do_other (xc::ETC_REDRAW _)
=>
{ redraw (seqn+1, window_size);
wait_loop (seqn+1, window_size);
};
do_other (xc::ETC_RESIZE ({ wide, high, ... } ))
=>
{ window_size = { wide, high };
redraw (seqn, window_size);
wait_loop (seqn, window_size);
};
do_other (xc::ETC_OWN_DEATH)
=>
quit ();
do_other _
=>
();
end;
block_until_mailop_fires # doesn't <<block_until_mailop_fires cat_mailops>> == <<select>> ? (Was this maybe written before select existed?)
(cat_mailops
[ from_mouse' ==> do_mouse,
from_other' ==> do_other
]
);
}
also
fun down_loop (seqn, window_size, point0, t0)
=
{ fun do_mouse (xc::MOUSE_LAST_UP { mouse_button=>xc::MOUSEBUTTON 1, window_point, timestamp, ... } )
=>
{
sec = xc::xserver_timestamp::to_float (xc::xserver_timestamp::(-) (timestamp, t0));
(g2d::point::subtract (window_point, point0))
->
{ col=>x, row=>y };
dt = sec * bl::updates_per_sec;
fun limit a
=
{ r = (float(a)) / dt;
#
da = f8b::truncate r;
my (abs, sign)
=
if (f8b::(<) (r, 0.0)) (-da, -1);
else ( da, 1);
fi;
if (da == 0)
#
if (f8b::(!=) (r, 0.0)) sign;
else 0;
fi;
else
if (abs * (f8b::round bl::updates_per_sec) > 1000)
#
int::quot (sign*200, (f8b::round bl::updates_per_sec));
else
da;
fi;
fi;
};
make_ball (seqn, window_point, { col => limit x, row => limit y }, window_size);
back_up (seqn, window_size);
};
do_mouse (xc::MOUSE_LAST_UP _) => back_up (seqn, window_size);
do_mouse (xc::MOUSE_LEAVE _) => back_up (seqn, window_size);
do_mouse _
=>
down_loop (seqn, window_size, point0, t0);
end;
fun do_other (xc::ETC_REDRAW _)
=>
{ redraw (seqn+1, window_size);
back_up (seqn+1, window_size);
};
do_other (xc::ETC_RESIZE ({ wide, high, ... } ))
=>
{ window_size = { wide, high };
redraw (seqn, window_size);
back_up (seqn, window_size);
};
do_other (xc::ETC_OWN_DEATH)
=>
quit ();
do_other _
=>
();
end;
block_until_mailop_fires
(cat_mailops
[ from_mouse' ==> do_mouse,
from_other' ==> do_other
]
);
}
also
fun back_up (seqn, window_size)
=
{ set_cursor normal_cursor;
#
wait_loop (seqn, window_size);
};
set_cursor normal_cursor;
if *run_selfcheck
#
make_selfcheck_thread { hostwindow, xsession };
();
fi;
wait_loop (0, window_size); # Enter main loop for thread.
}; # fun run_bounce
herein
fun do_it' (flgs, display_name)
=
{
xlogger::init flgs;
if write_tracelog
#
set_up_tracing ();
fi;
bouncing_heads_app_task = make_task "bouncing heads app" [];
app_task := THE bouncing_heads_app_task;
xlogger::make_thread' [ THREAD_NAME "bounce",
THREAD_TASK bouncing_heads_app_task
]
{. run_bounce (display_name == "" ?? NULL :: THE display_name); }
();
wait_for_app_task_done ();
winix__premicrothread::process::success;
};
fun do_it ()
=
do_it' ([], "");
fun selfcheck ()
=
{
reset_global_mutable_state ();
run_selfcheck := TRUE;
do_it' ([], "");
test_stats ();
};
fun main (program, server ! _) => do_it' ([], server);
main _ => do_it' ([], "");
end;
end; # stipulate
}; # package bouncing_heads_app
end;