## slider-look.pkg
#
# Slider views.
# Compiled by:
# src/lib/x-kit/widget/xkit-widget.sublibstipulate#
# include package geometry2d; # geometry2d is from src/lib/std/2d/geometry2d.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 g2d = geometry2d; # geometry2d is from src/lib/std/2d/geometry2d.pkg #
package d3 = three_d; # three_d is from src/lib/x-kit/widget/old/lib/three-d.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.pkgherein
package slider_look
: (weak) Slider_Look # Slider_Look is from src/lib/x-kit/widget/old/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)
=>
{ ((xc::text_extents font s).overall_info)
->
xc::CHAR_INFO { left_bearing=>lb, right_bearing=>rb, ... };
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;
#
((xc::text_extents font s).overall_info)
->
xc::CHAR_INFO { left_bearing=>lb, right_bearing=>rb, ... };
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, # Show current value of slider as text?
#
fontinfo: (xc::Font, Int, Int),
relief: wg::Relief,
#
border_thickness: Int,
from_v: Int, # Leftmost slider value.
length: Int,
#
label: Null_Or( (String, Int, Int) ), # String label for slider. The two int values x size of string as lb,rb == leftbearing,rightbearing from xc::text_extents -- see make_label.
#
shades: wg::Shades, # Default shades for slider.
ready_shades: wg::Shades,
slide_shades: wg::Shades,
#
thumb: Int, # thumb length in pixels.
tick: Int, # I think this is pixels-between-tick-marks.
to_v: Int, # Rightmost slider value.
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) \\ v = to_v < v;
else \\ 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 ), # Gutter length in pixels.
(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 ), # Thumb length in pixels.
(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);
(make_font_info font)
->
fontinfo as (font, font_ascent, _);
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
+ (slider_look.tick != 0 ?? line_high :: 0)
+ (slider_look.show_value ?? line_high + spacing :: 0)
+ (slider_look.label != NULL ?? line_high :: 0)
;
size_preferences
=
{ col_preference => wg::loose_preference (x+bw2),
row_preference => wg::tight_preference y
};
\\ () = 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 = slider_look.tick != 0 ?? tick_width :: 0;
value_width = slider_look.show_value ?? tick_width :: 0;
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
};
\\ () = size_preferences;
};
fun val_to_pt (size, slider_look: Slider_Look) # Return fn mapping value to pixel position for thumb.
=
{ slider_look -> { is_vertical, thumb, border_thickness, offset, from_v, to_v, ... };
#
size -> { wide, high };
range = float (to_v - from_v);
prange = (is_vertical ?? high :: wide) # "prange" == "pixel_range" -- number of pixels slider can move through...?
- thumb - 2*(offset + border_thickness);
rprange = float prange;
off = thumb/2 + offset + border_thickness; # Left/bottom limit of thumb motion, as pixel coordinate.
if (range == 0.0)
#
\\ _ = off;
else
\\ value
=
{ y = trunc((float (value - from_v) * rprange)/range + 0.5);
#
y = if (y < 0 ) 0;
elif (y > prange) prange;
else y;
fi;
y + off;
};
fi;
};
fun draw_border (0, _, _, _, _) # This appears to actually draw the gutter in which the slider moves.
=>
();
draw_border (bw, d, wide, high, slider_look: Slider_Look)
=>
{ r = { 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;
# Draw one tickmark on a vertical slider, labelled by its numeric value -- called by draw_ticks().
# Also used to draw current value of slider, at upperright of vertical slider.
fun draw_vvalue # Convert int 'value' to string and draw it right-justified (i.e., ending at column 'right').
(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;
((xc::text_extents font string).overall_info)
->
xc::CHAR_INFO { right_bearing, ascent, descent, ... };
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 ({ col=>x, row=>y }, string);
};
# Draw one tickmark on a horizontal slider, labelled by its numeric value -- called by draw_ticks().
fun draw_hvalue # Convert int 'value' to string and draw it right-justified
(val_to_pt, wide, dr, pen, slider_look: Slider_Look)
(value, bottom)
=
{ slider_look.fontinfo -> (font, _, font_descent);
#
string = int_to_string value;
((xc::text_extents font string).overall_info)
->
xc::CHAR_INFO { left_bearing=>lb, right_bearing=>rb, ... };
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 ({ col=>x, row=>y }, string);
};
fun vdrawf (window, size as { wide, high }, slider_look: Slider_Look)
=
draw
where
# include package 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 # Figure horizontal pixels taken by slider title.
THE(_, lb, rb) => rb - lb + font_ascent; # " + font_ascent" ???
NULL => 0;
esac;
tick_width = slider_look.tick_width; # Horizontal pixels taken by a tickmark.
tick_wide = slider_look.tick != 0 ?? tick_width :: 0;
value_wide = slider_look.show_value ?? tick_width :: 0; # Are we assuming values have same horizontal pixels as a tickmark...??
# Layout consists of four columns. Left-to-right:
# 1: Tickmarks with numeric labels above them.
# 2: Current value of slider, written to left of slider.
# 3: Gutter with thumb sliding up and down in it.
# 4: Title ("label") for widget.
# Compute total width of all the stuff
# we're committed to drawing:
#
total = tick_wide # Leftmost is tickmark.
+ value_wide # Next numeric value for thumb written to left of thumb.
+ 2 * (border_thickness+spacing) # Next come the two sides of the gutter and between them
+ slider_look.width # the thumb.
+ label_wide # Rightmost is title ("label") for the slider widget.
;
# We'll center our stuff in the available space:
#
tick_right = (wide - total) / 2 + tick_wide; # Figure column in which ticks end. Total left-over pixels for margin are (wide-total); we'll put half on the left and half on the right.
value_right = tick_right + value_wide; # Figure column in which numeric label for thumb ends.
scale_left = value_right + spacing; # We'll draw the gutter 'spacing' pixels to the right of the thumb-value column.
label_left = scale_left + 2*border_thickness # The thumb is slider_look.width pixels wide, with on each side of it border_thickness pixels of gutter box.
+ slider_look.width + (font_ascent / 2); # We'll draw the slider title/label font_ascent/2 pixels to right of gutter.
fun draw_ticks 0 # Draw referece tickmarks along the slider, labelled with their values right above them.
=>
();
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) \\ v = to_v < v;
else \\ 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 the text title for the slider at upper-right.
=>
();
draw_label (THE (string, _, _))
=>
{ col = label_left;
row = offset + (3*font_ascent) / 2;
xc::draw_transparent_string drawable text_pen font ({ col, row }, string);
};
end;
fun draw_value (value, dont_erase) # Draw current numeric value of slider to left of slider.
=
{ if (not dont_erase)
#
box = { col=> value_right - value_wide, wide=> value_wide,
row=> offset, 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 ticks and title -- they never change.
draw_label slider_look.label;
};
fun draw_slider (value, ready, down, do_all)
=
{ include package three_d;
#
width = slider_look.width; # Width-in-pixels of thumb.
border_thickness = slider_look.border_thickness; # Width-in-pixels of gutter wall.
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) # Draw two smaller islands inside the thumb to give it some texture.
=
{ x = x + sw;
y = y + sw;
h = h - sw;
w = w - 2*sw;
box = { col=>x, row=>y, wide=>w, high=>h };
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 () # Draw the main thumb outline at appropriate spot.
=
{ sht2 = slider_look.thumb / 2; # "sht2" == "1/2 slider height".
swid = width; # "swid" == "slider_width".
col = scale_left + border_thickness; # Start col for thumb.
row = (val_to_pt value) - sht2; # Start row for thumb. Subtracting sht2 puts midpoint of thumb squarely on 'value'-derived pixel.
shadow_width = max (1, border_thickness / 2);
relief = if down wg::SUNKEN; else wg::RAISED;fi; # <============
box = { col, row, wide=>swid, high=>2*sht2 }; # Thumb outline.
draw_box drawable { box, width=>border_thickness, relief } slide_shades; # Draw thumb proper within gutter.
draw_inset (col, row, swid, sht2, shadow_width, relief);
};
if do_all
#
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 = { 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; # Draw ticks and label -- these never change.
#
if slider_look.show_value draw_value (value, do_all); fi; # Draw value of slider as numeric text.
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 { 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;
# Layout here is four rows. Top-to-bottom:
# 1. Title ("label") for slider widget.
# 2. Gutter with thumb sliding in it.
# 3. Value of slider.
# 4. Ticks, with numeric labels.
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) \\ v = to_v < v;
else \\ 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 ({ 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 = { 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 package 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) # Draw two smaller islands inside the thumb to give it some texture.
=
{ x = x+sw;
y = y+sw;
w = w - sw;
h = h - 2*sw;
r = { col=>x, row=>y, wide=>w, high=>h };
r' = { 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 () # Draw the main thumb outline at appropriate spot.
=
{ slider_wide2 = slider_look.thumb / 2; # Half of the full thumb length. Useful for putting the middle of thumb exactly on value-appropriate pixel.
slider_high = width;
x = (val_to_pt value) - slider_wide2; # Where to put middle of thumb.
shadow_width = max (1, border_thickness / 2);
y = y + border_thickness;
relief = down ?? wg::SUNKEN
:: wg::RAISED;
r = { col=>x, row=>y, wide=> 2*slider_wide2, high=>slider_high };
draw_box drawable { box=>r, width=>border_thickness, relief } slide_shades; # Draw main outline of thumb.
draw_inset (x, y, slider_wide2, slider_high, shadow_width, relief); # Draw two islands within thumb to provide texture.
};
if do_all
#
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 = { 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 -> { wide, high };
l = is_vertical ?? high :: wide;
range = l - thumb - 2*(offset + border_thickness);
prange = float range;
inset = thumb / 2 + offset + border_thickness;
rrange = float (to_v-from_v);
fun make_var v
=
{ value = min (max (0, v - inset), range);
tmp = ((float value)*rrange)/prange + (float from_v);
trunc (if (tmp < 0.0 ) tmp - 0.5; else tmp + 0.5;fi);
};
if (range <= 0) \\ _ = raise exception BAD_RANGE;
elif is_vertical \\ ({ row, ... }: g2d::Point) = make_var row;
else \\ ({ col, ... }: g2d::Point) = 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 make_slider_drawfn (arg as (_, _, slider_look: Slider_Look))
=
if slider_look.is_vertical vdrawf arg;
else hdrawf arg;
fi;
}; # package slider_look
end;