## plaid-app.pkg
#
# This app draws screensaver-like rectangular patterns in a window.
#
# It has two modes, "idle" and "active".
#
# In "idle" mode it uses normal buffered xd::fill_boxes XOR-draw
# commands to fill the window with a rectangular pattern and stops.
#
# In "active" mode is uses unbuffered xd::fill_boxes XOR-draw
# commands to draw a continuously changing (another draw every
# 100ms) pattern.
#
# Clicking any mouse button anywhere in the window toggles
# the app between these two modes.
#
# This app uses the "unbuffered" window mode designed to support
# rubber-banding and also the XOR drawing mode used by rubber-banding;
# this makes it a useful unit test for rubber-banding functionality.
#
# One way to run this app from the base-directory commandline is:
#
# linux% my
# eval: make "src/lib/x-kit/tut/plaid/plaid-app.lib";
# eval: plaid_app::do_it ();
# Compiled by:
# src/lib/x-kit/tut/plaid/plaid-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 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 rx = run_in_x_window_old; # run_in_x_window_old is from src/lib/x-kit/widget/old/lib/run-in-x-window-old.pkg #
package top = hostwindow; # hostwindow is from src/lib/x-kit/widget/old/basic/hostwindow.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.pkg package wy = widget_style_old; # widget_style_old is from src/lib/x-kit/widget/old/lib/widget-style-old.pkg #
package sz = size_preference_wrapper; # size_preference_wrapper is from src/lib/x-kit/widget/old/wrapper/size-preference-wrapper.pkg #
package xtr = xlogger; # xlogger is from src/lib/x-kit/xclient/src/stuff/xlogger.pkg #
tracefile = "plaid-app.trace.log";
tracing = logger::make_logtree_leaf { parent => xlogger::xkit_logging, name => "plaid_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 plaid_app
: Plaid_App # Plaid_App is from src/lib/x-kit/tut/plaid/plaid-app.api {
write_tracelog = FALSE;
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.
};
######## Begin mutable selfcheck globals ########
#
app_task = REF (NULL: Null_Or( Apptask ));
selfcheck_tests_passed = REF 0;
selfcheck_tests_failed = REF 0;
run_selfcheck = REF FALSE;
#
######## End mutable selfcheck globals ########
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_plaid_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);
};
# This maildrop gives the selfcheck code
# access to the main drawing window:
#
my drawing_window_oneshot: Oneshot_Maildrop( xc::Window )
=
make_oneshot_maildrop ();
empty_box
=
{ col => 0,
row => 0,
wide => 0,
high => 0
};
# Center given box on given point:
#
fun center_box
( { wide, high, ... }: g2d::Box,
{ col, row }
)
=
{ wide,
high,
col => col - (wide / 2),
row => row - (high / 2)
};
fun make_plaid_widgettree root_window
=
{ bounds = wg::make_tight_size_preference (300, 200);
sz::make_loose_size_preference_wrapper
(wg::make_widget
{
root_window,
size_preference_thunk_of => {. bounds; },
args => {. { background => NULL }; },
realize_widget
}
);
}
where
screen = wg::screen_of root_window;
pen = xc::make_pen [
xc::p::FOREGROUND (xc::rgb8_from_int 0xFF0000), # Was xc::rgb8_color1
xc::p::FUNCTION xc::OP_XOR
];
idle_pen = pen;
timeout' = timeout_in' 0.025;
fun realize_widget { window, window_size, kidplug }
=
{ make_thread "plaid" {. do_active window_size; };
#
();
}
where
put_in_oneshot (drawing_window_oneshot, window);
#
drawwin = xc::drawable_of_window window;
autodrawwin = xc::make_unbuffered_drawable drawwin;
idle_fill = xc::fill_boxes drawwin idle_pen;
fill = xc::fill_boxes autodrawwin idle_pen;
(xc::ignore_keyboard kidplug)
->
xc::KIDPLUG { from_mouse', from_other', ... };
fun do_active (size as { wide, high } )
=
start_over ()
where
my midpoint as ({ col=>midx, row=>midy } )
=
g2d::box::midpoint (g2d::box::make (g2d::point::zero, size));
# Given a point (x,y) with a velocity (dx,dy),
# make it bounce off walls to stay within
# 0 < x < wide
# 0 < y < high
# by appropriately adjusting point and velocity
# whenever it strays outside that area:
#
fun bounce_if_outside_box
(arg as ( { col=>x, row=>y }, # Position.
{ col=>dx, row=>dy } # Velocity.
) )
=
if (x < 0) bounce_if_outside_box ({ col=> -x, row=> y }, { col=> -dx, row=> dy } );
elif (x >= wide) bounce_if_outside_box ({ col=> 2*wide - x - 2, row=> y }, { col=> -dx, row=> dy } );
elif (y < 0) bounce_if_outside_box ({ col=> x, row=> -y }, { col=> dx, row=> -dy } );
elif (y >= high) bounce_if_outside_box ({ col=> x, row=> 2*high - y - 2 }, { col=> dx, row=> -dy } );
else arg;
fi;
# Step point by one velocity increment,
# bouncing off any wall(s) encountered:
#
fun step_point (point, velocity)
=
{ point = g2d::point::add (point, velocity); # Move point one increment.
#
my (point, velocity)
=
bounce_if_outside_box (point, velocity);
(point, velocity);
};
# Step point, bouncing off walls,
# and on odd cycles draw to display:
#
fun step_state { point, velocity, last_box, odd_cycle }
=
{ # Move the point per velocity,
# bouncing off walls appropriately:
#
(step_point (point, velocity))
->
( point as { col, row },
velocity
);
# Map 'point' into the fourth quadrant, then
# define a box with that as one corner and
# (0,0) as the other:
#
box = { col => 0,
row => 0,
#
wide => 2 * abs(col - midx),
high => 2 * abs(row - midy)
};
# Center above box on midpoint of drawing_window:
#
box = center_box (box, midpoint);
if odd_cycle
#
fill (g2d::box::xor (box, last_box));
fi;
{ point,
velocity,
last_box => box,
odd_cycle => not odd_cycle
};
};
fun do_mom (xc::ETC_REDRAW _) => start_over ();
do_mom (xc::ETC_RESIZE ({ wide, high, ... }: g2d::Box)) => do_active ({ wide, high } );
do_mom _ => ();
end
also
fun active_loop state
=
do_one_mailop [
#
timeout' ==> {. active_loop (step_state state); },
from_other' ==> do_mom o xc::get_contents_of_envelope,
from_mouse' ==> (\\ mail = case (xc::get_contents_of_envelope mail)
#
xc::MOUSE_FIRST_DOWN _ => do_idle size;
_ => active_loop state;
esac
)
]
also
fun start_over ()
=
{ xc::clear_drawable drawwin;
#
active_loop
{
point => midpoint,
last_box => empty_box,
odd_cycle => FALSE,
velocity => { col=>1, row=>1 }
};
};
end # fun do_active
also
fun do_idle (size as { wide, high } )
=
idle_loop ()
where
fun redraw ()
=
{
xc::clear_drawable drawwin;
redraw_loop 1;
}
where
bound = int::min (wide, high) / 2;
fun redraw_loop i
=
if (i <= bound)
#
idle_fill
[
{ col=>i, row=>i, wide=>1, high=>high-(2*i) },
{ col=>wide - i - 1, row=>i, wide=>1, high=>high-(2*i) },
{ col=>i, row=>i, wide=>wide-(2*i), high=>1 },
{ col=>i, row=>high - i - 1, wide=>wide-(2*i), high=>1 }
];
redraw_loop (i+2);
fi;
end;
fun do_mom (xc::ETC_REDRAW _) => redraw ();
do_mom (xc::ETC_RESIZE ({ wide, high, ... } )) => do_idle ({ wide, high } );
do_mom _ => ();
end;
fun idle_loop ()
=
do_one_mailop [
#
from_other' ==> idle_loop o do_mom o xc::get_contents_of_envelope,
#
from_mouse' ==> (\\ envelope = case (xc::get_contents_of_envelope envelope)
#
xc::MOUSE_FIRST_DOWN _ => do_active size;
_ => idle_loop ();
esac
)
];
end; # fun do_idle
end; # fun realize_widget
end; # fun make_plaid_widgettree
# Thread to exercise the app by simulating user
# mouseclicks and verifying their effects:
#
fun make_selfcheck_thread { hostwindow, widgettree }
=
{ xtr::make_thread "plaid-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);
};
fun selfcheck ()
=
{ # Wait until the widgettree is realized and running:
#
get_from_oneshot (wg::get_''gui_startup_complete''_oneshot_of widgettree);
drawing_window = get_from_oneshot drawing_window_oneshot;
# Fetch from X server the center pixels
# over which we are about to draw:
#
(midwindow drawing_window) -> (_, drawing_window_midbox);
#
antedraw_midwindow_image
=
xc::make_clientside_pixmap_from_window (drawing_window_midbox, drawing_window);
# Give the drawing thread time to
# draw over the window center:
#
sleep_for 0.5;
# Re-fetch center pixels, verify
# that new result differs from original result.
#
# Strictly speaking we have a race condition
# here, but I think this is good enough for
# the purpose -- this isn't flight control:
#
postdraw_midwindow_image
=
xc::make_clientside_pixmap_from_window (drawing_window_midbox, drawing_window);
#
assert (not (xc::same_cs_pixmap (antedraw_midwindow_image, postdraw_midwindow_image)));
# All done -- shut everything down:
#
(xc::xsession_of_window (wg::window_of widgettree)) -> xsession;
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_plaid_app ();
# shut_down_thread_scheduler winix__premicrothread::process::success; # We did this prior to 6.3
};
end; # fun make_selfcheck_thread
fun start_up_plaid_app_threads root_window
=
{ name = wy::make_view
{ name => wy::style_name [],
aliases => [ wy::style_name [] ]
};
style = wg::style_from_strings (root_window, []);
view = (name, style);
widgettree = make_plaid_widgettree root_window;
args = [ (wa::title, wa::STRING_VAL "Plaid"),
(wa::icon_name, wa::STRING_VAL "Plaid")
];
hostwindow
=
top::hostwindow (root_window, view, args) widgettree;
top::start_widgettree_running_in_hostwindow hostwindow;
close_window' = top::get_''close_window''_mailop hostwindow;
make_thread "window closer" {.
#
do_one_mailop [
#
close_window'
==>
{. hostwindow::destroy hostwindow;
#
sleep_for 0.2; # Give previous time to complete. Need something cleaner here. XXX SUCKO FIXME.
#
kill_plaid_app ();
#
# shut_down_thread_scheduler winix__premicrothread::process::success; # This is what we did pre-6.3.
}
];
};
if *run_selfcheck
#
make_selfcheck_thread { hostwindow, widgettree };
();
fi;
();
}; # fun start_up_plaid_app_threads
fun set_up_plaid_app_task root_window
=
# Here we arrange that all the threads
# for the application run as a task "plaid app",
# so that later we can shut them all down with
# a simple kill_task(). We explicitly create one
# root thread within the task; the rest then implicitly
# inherit task membership:
#
{ plaid_app_task = (the *app_task);
#
xtr::make_thread' [ THREAD_NAME "plaid app",
THREAD_TASK plaid_app_task
]
start_up_plaid_app_threads
root_window;
();
};
fun do_it' (debug_flags, server)
=
{ xlogger::init debug_flags;
#
if write_tracelog set_up_tracing (); fi;
plaid_app_task = make_task "plaid app" [];
app_task := THE plaid_app_task;
rx::run_in_x_window_old' set_up_plaid_app_task [ rx::DISPLAY server ]; # if (server=="") it will be ignored.
sleep_for 0.5;
wait_for_app_task_done ();
};
fun do_it ()
=
{ if write_tracelog set_up_tracing (); fi;
#
plaid_app_task = make_task "plaid app" [];
app_task := THE plaid_app_task;
rx::run_in_x_window_old set_up_plaid_app_task;
wait_for_app_task_done ();
};
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 ();
};
fun main (program ! server ! _, _)
=>
do_it' ([], server);
main _
=>
do_it ();
end;
}; # package plaid
end;