## animate-sim-g.pkg
# Compiled by:
# src/lib/x-kit/tut/nbody/nbody-app.libstipulate
include package threadkit; # threadkit is from src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.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 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 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 v = gravity_simulator::v; # gravity_simulator is from src/lib/x-kit/tut/nbody/gravity-simulator.pkg package wg = widget; # widget is from src/lib/x-kit/widget/old/basic/widget.pkg #
package low = line_of_widgets; # line_of_widgets is from src/lib/x-kit/widget/old/layout/line-of-widgets.pkg package pb = pushbuttons; # pushbuttons is from src/lib/x-kit/widget/old/leaf/pushbuttons.pkg package rw = root_window_old; # root_window_old is from src/lib/x-kit/widget/old/basic/root-window-old.pkg package ws = widget_style_old; # widget_style_old is from src/lib/x-kit/widget/old/lib/widget-style-old.pkg package sld = slider; # slider is from src/lib/x-kit/widget/old/leaf/slider.pkg package sz = size_preference_wrapper; # size_preference_wrapper is from src/lib/x-kit/widget/old/wrapper/size-preference-wrapper.pkg package top = hostwindow; # hostwindow is from src/lib/x-kit/widget/old/basic/hostwindow.pkg package wa = widget_attribute_old; # widget_attribute_old is from src/lib/x-kit/widget/old/lib/widget-attribute-old.pkg #
package xtr = xlogger; # xlogger is from src/lib/x-kit/xclient/src/stuff/xlogger.pkgherein
# This generic is invoked once, in:
#
# src/lib/x-kit/tut/nbody/nbody-app.pkg #
generic package animate_sim_g
(
package gravity_simulator: Gravity_Simulator; # Gravity_Simulator is from src/lib/x-kit/tut/nbody/gravity-simulator.api # position velocity mass radius color
# -------- -------- ---- ------ --------------
planet_data: List( (v::Vector, v::Vector, Float, Int, Null_Or(String)) );
)
{
contr_size = 12; # "contr" may be "control" here.
g = 6.67e-8; # Gravitational constant G == 6.67428e-8 in CGS units -- http://en.wikipedia.org/wiki/Gravitational_constant
simsecs_per_simstep = 500.0; # Simulated seconds per gravitational-simulation step.
max = 7.80e13 * 2.1;
simsteps_per_50ms = 1500;
######## Begin mutable selfcheck globals ########
#
run_selfcheck = REF FALSE;
app_task = REF (NULL: Null_Or( Apptask ));
# gravity_simulator_thread = REF (NULL: Null_Or( Microthread ));
# sim_mouse_thread = REF (NULL: Null_Or( Microthread ));
# sim_body_thread = REF (NULL: Null_Or( Microthread ));
# sim_zoom_thread = REF (NULL: Null_Or( Microthread ));
# selfcheck_thread = REF (NULL: Null_Or( Microthread ));
selfcheck_tests_passed = REF 0;
selfcheck_tests_failed = REF 0;
#
######## End mutable selfcheck globals ########
# all_app_threads = [ gravity_simulator_thread,
# sim_mouse_thread,
# sim_body_thread,
# sim_zoom_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;
#
app_task := NULL;
# apply' all_app_threads
# (\\ thread = thread := NULL);
#
# selfcheck_thread := 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_nbody_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);
};
# fun kill_all_app_threads ()
# =
# apply kill all_app_threads
# where
# fun kill (REF (NULL )) => ();
# kill (REF (THE thread)) => kill_thread { thread, success => TRUE };
# end;
# end;
# fun wait_for_all_app_threads_to_die ()
# =
# { apply wait_for_thread_to_die all_app_threads;
# #
# assert (*deaths_observed == list::length all_app_threads);
# }
# where
# deaths_observed = REF 0;
#
# fun wait_for_thread_to_die (REF NULL)
# =>
# (); # Shouldn't happen.
#
# wait_for_thread_to_die (REF (THE microthread))
# =>
# {
# mailop = thread_done__mailop microthread;
# #
# block_until_mailop_fires mailop;
#
# deaths_observed := *deaths_observed + 1;
# };
# end;
# end;
# This maildrop gives the selfcheck code
# access to the main drawing window:
#
drawing_window_oneshot
=
make_oneshot_maildrop ()
:
Oneshot_Maildrop( xc::Window );
# Thread to exercise the app by simulating user
# mouseclicks and verifying their effects:
#
fun make_selfcheck_thread { hostwindow, widgettree }
=
{
xtr::make_thread "nbody-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 19x19 box enclosing it:
#
stipulate
row = high / 2;
col = wide / 2;
herein
midpoint = { row, col };
midbox = { row => row - 64, col => col - 64, high => 129, wide => 129 };
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;
# There's a nassty race condition here where we wind up
# triggering the
# GET_WINDOW_SITE: window_id %s not yet registered"
# error in
# src/lib/x-kit/xclient/src/window/xsocket-to-hostwindow-router-old.pkg # We need a proper solution to this but for the moment
# we just sleep for 250ms to let stuff get underway:
#
sleep_for 0.25;
# 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.25;
# 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_nbody_app ();
# shut_down_thread_scheduler winix__premicrothread::process::success;
};
end; # fun make_selfcheck_thread
fun spacer n = low::SPACER { min_size => n, best_size => n, max_size => THE n };
fun rubber n = low::SPACER { min_size => 1, best_size => n, max_size => NULL };
sp5 = spacer 5;
fun make_sim_widgettree (root_window, view)
=
{ fun quit ()
=
{ fun q ()
=
{ sleep_for 0.02;
#
rw::delete_root_window root_window;
kill_nbody_app ();
# shut_down_thread_scheduler winix__premicrothread::process::success;
};
make_thread "sim quit" q;
();
};
screen = wg::screen_of root_window;
xsession = wg::xsession_of root_window;
black = xc::black;
white = xc::white;
color_by_name
=
xc::get_color o xc::CMS_NAME;
stipulate
reset_slider_slot = make_mailslot ();
herein
reset_slider' = take_from_mailslot' reset_slider_slot;
fun reset_slider ()
=
put_in_mailslot (reset_slider_slot, ());
end;
s_args = [ (wa::is_vertical, wa::BOOL_VAL FALSE),
(wa::background, wa::STRING_VAL "gray"),
(wa::width, wa::INT_VAL contr_size),
#
(wa::from_value, wa::INT_VAL 0),
(wa::to_value, wa::INT_VAL 100)
];
quit_args = [ (wa::label, wa::STRING_VAL "Q") ];
reset_args = [ (wa::label, wa::STRING_VAL "R") ];
slider = sld::make_slider (root_window, view, s_args);
fun center_slider ()
=
sld::set_slider_value slider 50;
my (qbutton_w, rbutton_w) # "_w" here may be "_widget" or "_wrapper"
=
{ s = 2 * contr_size;
qb = pb::make_text_pushbutton_with_click_callback' (root_window, view, quit_args ) quit;
rb = pb::make_text_pushbutton_with_click_callback' (root_window, view, reset_args) reset_slider;
( sz::make_tight_sized_preference_wrapper (pb::as_widget qb, { wide => s, high => s } ),
sz::make_tight_sized_preference_wrapper (pb::as_widget rb, { wide => s, high => s } )
);
};
controls_line
=
low::HZ_CENTER
[ sp5, low::WIDGET rbutton_w,
sp5, low::WIDGET (sld::as_widget slider),
sp5, low::WIDGET qbutton_w, sp5
];
stipulate
slider_motion' = sld::slider_motion'_of slider;
zoom_slot = make_mailslot ();
herein
zoom' = take_from_mailslot' zoom_slot;
fun slider_thread base
=
{ center_slider ();
loop (base, base);
}
where
fun loop (base, cur)
=
do_one_mailop [
slider_motion' ==> {. do_slider_motion (base, #slider_position); },
reset_slider' ==> {. do_reset_slider cur; }
]
also
fun do_slider_motion (base, slider_position)
=
{ factor = math::pow (2.0, f8b::from_int (slider_position - 50) / 50.0); # Factor runs 0.5 -> 2.0
cur = base * factor;
put_in_mailslot (zoom_slot, cur);
loop (base, cur);
}
also
fun do_reset_slider cur
=
{ center_slider ();
loop (cur, cur);
};
end;
end;
draw_pen = xc::make_pen [xc::p::FOREGROUND xc::rgb8_white ];
erase_pen = xc::make_pen [xc::p::FOREGROUND xc::rgb8_black ];
timer_20ms' = timeout_in' 0.02;
fun make_planet (position, velocity, mass, radius, color_spec)
=
{ color = the_else (null_or::map color_by_name color_spec, white);
#
pen = xc::make_pen [xc::p::FOREGROUND (xc::rgb8_from_rgb color)];
{ position, velocity, mass, user_data => { pen, radius } };
};
planets = map make_planet planet_data;
plea_slot = make_mailslot ();
sim_thread = gravity_simulator::start { g, planets, simsecs_per_simstep, plea_slot, simsteps_per_50ms };
sim_death' = thread_done__mailop sim_thread;
fun realize_widget { window, window_size => { wide, high }, kidplug }
=
{ # make_thread "sim gc" gc_thread;
#
make_thread "sim mouse" mouse_thread;
make_thread "sim body" thread_body ;
();
}
where
put_in_oneshot (drawing_window_oneshot, window);
#
depth = xc::depth_of_window window;
drawwin = xc::drawable_of_window window;
drawwin = xc::make_unbuffered_drawable drawwin;
draw_circle = xc::fill_circle drawwin;
my xc::KIDPLUG { from_other', from_mouse', ... }
=
xc::ignore_keyboard kidplug;
Pan_Cmd
=
PAN
{ horiz: Int,
vert: Int
};
pan_slot = make_mailslot ();
pan' = take_from_mailslot' pan_slot;
fun mouse_thread ()
=
idle ()
where
fun idle ()
=
case (xc::get_contents_of_envelope (block_until_mailop_fires from_mouse'))
#
xc::MOUSE_FIRST_DOWN { mouse_button => xc::MOUSEBUTTON 1, window_point, ... }
=>
pan window_point;
xc::MOUSE_FIRST_DOWN { mouse_button => xc::MOUSEBUTTON 3, ... }
=>
{ quit ();
idle ();
};
_ => idle ();
esac
also
fun pan (pt' as { col => x', row => y' } )
=
case (xc::get_contents_of_envelope (block_until_mailop_fires from_mouse'))
#
xc::MOUSE_MOTION { window_point => pt as { col=>x, row=>y }, ... }
=>
{ put_in_mailslot (pan_slot, PAN { horiz => x - x', vert => y - y' } );
pan pt;
};
xc::MOUSE_UP { mouse_button => xc::MOUSEBUTTON 1, ... }
=>
idle ();
xc::MOUSE_LAST_UP _
=>
idle ();
_ => pan pt';
esac;
end;
fun new_translation { ocl, wid, ht, w_zx, w_zy, zoom }
=
loop ocl
where
fun win_circle { position, velocity, mass, user_data => { pen, radius } }
=
{ my { x, y } = v::proj2d position;
scrx = f8b::round ((x - w_zx) * zoom) except _ = 0;
scry = f8b::round ((y - w_zy) * zoom) except _ = 0;
{ center => { col => scrx, row => scry },
rad => radius
};
};
fun draw_planet (new_planet as { user_data => { pen, ... }, ... } )
=
{ new_circle = win_circle new_planet;
draw_circle pen new_circle;
new_circle;
};
fun move_planet (old_circle, new_planet)
=
{ draw_circle erase_pen old_circle;
draw_planet new_planet;
};
fun update old_circles
=
{ reply_slot = make_mailslot ();
#
put_in_mailslot (plea_slot, gravity_simulator::GET_PLANETS reply_slot);
new_planets = take_from_mailslot reply_slot;
THE case old_circles
#
THE old_circles => paired_lists::map move_planet (old_circles, new_planets);
NULL => list::map draw_planet new_planets;
esac;
};
fun death cl
=
{ print "Simulation has died!\n";
quit ();
loop cl;
}
also
fun loop circles
=
do_one_mailop [
#
sim_death' ==> {. death circles; },
timer_20ms' ==> {. loop (update circles); },
#
from_other' ==> {. do_mom (circles, xc::get_contents_of_envelope #x); },
pan' ==> {. do_pan (circles, #p); },
zoom' ==> {. do_zoom (circles, #z); }
]
also
fun do_mom (cl, xc::ETC_RESIZE (r))
=>
{ r -> { wide => nw,
high => nh,
...
};
f = 0.5 / zoom;
xc::clear_drawable drawwin;
new_translation
{ ocl => cl,
wid => nw,
ht => nh,
w_zx => w_zx - f8b::from_int (nw - wid) * f,
w_zy => w_zy - f8b::from_int (nh - ht ) * f,
zoom
};
};
do_mom (cl, _)
=>
loop cl;
end
also
fun do_pan (cl, PAN { horiz, vert } )
=
new_translation
{ ocl => cl,
wid => wid,
ht,
zoom,
w_zx => w_zx - f8b::from_int horiz / zoom,
w_zy => w_zy - f8b::from_int vert / zoom
}
also
fun do_zoom (cl, z)
=
{ f = 0.5 * (1.0 / zoom - 1.0 / z);
new_translation
{ ocl => cl,
wid,
ht,
zoom => z,
w_zx => w_zx + f8b::from_int wid * f,
w_zy => w_zy + f8b::from_int ht * f
};
};
end;
fun thread_body ()
=
{ zoom = f8b::from_int wide / max;
f = -0.5 / zoom;
w_zx = f8b::from_int wide * f;
w_zy = f8b::from_int high * f;
make_thread "sim zoom" {.
#
slider_thread zoom;
};
new_translation
{ ocl => NULL,
wid => wide,
ht => high,
w_zx,
w_zy,
zoom
};
};
/* garbageCollectionTimeOut = threadkit::timeOutEvt (time::from_seconds 10)
fun garbageCollectionThread ()
=
( block_until_mailop_fires garbageCollectionTimeOut; runtime_internals::gc::collectGarbage 5; # runtime_internals is from src/lib/std/src/nj/runtime-internals.pkg garbageCollectionThread ()
)
*/
end; # fun realize_widget
size = wg::make_tight_size_preference (500, 500);
disp_w
=
sz::make_loose_size_preference_wrapper
(wg::make_widget
{ size_preference_thunk_of => \\ () = size,
args => \\ () = { background => THE black },
root_window,
realize_widget
}
);
low::as_widget
(low::make_line_of_widgets root_window
(low::VT_CENTER
[ sp5,
controls_line,
sp5,
low::WIDGET disp_w,
sp5
]
)
);
}; # fun make_sim_widgettree
fun start_up_nbody_app_threads root_window
=
{
style = wg::style_from_strings (root_window, []);
name = ws::make_view
{ name => ws::style_name [],
aliases => [ ws::style_name [] ]
};
view = (name, style);
widgettree = make_sim_widgettree (root_window, view);
args = [ (wa::title, wa::STRING_VAL "N-Body"),
(wa::icon_name, wa::STRING_VAL "n-body")
];
hostwindow = top::hostwindow (root_window, view, args) widgettree;
top::start_widgettree_running_in_hostwindow hostwindow;
if *run_selfcheck
#
make_selfcheck_thread { hostwindow, widgettree };
();
fi;
};
fun set_up_nbody_app_task root_window
=
# Here we arrange that all the threads
# for the application run as a task "nbody 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:
#
{ nbody_app_task = (the *app_task);
#
xtr::make_thread' [ THREAD_NAME "nbody app",
THREAD_TASK nbody_app_task
]
start_up_nbody_app_threads
root_window;
();
};
fun do_it' (debug_flags, server)
=
{ xlogger::init debug_flags;
#
nbody_app_task = make_task "nbody app" [];
app_task := THE nbody_app_task;
rx::run_in_x_window_old' set_up_nbody_app_task [ rx::DISPLAY server ];
sleep_for 0.25;
wait_for_app_task_done ();
};
fun do_it ()
=
{
nbody_app_task = make_task "nbody app" [];
app_task := THE nbody_app_task;
rx::run_in_x_window_old set_up_nbody_app_task;
#
sleep_for 0.25;
wait_for_app_task_done ();
};
fun main (_: String, program ! server ! _)
=>
do_it' ([], server);
main _
=>
do_it ();
end;
main = (\\ () = winix__premicrothread::process::success) o main;
fun selfcheck ()
=
{ reset_global_mutable_state ();
run_selfcheck := TRUE;
do_it ();
test_stats ();
};
}; # generic package animate_sim_g
end;