## 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 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 rx = run_xkit; # run_xkit is from src/lib/x-kit/widget/lib/run-xkit.pkg #
package top = topwindow; # topwindow is from src/lib/x-kit/widget/basic/topwindow.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 package wy = widget_style; # widget_style is from src/lib/x-kit/widget/lib/widget-style.pkg #
package sz = size_preference_wrapper; # size_preference_wrapper is from src/lib/x-kit/widget/wrapper/size-preference-wrapper.pkg #
package xtr = xlogger; # xlogger is from src/lib/x-kit/xclient/pkg/stuff/xlogger.pkg #
tracefile = "plaid-app.trace.log";
tracing = logger::make_logtree_leaf { parent => xlogger::xkit_logging, name => "plaid_app::tracing" };
trace = xtr::log_if tracing; # 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.pkg #
include logger; # logger is from src/lib/src/lib/thread-kit/src/lib/logger.pkg #
set_logger_to (file::LOG_TO_FILE tracefile);
# enable file::all_logging; # Gross overkill.
};
stipulate
selfcheck_tests_passed = REF 0;
selfcheck_tests_failed = REF 0;
herein
run_selfcheck = REF FALSE;
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
};
end;
# 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
=
xg::BOX
{ col => 0,
row => 0,
wide => 0,
high => 0
};
# Center given box on given point:
#
fun center_box
( xg::BOX { wide, high, ... },
xg::POINT { col, row }
)
=
xg::BOX
{ 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 => realize_plaid
}
);
}
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' (time::from_milliseconds 25);
fun realize_plaid { window, window_size, kidplug }
=
{ make_thread "plaid" .{ do_active window_size; };
();
}
where
set (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 xg::SIZE { wide, high } )
=
start_over ()
where
my middle as (xg::POINT { col=>midx, row=>midy } )
=
xg::box::middle (xg::box::make (xg::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 ( xg::POINT { col=>x, row=>y }, # Position.
xg::POINT { col=>dx, row=>dy } # Velocity.
) )
=
if (x < 0) bounce_if_outside_box (xg::POINT { col=> -x, row=> y }, xg::POINT { col=> -dx, row=> dy } );
elif (x >= wide) bounce_if_outside_box (xg::POINT { col=> 2*wide - x - 2, row=> y }, xg::POINT { col=> -dx, row=> dy } );
elif (y < 0) bounce_if_outside_box (xg::POINT { col=> x, row=> -y }, xg::POINT { col=> dx, row=> -dy } );
elif (y >= high) bounce_if_outside_box (xg::POINT { col=> x, row=> 2*high - y - 2 }, xg::POINT { 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 = xg::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 xg::POINT { 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 = xg::BOX
{ col => 0,
row => 0,
#
wide => 2 * abs(col - midx),
high => 2 * abs(row - midy)
};
# Center above box on middle of drawing_window:
#
box = center_box (box, middle);
if odd_cycle
#
fill (xg::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 (xg::BOX { wide, high, ... } )) => do_active (xg::SIZE { wide, high } );
do_mom _ => ();
end
also
fun active_loop state
=
select [ timeout' ==> .{ active_loop (step_state state); },
from_other' ==> do_mom o xc::envelope_contents,
from_mouse' ==> (fn mail = case (xc::envelope_contents mail)
#
xc::MOUSE_FIRST_DOWN _ => do_idle size;
_ => active_loop state;
esac
)
]
also
fun start_over ()
=
{ xc::clear_drawable drawwin;
active_loop
{
point => middle,
last_box => empty_box,
odd_cycle => FALSE,
velocity => xg::POINT { col=>1, row=>1 }
};
};
end # fun do_active
also
fun do_idle (size as xg::SIZE { 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
[
xg::BOX { col=>i, row=>i, wide=>1, high=>high-(2*i) },
xg::BOX { col=>wide - i - 1, row=>i, wide=>1, high=>high-(2*i) },
xg::BOX { col=>i, row=>i, wide=>wide-(2*i), high=>1 },
xg::BOX { 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 (xg::BOX { wide, high, ... } )) => do_idle (xg::SIZE { wide, high } );
do_mom _ => ();
end;
fun idle_loop ()
=
select [ from_other' ==> idle_loop o do_mom o xc::envelope_contents,
#
from_mouse' ==> (fn envelope = case (xc::envelope_contents envelope)
#
xc::MOUSE_FIRST_DOWN _ => do_active size;
_ => idle_loop ();
esac
)
];
end; # fun do_idle
end; # fun realize_plaid
end; # fun make_plaid_widgettree
# Thread to exercise the app by simulating user
# mouseclicks and verifying their effects:
#
fun make_selfcheck_thread { topwindow, 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)
->
xg::BOX { row, col, high, wide };
# Define midpoint of drawing window,
# and a 9x9 box enclosing it:
#
stipulate
row = high / 2;
col = wide / 2;
herein
midpoint = xg::POINT { row, col };
midbox = xg::BOX { row => row - 4, col => col - 4, high => 9, wide => 9 };
end;
(midpoint, midbox);
};
fun selfcheck ()
=
{ # Wait until the widgettree is realized and running:
#
get (wg::get_''gui_startup_complete''_oneshot_of widgettree);
drawing_window = get 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 (time::from_milliseconds 500);
# 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;
shut_down_thread_scheduler winix::process::success;
};
end; # fun make_selfcheck_thread
fun plaid_app 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")
];
topwindow
=
top::topwindow (root_window, view, args) widgettree;
top::start topwindow;
close_window' = top::get_''close_window''_mailop topwindow;
make_thread "window closer" .{
#
select [
close_window'
==>
.{
topwindow::destroy topwindow;
shut_down_thread_scheduler winix::process::success;
}
];
};
if *run_selfcheck
#
make_selfcheck_thread { topwindow, widgettree };
();
fi;
();
}; # fun plaid_app
fun do_it' (debug_flags, server)
=
{ xlogger::init debug_flags;
if write_tracelog set_up_tracing (); fi;
rx::run_xkit'
#
plaid_app
#
{ display => (server == "" ?? NULL :: THE server),
time_quantum_in_milliseconds => NULL
};
};
fun do_it ()
=
{ if write_tracelog set_up_tracing (); fi;
#
rx::run_xkit plaid_app;
};
fun selfcheck ()
=
{ run_selfcheck := TRUE;
do_it' ([], "");
test_stats ();
};
fun main (program ! server ! _, _)
=>
do_it' ([], server);
main _
=>
do_it ();
end;
}; # package plaid
end;