## slider-look.pkg
#
# Slider views.
# Compiled by:
# src/lib/x-kit/widget/xkit-widget.sublib### "I am amazed, O Wall, that you have
### not collapsed and fallen, since you
### must bear the tedious stupidities
### of so many scrawlers."
###
### -- graffiti in Pompeii, 79AD
stipulate#
# include xgeometry; # xgeometry is from src/lib/std/2d/xgeometry.pkg package f8b = eight_byte_float; # eight_byte_float is from src/lib/std/eight-byte-float.pkg package xc = xclient; # xclient is from src/lib/x-kit/xclient/xclient.pkg package xg = xgeometry; # xgeometry is from src/lib/std/2d/xgeometry.pkg #
package d3 = three_d; # three_d is from src/lib/x-kit/widget/lib/three-d.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.pkgherein
package slider_look
: (weak) Slider_Look # Slider_Look is from src/lib/x-kit/widget/leaf/slider-look.api {
min = int::min;
max = int::max;
fun make_font_info font
=
{ (xc::font_high font)
->
{ ascent => font_ascent,
descent => font_descent
};
(font, font_ascent, font_descent);
};
fun make_label (NULL, _)
=>
NULL;
make_label (THE s, font)
=>
{ my xc::CHAR_INFO { left_bearing=>lb, right_bearing=>rb, ... }
=
.overall_info (xc::text_extents font s);
THE (s, lb, rb);
};
end;
fun int_to_string i
=
if (i >= 0)
int::to_string i;
else
"-" + (int::to_string (-i));
fi;
fun get_tick_width (from_v, to_v, font, font_ascent)
=
{ fun size (i: Int)
=
{ s = int_to_string i;
my xc::CHAR_INFO { left_bearing=>lb, right_bearing=>rb, ... }
=
.overall_info (xc::text_extents font s);
rb-lb;
};
(font_ascent / 2) + max (size from_v, size to_v);
};
State = (Int, Bool, Bool, Bool);
Slider_Look
=
{ background_color: xc::Rgb,
foreground_color: xc::Rgb,
#
is_vertical: Bool,
show_value: Bool,
#
fontinfo: (xc::Font, Int, Int),
relief: wg::Relief,
#
border_thickness: Int,
from_v: Int,
length: Int,
#
label: Null_Or( (String, Int, Int) ),
#
shades: wg::Shades,
ready_shades: wg::Shades,
slide_shades: wg::Shades,
#
thumb: Int,
tick: Int,
to_v: Int,
offset: Int,
tick_width: Int,
width: Int
};
fun num_ticks ( { tick=>0, ... } : Slider_Look)
=>
0;
num_ticks ( { tick, from_v, to_v, ... } : Slider_Look)
=>
loop (from_v, 0)
where
stop = if (from_v <= to_v) fn v = to_v < v;
else fn v = to_v > v;
fi;
fun loop (v, count)
=
if (stop v) count;
else loop (v+tick, count+1);
fi;
end;
end;
widget_attributes
=
[ (wa::ready_color, wa::COLOR, wa::NO_VAL ),
(wa::background, wa::COLOR, wa::STRING_VAL "white" ),
(wa::border_thickness, wa::INT, wa::INT_VAL 2 ),
(wa::font, wa::FONT, wa::STRING_VAL "8x13" ),
(wa::foreground, wa::COLOR, wa::STRING_VAL "black" ),
(wa::is_vertical, wa::BOOL, wa::BOOL_VAL TRUE ),
(wa::relief, wa::RELIEF, wa::RELIEF_VAL wg::FLAT ),
(wa::from_value, wa::INT, wa::INT_VAL 0 ),
(wa::label, wa::STRING, wa::NO_VAL ),
(wa::length, wa::INT, wa::INT_VAL 100 ),
(wa::show_value, wa::BOOL, wa::BOOL_VAL FALSE ),
(wa::color, wa::COLOR, wa::NO_VAL ),
(wa::thumb_length, wa::INT, wa::INT_VAL 30 ),
(wa::tick_interval, wa::INT, wa::INT_VAL 0 ),
(wa::to_value, wa::INT, wa::INT_VAL 100 ),
(wa::width, wa::INT, wa::INT_VAL 15 )
];
spacing = 2;
fun make_slider_look (root, attributes)
=
{ foreground_color = wa::get_color (attributes wa::foreground);
background_color = wa::get_color (attributes wa::background);
shades = wg::shades root background_color;
slide_shades = case (wa::get_color_opt (attributes wa::color))
#
THE c => wg::shades root c;
NULL => shades;
esac;
ready_shades = case (wa::get_color_opt (attributes wa::ready_color))
#
THE c => wg::shades root c;
NULL => slide_shades;
esac;
to_v = wa::get_int (attributes wa::to_value);
from_v = wa::get_int (attributes wa::from_value);
border_thickness = wa::get_int (attributes wa::border_thickness);
font = wa::get_font (attributes wa::font);
my fontinfo as (font, font_ascent, _)
=
make_font_info font;
thumb = max (6, max (3*border_thickness, wa::get_int (attributes wa::thumb_length)));
relief = wa::get_relief (attributes wa::relief);
fun check_tick t
=
if (from_v <= to_v) (t < 0) ?? -t :: t;
else (t > 0) ?? -t :: t;
fi;
{ background_color,
foreground_color,
border_thickness,
fontinfo,
is_vertical => wa::get_bool (attributes wa::is_vertical),
relief,
from_v,
label => make_label (wa::get_string_opt (attributes wa::label), font),
length => max (wa::get_int (attributes wa::length), thumb),
show_value => wa::get_bool (attributes wa::show_value),
shades,
slide_shades,
ready_shades,
thumb,
tick => check_tick (wa::get_int (attributes wa::tick_interval)),
tick_width => get_tick_width (from_v, to_v, font, font_ascent),
offset => case relief wg::FLAT => 0; _ => border_thickness; esac,
to_v,
width => max (3*border_thickness, wa::get_int (attributes wa::width))
};
};
fun hbounds_of (slider_look: Slider_Look)
=
{ slider_look.fontinfo -> (_, font_ascent, font_descent);
line_high = font_ascent + font_descent;
offset2 = 2*slider_look.offset;
bw2 = 2*slider_look.border_thickness;
x = max (slider_look.length + offset2, (num_ticks slider_look)*slider_look.tick_width);
y = slider_look.width
+ offset2
+ bw2
+ if (slider_look.tick != 0 ) line_high; else 0;fi
+ if slider_look.show_value line_high + spacing; else 0;fi
+ case slider_look.label NULL => 0; _ => line_high; esac
;
size_preferences
=
{ col_preference => wg::loose_preference (x+bw2),
row_preference => wg::tight_preference y
};
fn ()
=
size_preferences;
};
fun vbounds_of (slider_look: Slider_Look)
=
{ slider_look.fontinfo -> (font, font_ascent, font_descent);
label_width = case slider_look.label
THE(_, lb, rb) => rb - lb + font_ascent;
NULL => 0;
esac;
tick_width = slider_look.tick_width;
tick_width = if (slider_look.tick != 0 ) tick_width; else 0;fi;
value_width = if slider_look.show_value tick_width; else 0;fi;
offset2 = 2*slider_look.offset;
bw2 = 2*slider_look.border_thickness;
y = slider_look.length + offset2 + bw2;
x = slider_look.width + offset2 + bw2 +
label_width + spacing + tick_width + value_width;
size_preferences
=
{ col_preference => wg::tight_preference x,
row_preference => wg::loose_preference y
};
fn ()
=
size_preferences;
};
fun val_to_pt (size, slider_look: Slider_Look)
=
{ slider_look -> { is_vertical, thumb, border_thickness, offset, from_v, to_v, ... };
size -> xg::SIZE { wide, high };
range = real (to_v - from_v);
prange = (is_vertical ?? high :: wide)
- thumb - 2*(offset + border_thickness);
rprange = real prange;
off = thumb / 2 + offset + border_thickness;
if (f8b::(====) (range, 0.0))
#
fn _ = off;
else
fn value
=
{ y = trunc((real (value - from_v) * rprange)//range + 0.5);
y = if (y < 0 ) 0;
else if (y > prange) prange;
else y; fi; fi;
y + off;
};
fi;
};
fun draw_border (0, _, _, _, _)
=>
();
draw_border (bw, d, wide, high, slider_look: Slider_Look)
=>
{ r = xg::BOX { row=>0, col=>0, wide, high };
rel = slider_look.relief;
shades = slider_look.shades;
d3::draw_box d { box=>r, relief=> rel, width=>bw } shades;
};
end;
fun draw_vvalue (val_to_pt, high, dr, pen, slider_look: Slider_Look) (value, right)
=
{ slider_look.fontinfo -> (font, font_ascent, font_descent);
offset = slider_look.offset;
string = int_to_string value;
my xc::CHAR_INFO { right_bearing, ascent, descent, ... }
=
(xc::text_extents font string).overall_info;
y = max((val_to_pt value) + (font_ascent / 2), offset+ascent);
y = min (y, high - offset - descent);
x = right - right_bearing;
xc::draw_transparent_string dr pen font (xg::POINT { col=>x, row=>y }, string);
};
fun draw_hvalue (val_to_pt, wide, dr, pen, slider_look: Slider_Look) (value, bottom)
=
{ slider_look.fontinfo -> (font, _, font_descent);
string = int_to_string value;
my xc::CHAR_INFO { left_bearing=>lb, right_bearing=>rb, ... }
=
.overall_info (xc::text_extents font string);
y = bottom - font_descent;
offset = slider_look.offset;
x = max((val_to_pt value) - (lb + rb) / 2, lb + offset);
x = min (x, wide - offset - rb);
xc::draw_transparent_string dr pen font (xg::POINT { col=>x, row=>y }, string);
};
fun vdrawf (window, size as xg::SIZE { wide, high }, slider_look: Slider_Look)
=
draw
where
# include xdraw; # xdraw is from src/lib/x-kit/xclient/xclient.pkg drawable = xc::drawable_of_window window;
fd = xc::make_unbuffered_drawable drawable; # "fd" might be "fast drawable" or some such...?
offset = slider_look.offset;
border_thickness = slider_look.border_thickness;
val_to_pt = val_to_pt (size, slider_look);
text_pen = xc::make_pen [xc::p::FOREGROUND (xc::rgb8_from_rgb slider_look.foreground_color)];
draw_vvalue = draw_vvalue (val_to_pt, high, drawable, text_pen, slider_look);
slider_look.fontinfo -> (font, font_ascent, font_descent);
label_wide = case slider_look.label
THE(_, lb, rb) => rb - lb + font_ascent;
NULL => 0;
esac;
tick_width = slider_look.tick_width;
tick_wide = if (slider_look.tick != 0) tick_width; else 0;fi;
value_wide = if slider_look.show_value tick_width; else 0;fi;
total = tick_wide + value_wide + 2*(border_thickness+spacing)
+ label_wide + slider_look.width;
tick_right = (wide - total) / 2 + tick_wide;
value_right = tick_right + value_wide;
scale_left = value_right + spacing;
label_left = scale_left + 2*border_thickness
+ slider_look.width + (font_ascent / 2);
fun draw_ticks 0
=>
();
draw_ticks delta
=>
loop from_v
where
to_v = slider_look.to_v;
from_v = slider_look.from_v;
stop = if (from_v <= to_v) fn v = to_v < v;
else fn v = to_v > v;
fi;
fun loop v
=
if (not (stop v))
draw_vvalue (v, tick_right);
loop (v+delta);
fi;
end;
end;
fun draw_label NULL
=>
();
draw_label (THE (string, _, _))
=>
{ col = label_left;
row = offset + (3*font_ascent) / 2;
xc::draw_transparent_string drawable text_pen font (xg::POINT { col, row }, string);
};
end;
fun draw_value (value, dont_erase)
=
{ if (not dont_erase)
box = xg::BOX
{ col=> value_right - value_wide,
row=> offset,
wide=>value_wide,
high=> high - 2*offset
};
xc::clear_box drawable box;
fi;
draw_vvalue (value, value_right);
};
fun init_window ()
=
{ xc::clear_drawable drawable;
draw_ticks slider_look.tick;
draw_label slider_look.label;
};
fun draw_slider (value, ready, down, do_all)
=
{ include three_d;
width = slider_look.width;
border_thickness = slider_look.border_thickness;
shades = slider_look.shades;
slide_shades = if ready slider_look.ready_shades;
else slider_look.slide_shades;
fi;
fun draw_inset (x, y, w, h, sw, rel)
=
{ x = x+sw;
y = y+sw;
h = h-sw;
w = w - 2*sw;
box = xg::BOX { col=>x, row=>y, wide=>w, high=>h };
box' = xg::BOX { col=>x, row=>y+h, wide=>w, high=>h };
draw_filled_box drawable { box=>box, width=>sw, relief=>rel } slide_shades;
draw_filled_box fd { box=>box', width=>sw, relief=>rel } slide_shades;
};
fun draw_slide ()
=
{ sht = slider_look.thumb / 2;
swid = width;
col = scale_left + border_thickness;
row = (val_to_pt value) - sht;
shadow_width = max (1, border_thickness / 2);
relief = if down wg::SUNKEN; else wg::RAISED;fi;
box = xg::BOX { col, row, wide=>swid, high=>2*sht };
draw_box drawable { box, width=>border_thickness, relief } slide_shades;
draw_inset (col, row, swid, sht, shadow_width, relief);
};
if do_all
box = xg::BOX
{ col=>scale_left,
row=>offset,
high=>high - 2*offset,
wide=> width + 2*border_thickness
};
draw_box drawable { box, width=>border_thickness, relief=>wg::SUNKEN } shades;
else
box = xg::BOX
{ col => scale_left+border_thickness,
row => offset+border_thickness,
#
high => high - 2*(border_thickness+offset),
wide => width
};
xc::clear_box drawable box;
fi;
draw_slide ();
};
fun draw ((value, active, ready, down), do_all)
=
{ if do_all init_window(); fi;
if slider_look.show_value draw_value (value, do_all); fi;
draw_slider (value, ready, down, do_all);
if do_all draw_border (offset, drawable, wide, high, slider_look); fi;
};
end;
fun hdrawf (window, size as xg::SIZE { wide, high }, slider_look: Slider_Look)
=
{ drawable = xc::drawable_of_window window;
fd = xc::make_unbuffered_drawable drawable; # "fd" may be "fast drawable"
offset = slider_look.offset;
val_to_pt = val_to_pt (size, slider_look);
text_pen = xc::make_pen [xc::p::FOREGROUND (xc::rgb8_from_rgb slider_look.foreground_color)];
draw_hvalue = draw_hvalue (val_to_pt, wide, drawable, text_pen, slider_look);
slider_look.fontinfo -> (font, font_ascent, font_descent);
line_high = font_ascent + font_descent;
tick_height = if (slider_look.tick != 0) line_high; else 0;fi;
value_height = if slider_look.show_value line_high + spacing; else 0;fi;
label_height
=
case slider_look.label
#
NULL => 0;
_ => line_high;
esac;
border_thickness = slider_look.border_thickness;
total = tick_height + value_height + 2*border_thickness + slider_look.width
+ label_height;
ticky = (high + total) / 2 - 1;
valuey = ticky - tick_height;
scaley = valuey - value_height;
labely = scaley - 2*border_thickness - slider_look.width;
fun draw_ticks 0
=>
();
draw_ticks delta
=>
loop from_v
where
to_v = slider_look.to_v;
from_v = slider_look.from_v;
stop = if (from_v <= to_v) fn v = to_v < v;
else fn v = to_v > v;
fi;
fun loop v
=
if (not (stop v))
#
draw_hvalue (v, ticky);
loop (v+delta);
fi;
end;
end;
fun draw_label NULL
=>
();
draw_label (THE (string, lb, rb))
=>
{ col = offset + font_ascent / 2;
row = labely - font_descent;
xc::draw_transparent_string drawable text_pen font (xg::POINT { col, row }, string);
};
end;
fun init_window ()
=
{ xc::clear_drawable drawable;
draw_ticks slider_look.tick;
draw_label slider_look.label;
};
fun draw_value (value, do_not_erase)
=
{
if (not do_not_erase)
#
box = xg::BOX
{ col=> offset,
row=> scaley + 1,
wide=> wide - 2*offset,
high=> valuey - scaley
};
xc::clear_box drawable box;
fi;
draw_hvalue (value, valuey);
};
fun draw_slider (value, ready, down, do_all)
=
{ include three_d;
width = slider_look.width;
border_thickness = slider_look.border_thickness;
y = scaley - 2*border_thickness - width + 1;
shades = slider_look.shades;
slide_shades = if ready slider_look.ready_shades;
else slider_look.slide_shades;
fi;
fun draw_inset (x, y, w, h, sw, rel)
=
{ x = x+sw;
y = y+sw;
w = w-sw;
h = h - 2*sw;
r = xg::BOX { col=>x, row=>y, wide=>w, high=>h };
r' = xg::BOX { col=>x+w, row=>y, wide=>w, high=>h };
draw_filled_box drawable { box=>r, width=>sw, relief=>rel } slide_shades;
draw_filled_box fd { box=>r', width=>sw, relief=>rel } slide_shades;
};
fun draw_slide ()
=
{ slider_wide = slider_look.thumb / 2;
slider_high = width;
x = (val_to_pt value) - slider_wide;
shadow_width = max (1, border_thickness / 2);
y = y + border_thickness;
relief = down ?? wg::SUNKEN
:: wg::RAISED;
r = xg::BOX { col=>x, row=>y, wide=> 2*slider_wide, high=>slider_high };
draw_box drawable { box=>r, width=>border_thickness, relief } slide_shades;
draw_inset (x, y, slider_wide, slider_high, shadow_width, relief);
};
if do_all
#
box = xg::BOX
{ col=>offset,
row=>y,
wide=>wide - 2*offset,
high=> width + 2*border_thickness
};
draw_box drawable { box, width=>border_thickness, relief=>wg::SUNKEN } shades;
else
box = xg::BOX
{ col=>offset+border_thickness,
row=>y+border_thickness,
wide=>wide - 2*(border_thickness+offset),
high=> width
};
xc::clear_box drawable box;
fi;
draw_slide ();
};
fun draw ((value, active, ready, down), do_all)
=
{ if do_all init_window (); fi;
if slider_look.show_value draw_value (value, do_all); fi;
draw_slider (value, ready, down, do_all);
if do_all draw_border (offset, drawable, wide, high, slider_look); fi;
};
draw;
};
exception BAD_RANGE;
fun pt_to_val (size, slider_look: Slider_Look)
=
{ slider_look -> { is_vertical, thumb, border_thickness, offset, from_v, to_v, ... };
size -> xg::SIZE { wide, high };
l = if is_vertical high; else wide;fi;
range = l - thumb - 2*(offset + border_thickness);
prange = real range;
inset = thumb / 2 + offset + border_thickness;
rrange = real (to_v-from_v);
fun make_var v
=
{ value = min (max (0, v - inset), range);
tmp = ((real value)*rrange)//prange + (real from_v);
trunc (if (tmp < 0.0 ) tmp - 0.5; else tmp + 0.5;fi);
};
if (range <= 0) fn _ = raise exception BAD_RANGE;
elif is_vertical fn (xg::POINT { row, ... } ) = make_var row;
else fn (xg::POINT { col, ... } ) = make_var col;
fi;
};
fun size_preference_thunk_of (slider_look: Slider_Look)
=
if slider_look.is_vertical vbounds_of slider_look;
else hbounds_of slider_look;
fi;
fun drawf (arg as (_, _, slider_look: Slider_Look))
=
if slider_look.is_vertical vdrawf arg;
else hdrawf arg;
fi;
}; # package slider_look
end;