## shade -imp-old.pkg
#
# Publish the current trio of color shades
# (light/base/dark) to be used for drawing
# 3-D widgets etc.
# Compiled by:
# src/lib/x-kit/widget/xkit-widget.sublib### "The idea of a formal design discipline is often rejected
### on account of vague cultural/philosophical condemnations
### such as ``stifling creativity''; this is more pronounced
### in the Anglo-Saxon world where a romantic vision of
### ``the humanities'' in fact idealizes technical incompetence."
###
### -- E.J. Dijkstra
stipulate
include package threadkit; # threadkit is from src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.pkg #
package xc = xclient; # xclient is from src/lib/x-kit/xclient/xclient.pkg package pms = standard_clientside_pixmaps_old; # standard_clientside_pixmaps_old is from src/lib/x-kit/widget/old/lib/standard-clientside-pixmaps-old.pkgherein
package shade_imp_old
: (weak) Shade_Imp_Old # Shade_Imp_Old is from src/lib/x-kit/widget/old/lib/shade-imp-old.api {
exception BAD_SHADE;
Shades = { light: xc::Pen,
base: xc::Pen,
dark: xc::Pen
};
Plea_Mail
=
GET_SHADES xc::Rgb;
Reply_Mail
=
Null_Or( Shades );
Shade_Imp
=
SHADE_IMP
{ plea_slot: Mailslot( Plea_Mail ),
reply_slot: Mailslot( Reply_Mail )
};
# typelocked_hashtable_g is from src/lib/src/typelocked-hashtable-g.pkg package rgb
=
typelocked_hashtable_g (
Hash_Key = xc::Rgb;
fun same_key (k1: Hash_Key, k2)
=
xc::same_rgb (k1, k2);
fun hash_value (rgb: xc::Rgb)
=
{ (xc::rgb_to_unts rgb)
->
(red, green, blue);
red + green + blue;
};
);
Rgb_Table = rgb::Hashtable( Shades );
fun monochrome screen
=
xc::display_class_of_screen screen == xc::STATIC_GRAY and
xc::depth_of_screen screen == 1;
fun make_shade_imp screen
=
{ exception NOT_FOUND;
#
rgb_table = rgb::make_hashtable { size_hint => 32, not_found_exception => NOT_FOUND }
: Rgb_Table
;
rgb_ins = rgb::set rgb_table;
rgb_find = rgb::find rgb_table;
max_i = 0u65535;
fun lighten v c = unt::min (max_i, (v*c) / 0u100) except _ = max_i;
fun darken v c = unt::min (max_i, (v*c) / 0u100) except _ = max_i;
lighten = lighten 0u140;
darken = darken 0u060;
fun color (r, g, b)
=
xc::get_color (xc::CMS_RGB { red=>r, green=>g, blue=>b } );
fun make_p c
=
xc::make_pen [xc::p::FOREGROUND (xc::rgb8_from_rgb c) ];
fun make_p' t
=
xc::make_pen [ xc::p::FOREGROUND xc::rgb8_black,
xc::p::BACKGROUND xc::rgb8_white,
xc::p::STIPPLE t,
xc::p::FILL_STYLE_OPAQUE_STIPPLED
];
fun bw_shade (c, rgb)
=
{ lgray = xc::make_readonly_pixmap_from_clientside_pixmap screen pms::light_gray;
dgray = xc::make_readonly_pixmap_from_clientside_pixmap screen pms::dark_gray;
my (lt, dk)
=
xc::same_rgb (c, xc::white)
?? (lgray, dgray)
:: (dgray, lgray);
s = { light => make_p' lt, base => make_p c, dark => make_p' dk };
rgb_ins (rgb, s);
THE s;
}
except _ = NULL;
fun gray_shade (c, rgb)
=
{
lgray = xc::get_color (xc::CMS_NAME "gray87");
dgray = xc::get_color (xc::CMS_NAME "gray44");
my (lt, dk)
=
xc::same_rgb (c, xc::white)
?? (lgray, dgray)
:: (dgray, lgray);
s = { light => make_p lt, base => make_p c, dark => make_p dk };
rgb_ins (rgb, s);
THE s;
}
except
_ = bw_shade (c, rgb);
fun color_shade (c, rgb)
=
{ (xc::rgb_to_unts rgb)
->
(red, blue, green);
fun shade ()
=
{ lt = color (lighten red, lighten green, lighten blue);
dk = color (darken red, darken green, darken blue);
s = { light => make_p lt, base => make_p c, dark => make_p dk };
rgb_ins (rgb, s);
THE s;
}
except _ = NULL;
if (xc::same_rgb (c, xc::white)
or xc::same_rgb (c, xc::black)
)
gray_shade (c, rgb);
else shade ();
fi;
};
allot_shade = monochrome screen ?? bw_shade :: color_shade;
fun do_plea (GET_SHADES rgb)
=
case (rgb_find rgb)
#
NULL => allot_shade (rgb, rgb);
s => s;
esac;
plea_slot = make_mailslot ();
reply_slot = make_mailslot ();
fun loop ()
=
for (;;) {
put_in_mailslot (reply_slot, do_plea (take_from_mailslot plea_slot));
};
xlogger::make_thread "shade_imp" loop;
SHADE_IMP { plea_slot, reply_slot };
};
fun get_shades (SHADE_IMP { plea_slot, reply_slot } ) color
=
{ put_in_mailslot (plea_slot, GET_SHADES color);
#
case (take_from_mailslot reply_slot)
#
THE s => s;
_ => raise exception BAD_SHADE;
esac;
};
};
end;