## widget-theme-imp.pkg
#
# For the big picture see the imp dataflow diagrams in
#
# src/lib/x-kit/xclient/src/window/xclient-ximps.pkg#
# Compiled by:
# src/lib/x-kit/widget/xkit-widget.sublibstipulate
include package threadkit; # threadkit is from src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.pkg #
# package ap = client_to_atom; # client_to_atom is from src/lib/x-kit/xclient/src/iccc/client-to-atom.pkg# package au = authentication; # authentication is from src/lib/x-kit/xclient/src/stuff/authentication.pkg# package cpm = cs_pixmap; # cs_pixmap is from src/lib/x-kit/xclient/src/window/cs-pixmap.pkg# package cpt = cs_pixmat; # cs_pixmat is from src/lib/x-kit/xclient/src/window/cs-pixmat.pkg# package dy = display; # display is from src/lib/x-kit/xclient/src/wire/display.pkg# package xet = xevent_types; # xevent_types is from src/lib/x-kit/xclient/src/wire/xevent-types.pkg# package w2x = windowsystem_to_xserver; # windowsystem_to_xserver is from src/lib/x-kit/xclient/src/window/windowsystem-to-xserver.pkg# package fil = file__premicrothread; # file__premicrothread is from src/lib/std/src/posix/file--premicrothread.pkg# package fti = font_index; # font_index is from src/lib/x-kit/xclient/src/window/font-index.pkg# package r2k = xevent_router_to_keymap; # xevent_router_to_keymap is from src/lib/x-kit/xclient/src/window/xevent-router-to-keymap.pkg# package mtx = rw_matrix; # rw_matrix is from src/lib/std/src/rw-matrix.pkg# package rop = ro_pixmap; # ro_pixmap is from src/lib/x-kit/xclient/src/window/ro-pixmap.pkg# package rw = root_window; # root_window is from src/lib/x-kit/widget/lib/root-window.pkg# package rwv = rw_vector; # rw_vector is from src/lib/std/src/rw-vector.pkg# package sep = client_to_selection; # client_to_selection is from src/lib/x-kit/xclient/src/window/client-to-selection.pkg# package shp = shade; # shade is from src/lib/x-kit/widget/lib/shade.pkg# package sj = socket_junk; # socket_junk is from src/lib/internet/socket-junk.pkg# package x2s = xclient_to_sequencer; # xclient_to_sequencer is from src/lib/x-kit/xclient/src/wire/xclient-to-sequencer.pkg# package tr = logger; # logger is from src/lib/src/lib/thread-kit/src/lib/logger.pkg# package tsr = thread_scheduler_is_running; # thread_scheduler_is_running is from src/lib/src/lib/thread-kit/src/core-thread-kit/thread-scheduler-is-running.pkg# package u1 = one_byte_unt; # one_byte_unt is from src/lib/std/one-byte-unt.pkg# package v1u = vector_of_one_byte_unts; # vector_of_one_byte_unts is from src/lib/std/src/vector-of-one-byte-unts.pkg# package v2w = value_to_wire; # value_to_wire is from src/lib/x-kit/xclient/src/wire/value-to-wire.pkg# package wg = widget; # widget is from src/lib/x-kit/widget/old/basic/widget.pkg# package wi = window; # window is from src/lib/x-kit/xclient/src/window/window.pkg# package wme = window_map_event_sink; # window_map_event_sink is from src/lib/x-kit/xclient/src/window/window-map-event-sink.pkg# package wpp = client_to_window_watcher; # client_to_window_watcher is from src/lib/x-kit/xclient/src/window/client-to-window-watcher.pkg# package wy = widget_style; # widget_style is from src/lib/x-kit/widget/lib/widget-style.pkg# package e2s = xevent_to_string; # xevent_to_string is from src/lib/x-kit/xclient/src/to-string/xevent-to-string.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 xj = xsession_junk; # xsession_junk is from src/lib/x-kit/xclient/src/window/xsession-junk.pkg# package xt = xtypes; # xtypes is from src/lib/x-kit/xclient/src/wire/xtypes.pkg# package xtr = xlogger; # xlogger is from src/lib/x-kit/xclient/src/stuff/xlogger.pkg #
package gtg = guiboss_to_guishim; # guiboss_to_guishim is from src/lib/x-kit/widget/theme/guiboss-to-guishim.pkg #
package psi = widgetspace_imp; # widgetspace_imp is from src/lib/x-kit/widget/space/widget/widgetspace-imp.pkg #
package gd = gui_displaylist; # gui_displaylist is from src/lib/x-kit/widget/theme/gui-displaylist.pkg package gt = guiboss_types; # guiboss_types is from src/lib/x-kit/widget/gui/guiboss-types.pkg package c64 = rgb; # Colors with Float64 red-green-blue values. # rgb is from src/lib/x-kit/xclient/src/color/rgb.pkg package c8 = rgb8; # Colors with Unt8 red-green-blue values. # rgb8 is from src/lib/x-kit/xclient/src/color/rgb8.pkg #
package g2d = 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 sfp = sfprintf; # sfprintf is from src/lib/src/sfprintf.pkg package evt = gui_event_types; # gui_event_types is from src/lib/x-kit/widget/gui/gui-event-types.pkg package gtg = guiboss_to_guishim; # guiboss_to_guishim is from src/lib/x-kit/widget/theme/guiboss-to-guishim.pkg nb = log::note_on_stderr; # log is from src/lib/std/src/log.pkg tracefile = "widget-unit-test.trace.log";
herein
package widget_theme_imp
: Widget_Theme_Imp # Widget_Theme_Imp is from src/lib/x-kit/widget/theme/widget/widget-theme-imp.api {
#
include package widget_theme; # widget_theme is from src/lib/x-kit/widget/theme/widget/widget-theme.pkg #
Theme_State = Ref( Void ); # Holds all nonephemeral mutable state maintained by skin.
Imports = { # Ports we use, provided by other imps.
int_sink: Int -> Void,
guiboss_to_guishim: gtg::Guiboss_To_Guishim
};
Me_Slot = Mailslot( { imports: Imports,
me: Theme_State,
run_gun': Run_Gun,
end_gun': End_Gun
}
);
Exports = { # Ports we provide for use by other imps.
theme: Widget_Theme
};
Option = MICROTHREAD_NAME String; #
Widget_Theme_Egg = Void -> (Exports, (Imports, Run_Gun, End_Gun) -> Void);
Runstate = { # These values will be statically globally visible throughout the code body for the imp.
me: Theme_State, #
imports: Imports, # Imps to which we send requests.
to: Replyqueue, # The name makes foo::pass_something(imp) to {. ... } syntax read well.
end_gun': End_Gun # We shut down the microthread when this fires.
};
Theme_Q = Mailqueue( Runstate -> Void );
fun get__guiboss_to_hostwindow (theme: Widget_Theme)
=
case *theme.guiboss_to_hostwindow
#
THE g => g;
#
NULL => { msg = "font functions called before guiboss_to_hostwindow available!";
log::fatal msg;
raise exception DIE msg;
};
esac;
fun run ( theme_q: Theme_Q, #
#
runstate as
{ # These values will be statically globally visible throughout the code body for the imp.
me: Theme_State, #
imports: Imports, # Imps to which we send requests.
to: Replyqueue, # The name makes foo::pass_something(imp) to {. ... } syntax read well.
end_gun': End_Gun # We shut down the microthread when this fires.
}
)
=
loop ()
where
fun loop () # Outer loop for the imp.
=
{ do_one_mailop' to [
#
(end_gun' ==> shut_down_theme_imp'),
(take_from_mailqueue' theme_q ==> do_theme_plea)
];
loop ();
}
where
fun do_theme_plea thunk
=
thunk runstate;
fun shut_down_theme_imp' ()
=
{
thread_exit { success => TRUE }; # Will not return.
};
end;
end;
fun startup (reply_oneshot: Oneshot_Maildrop( (Me_Slot, Exports) )) () # Root fn of imp microthread. Note currying.
=
{ me_slot = make_mailslot () : Me_Slot;
#
# Functions like text_color refer to widget_theme
# but widget_theme also refers to them. We break
# the cycle via a four-step dance:
#
# 1) Define dummy fns.
# 2) Define widget_theme in terms of them.
# 3) Define real fns in terms of widget_theme.
# 4) Plug the real fns into widget_theme, replacing the dummy fns.
#
# Here are the dummies:
#
text_color = REF (\\ _ = c64::white);
textfield_color = REF (\\ _ = c64::white);
#
surround_color = REF (\\ _ = c64::white);
#
body_color = REF (\\ _ = c64::white);
body_color_with_mousefocus = REF (\\ _ = c64::white);
body_color_when_on = REF (\\ _ = c64::white);
body_color_when_on_with_mousefocus = REF (\\ _ = c64::white);
#
sunny_bevel_color = REF (\\ _ = c64::white);
shady_bevel_color = REF (\\ _ = c64::white);
#
current_gadget_colors = REF (\\ _ = { text_color => c64::white,
surround_color => c64::white,
body_color => c64::white,
#
upperleft_bevel_color => c64::white,
lowerright_bevel_color => c64::white
}
);
pictureframe = REF (\\ _ = \\ _ = []: gd::Gui_Displaylist);
filled_pictureframe = REF (\\ _ = \\ _ = []: gd::Gui_Displaylist);
rounded_pictureframe = REF (\\ _ = \\ _ = []: gd::Gui_Displaylist);
polygon3d = REF (\\ _ = \\ _ = []: gd::Gui_Displaylist);
guiboss_to_hostwindow = REF (NULL: Null_Or(gtg::Guiboss_To_Hostwindow));
#
stipulate
dummy_font = { id => id_zero,
font_height => { ascent => 0, descent => 0 },
string_length_in_pixels => (\\ (s: String) = 0)
};
herein
get_roman_fontname = REF (\\ (pointsize: Int) = ""); # Dummy fn, will be replaced momentarily below.
get_italic_fontname = REF (\\ (pointsize: Int) = ""); # Dummy fn, will be replaced momentarily below.
get_bold_fontname = REF (\\ (pointsize: Int) = ""); # Dummy fn, will be replaced momentarily below.
#
get_roman_font = REF (\\ (pointsize: Int) = dummy_font); # Dummy fn, will be replaced momentarily below.
get_italic_font = REF (\\ (pointsize: Int) = dummy_font); # Dummy fn, will be replaced momentarily below.
get_bold_font = REF (\\ (pointsize: Int) = dummy_font); # Dummy fn, will be replaced momentarily below.
end;
# A few widget_theme fns don't refer to widget_theme,
# so we can define the real versions of them before
# defining widget_theme:
fun slight_blackening (color: c64::Rgb) = c64::rgb_mix01 (0.9, c64::black, color); # PUBLIC.
fun medium_blackening (color: c64::Rgb) = c64::rgb_mix01 (0.5, c64::black, color); # PUBLIC.
fun lavish_blackening (color: c64::Rgb) = c64::rgb_mix01 (0.3, c64::black, color); # PUBLIC.
fun slight_graying (color: c64::Rgb) = c64::rgb_mix01 (0.9, c64::gray, color); # PUBLIC.
fun medium_graying (color: c64::Rgb) = c64::rgb_mix01 (0.5, c64::gray, color); # PUBLIC.
fun lavish_graying (color: c64::Rgb) = c64::rgb_mix01 (0.3, c64::gray, color); # PUBLIC.
fun slight_whitening (color: c64::Rgb) = c64::rgb_mix01 (0.9, c64::white, color); # PUBLIC.
fun medium_whitening (color: c64::Rgb) = c64::rgb_mix01 (0.5, c64::white, color); # PUBLIC.
fun lavish_whitening (color: c64::Rgb) = c64::rgb_mix01 (0.3, c64::white, color); # PUBLIC.
fun color_by_depth # This fn is an alternative to drop shadows, which are hard to do cleanly with just the original X drawops.
( # The idea is that the eye interprets dimmer and bluer as more distant, so by making each layer of popup
color: c64::Rgb, # successively brighter and warmer in color, we can make them look nearer than their parent guipane.
popup_nesting_depth: Int # The effect is deliberately toned down enough to be nearly subliminal.
)
=
warm_and_brighten_n_times (color, popup_nesting_depth)
where
fun warm_and_brighten ({ red, green, blue })
=
{ red = red * 0.9 + 0.1; # Move red value 10% of way to 100% red.
green = green * 0.95 + 0.05; # Move green value 5% of way to 100% green.
blue = blue * 1.0 + 0.0; # Move blue value 0% of way to 50% blue.
{ red, green, blue };
};
fun warm_and_brighten_n_times (color, 0)
=>
color;
warm_and_brighten_n_times (color, d)
=>
warm_and_brighten_n_times (warm_and_brighten(color), d - 1);
end;
end;
theme = { # We'll rename this to widget_theme later, for now a shorter name is nice.
do_something,
#
base_color => REF { red => 0.78, # Nice light gray background for GUI, initially a little bluish, getting warmer in color as we ascend the popup hierarchy.
green => 0.80,
blue => 0.82
},
text_color, # Dummy fn.
textfield_color, # Dummy fn.
surround_color, # Dummy fn.
#
body_color, # Dummy fn.
body_color_with_mousefocus, # Dummy fn.
body_color_when_on, # Dummy fn.
body_color_when_on_with_mousefocus, # Dummy fn.
#
sunny_bevel_color, # Dummy fn.
shady_bevel_color, # Dummy fn.
current_gadget_colors, # Dummy fn.
pictureframe, # Dummy fn.
filled_pictureframe, # Dummy fn.
rounded_pictureframe, # Dummy fn.
polygon3d, # Dummy fn.
#
slight_blackening => REF slight_blackening, # Real fn.
medium_blackening => REF medium_blackening, # Real fn.
lavish_blackening => REF lavish_blackening, # Real fn.
#
slight_graying => REF slight_graying, # Real fn.
medium_graying => REF medium_graying, # Real fn.
lavish_graying => REF lavish_graying, # Real fn.
#
slight_whitening => REF slight_whitening, # Real fn.
medium_whitening => REF medium_whitening, # Real fn.
lavish_whitening => REF lavish_whitening, # Real fn.
#
color_by_depth => REF color_by_depth, # Real fn.
default_font_size => REF 13,
# I found these font triples in use in Reppy+Gansner's 1990-era
# CML+eXene codebase. These days there may be better choices.
# Feel free to research and improve: -- 2014-12-29 CrT
# roman_font_spex => REF "-adobe-times-medium-r-normal--*-%d-*-*-p-*-iso8859-1",
# italic_font_spex => REF "-adobe-times-medium-i-normal--*-%d-*-*-p-*-iso8859-1",
# bold_font_spex => REF "-adobe-times-bold-r-normal--*-%d-*-*-p-*-iso8859-1",
# roman_font_spex => REF "-*-courier-medium-r-*-*-%d-*-*-*-*-*-*",
# italic_font_spex => REF "-*-courier-medium-o-*-*-%d-*-*-*-*-*-*",
# bold_font_spex => REF "-*-courier-bold-r-*-*-%d-*-*-*-*-*-*",
# roman_font_spex => REF "-adobe-helvetica-medium-r-normal--*-*-%d-*-*-*-*-*",
# italic_font_spex => REF "-adobe-helvetica-medium-o-normal--*-*-%d-*-*-*-*-*",
# bold_font_spex => REF "-adobe-helvetica-bold-r-normal--*-*-%d-*-*-*-*-*",
# To work with modern scalable fonts (recognisable by
# zeros in the seventh, eight and twelfth fields),
#
# http://menehune.opt.wfu.edu/Kokua/Irix_6.5.21_doc_cd/usr/share/Insight/library/SGI_bookshelves/SGI_Developer/books/XLib_PG/sgi_html/apa.html
#
# recommends using strings like
#
# -*-helvetica-medium-r-*-*-*-120-75-75-*-*-iso8859-1 # Normal font
# -*-helvetica-bold-r-*-*-*-120-75-75-*-*-iso8859-1 # Bold font
# -*-helvetica-medium-i-*-*-*-120-75-75-*-*-iso8859-1 # Italic font ("o" for "oblique" is also italic)
#
# where '120'== pointsize*10 and the two 75s are respectively
# horizontal and vertical screen resolution in dpi.
#
# Useful variants:
#
# -*-helvetica-medium-r-*-*-*-120-75-75-m-*-iso8859-1 # Monospace fonts only.
# -*-helvetica-medium-r-*-*-*-120-75-75-p-*-iso8859-1 # Proportional fonts only.
# -*-helvetica-medium-r-*-*-*-120-75-75-c-*-iso8859-1 # Constant-width "cell" fonts only -- "typewriter spacing".
#
# -*-helvetica-medium-r-*-*-*-120-75-75-c-*-iso10646-1 # Unicode font.
#
# Currently focus is on scalable typewriter utf-8 fonts:
#
# -misc-fixed-medium-r-normal--0-0-75-75-c-0-iso10646-1
# -misc-fixed-medium-o-normal--0-0-75-75-c-0-iso10646-1
# -misc-fixed-bold-r-normal--0-0-75-75-c-0-iso10646-1
#
# -misc-fixed-medium-r-normal-ja-0-0-75-75-c-0-iso10646-1
#
# -misc-fixed-bold-r-semicondensed--0-0-75-75-c-0-iso10646-1
# -misc-fixed-medium-o-semicondensed--0-0-75-75-c-0-iso10646-1
#
# -misc-fixed-medium-r-normal--0-0-100-100-c-0-iso10646-1
# -misc-fixed-bold-r-normal--0-0-100-100-c-0-iso10646-1
#
# -misc-fixed-medium-r-normal-ja-0-0-100-100-c-0-iso10646-1
# -misc-fixed-medium-r-normal-ko-0-0-100-100-c-0-iso10646-1
#
roman_font_spex => REF "-misc-fixed-medium-r-normal-*-*-%d-75-75-c-*-iso10646-1",
italic_font_spex => REF "-misc-fixed-medium-o-normal-*-*-%d-75-75-c-*-iso10646-1",
bold_font_spex => REF "-misc-fixed-bold-r-normal-*-*-%d-75-75-c-*-iso10646-1",
# I've also experimented with these triples:
# roman_font_spex => REF "lucidasans-%d",
# italic_font_spex => REF "lucidasans-italic-%d",
# bold_font_spex => REF "lucidasans-bold-%d",
# roman_font_spex => REF "lucidasanstypewriter-%d",
# italic_font_spex => REF "lucidasanstypewriter-italic-%d",
# bold_font_spex => REF "lucidasanstypewriter-bold-%d",
#
get_roman_fontname,
get_italic_fontname,
get_bold_fontname,
#
get_roman_font,
get_italic_font,
get_bold_font,
guiboss_to_hostwindow
# dummy_make_button_displaylist
};
#######################################################################
# Time to define the real versions of the above dummy fns:
#
fun text_color (d: Int) # My current thought here is that text usually
= # looks best in either black or white, so if
if (c64::rgb_is_light ((*theme.body_color)(d))) c64::black; # the widget body color is light use black
else c64::white; # otherwise use white.
fi; #
fun textfield_color (d: Int) # All through here 'd'=='popup_nesting_depth'.
=
if (c64::rgb_is_light (*theme.text_color d)) { red => 0.1, green => 0.1, blue => 0.1 };
else { red => 0.9, green => 0.9, blue => 0.9 };
fi;
fun surround_color (d: Int) = *theme.color_by_depth (*theme.base_color, d); # NB: We make it so that app programmer can change just base_color
# (or just surround_color) and have the other colors change reasonably.
fun body_color (d: Int) = *theme.surround_color d; #
fun body_color_when_on (d: Int) = rgb::rgb_mix01 (0.7, *theme.surround_color d, rgb::white);
#
fun body_color_with_mousefocus (d: Int) = rgb::rgb_scale (1.05, *theme.body_color d); # 5% brighter than body_color.
fun body_color_when_on_with_mousefocus (d: Int) = rgb::rgb_scale (1.05, *theme.body_color_when_on d); # 5% brighter than body_color_when_on.
fun sunny_bevel_color (d: Int) = *theme.lavish_whitening (*theme.surround_color d);
fun shady_bevel_color (d: Int) = *theme.lavish_blackening (*theme.surround_color d);
fun current_gadget_colors # Compute appropriate gadget colors based on mode and on/off status.
{ # This avoids duplicating this logic in every button etc and provides
gadget_is_on: Bool, # a central place for customizing these decisions.
#
gadget_mode => gadget as
{
is_active: Bool, # An inactive gadget is passed no user input. Inactive widgets are typically drawn "grayed-out".
has_mouse_focus: Bool, # A widget which has the mouse cursor on it may want to draw itself brigher or such.
has_keyboard_focus: Bool # A widget which has the keyboard focus will often draw a black outline around its text-entry rectangle.
} : gt::Gadget_Mode,
popup_nesting_depth: Int, # 0 for gadgets on basewindow, 1 for gadgets on popup on basewindow, 2 for gadgets on popup on popup, etc.
#
body_color: Null_Or( c64::Rgb ), # These four values allow per-widget overrides of the theme colors via
body_color_when_on: Null_Or( c64::Rgb ), # widget::BODY_COLOR (etc) Option values. They will typically be NULL:
body_color_with_mousefocus: Null_Or( c64::Rgb ), # most widgets will just let body colors default to the theme settings.
body_color_when_on_with_mousefocus: Null_Or( c64::Rgb ) #
}
=
{
d = popup_nesting_depth;
# Get our base colors from the theme:
#
surround_color = *theme.surround_color d;
text_color = *theme.text_color d;
sunny_bevel_color = *theme.sunny_bevel_color d;
shady_bevel_color = *theme.shady_bevel_color d;
text_color = if gadget.is_active text_color; # NB: 'active' is designed in but not tested or even(?) fully implemented.
else *theme.lavish_graying text_color; # Gray out inactive widget.
fi;
# Typically the body of a (for example) button widget
# will have different colors when it is ON vs OFF,
# plus it will brighten 5% when the mouse is over it,
# just to let the end user know that it is live.
#
# Also, typically the body colors come from the theme,
# but we allow the app programmer to override them,
# so that (e.g.) a stop/go switch can be red vs green.
#
# If widget is not 'active' (mouse-responsive) we signal
# that by graying its text (above) and here by setting
# it not to light up on mouse-over.
#
# Here we implement the above by:
#
# o Making body_color key on 'gadget_is_on' + 'gadget.has_mouse_focus'.
#
# o Giving per-widget colors precedence over theme colors.
#
# o Making the "_with_mousefocus" colors default to 5% brighter
# than the corresponding non-"_with_mousefocus" colors
# if the app programmer specified ON and/or OFF colors
# but not _with_mousefocus variants of them.
#
body_color = if (gadget.is_active)
#
case (gadget_is_on, gadget.has_mouse_focus)
#
(FALSE, TRUE ) => case body_color_with_mousefocus THE c => c; NULL => case body_color THE c => rgb::rgb_scale (1.05, c); NULL => *theme.body_color_with_mousefocus d; esac; esac;
(TRUE , TRUE ) => case body_color_when_on_with_mousefocus THE c => c; NULL => case body_color_when_on THE c => rgb::rgb_scale (1.05, c); NULL => *theme.body_color_when_on_with_mousefocus d; esac; esac;
#
(FALSE, FALSE) => case body_color THE c => c; NULL => *theme.body_color d; esac;
(TRUE , FALSE) => case body_color_when_on THE c => c; NULL => *theme.body_color_when_on d; esac;
esac;
else
case gadget_is_on
#
FALSE => case body_color THE c => c; NULL => *theme.body_color d; esac;
TRUE => case body_color_when_on THE c => c; NULL => *theme.body_color_when_on d; esac;
esac;
fi;
my ( upperleft_bevel_color,
lowerright_bevel_color
)
=
if gadget_is_on (shady_bevel_color, sunny_bevel_color); # Make button look pressed.
else (sunny_bevel_color, shady_bevel_color); # Make button look popped.
fi;
{ surround_color,
body_color,
text_color,
#
upperleft_bevel_color,
lowerright_bevel_color
} : Gadget_Palette;
};
stipulate
fun make_pictureframe # Used by pictureframe for FLAT, RAISED and SUNKEN.
(
upperleft_bevel_color: c64::Rgb,
lowerright_bevel_color: c64::Rgb,
thick: Int,
box as { col, row, wide, high }: g2d::Box
)
=
{
thick2 = thick*2;
if (wide < thick2
or high < thick2)
#
[];
else
point_1 = { col, row => row+high }; #
point_2 = { col, row }; # 2 3
point_3 = { col => col+wide, row }; # 5 4
point_4 = { col => col+wide-thick, row => row+thick }; #
point_5 = { col => col+thick, row => row+thick }; #
point_6 = { col => col+thick, row => row+high-thick }; # 6 7
point_7 = { col => col+wide-thick, row => row+high-thick }; # 1 8
point_8 = { col => col+wide, row => row+high };
upper_left_points
=
[ point_1, # Clockwise order. (Is this the convention?)
point_2,
point_3,
point_4,
point_5,
point_6,
point_1
];
lower_right_points
=
[ point_1, # Clockwise order again.
point_6,
point_7,
point_4,
point_3,
point_8,
point_1
];
[ gd::COLOR ( upperleft_bevel_color, [ gd::FILLED_POLYGON upper_left_points ] ),
gd::COLOR ( lowerright_bevel_color, [ gd::FILLED_POLYGON lower_right_points ] )
];
fi;
};
fun make_pictureframe' # Used by pictureframe for GROOVE and RIDGE.
(
upperleft_bevel_color: c64::Rgb,
lowerright_bevel_color: c64::Rgb,
thick: Int,
outerbox as { col, row, wide, high }: g2d::Box
)
=
{ inner_thick = thick / 2;
outer_thick = thick - inner_thick; # NB: If thick is odd, we'll have outer_thick == inner_thick + 1.
innerbox
=
{ col => col + outer_thick,
row => row + outer_thick,
#
wide => wide - outer_thick * 2,
high => high - outer_thick * 2
};
outer = make_pictureframe ( upperleft_bevel_color, lowerright_bevel_color, outer_thick, outerbox );
inner = make_pictureframe (lowerright_bevel_color, upperleft_bevel_color, inner_thick, innerbox );
outer @ inner;
};
fun make_rounded_pictureframe # Used by rounded_pictureframe for FLAT, RAISED and SUNKEN.
#
( upperleft_bevel_color: c64::Rgb,
lowerright_bevel_color: c64::Rgb,
thick: Int,
corner_high: Int,
corner_wide: Int,
{ col, row, wide, high }: g2d::Box
)
=
{
halfthick = thick / 2;
col = col + halfthick;
row = row + halfthick;
wide' = wide - 2*halfthick;
high' = high - 2*halfthick;
stipulate
#
cw2 = corner_wide*2;
ch2 = corner_high*2;
herein
my (ew, ew2) = if (cw2 > wide') (0, 0); else (corner_wide, cw2); fi;
my (eh, eh2) = if (ch2 > high') (0, 0); else (corner_high, ch2); fi;
end;
[ gd::LINE_THICKNESS
(
thick,
[
# XXX BUGGO FIXME This stuff is all wrong at the moment:
gd::COLOR ( upperleft_bevel_color, # ARC # ORIGIN # SHAPE
[ gd::ARCS [ # =============== # ============== # =========
{ col=> col, row=> row, wide=> ew2, high=> eh2, start_angle=> 180.0, fill_angle=> -90.0 }, # Topleft # topleft # corner
{ col=> col+ew, row=> row, wide=> wide' - ew2, high=> 0, start_angle=> 180.0, fill_angle=> -180.0 }, # Tophalf # topleft + ew # horizontal
{ col=> col, row=> row+eh, wide=> 0, high=> high' - eh2, start_angle=> 270.0, fill_angle=> -180.0 }, # All but topleft # topleft + eh # vertical
{ col=> col+wide' - ew2, row=> row, wide=> ew2, high=> eh2, start_angle=> 45.0, fill_angle=> 45.0 }, # Full circle # topright - ew2 # corner
{ col=> col, row=> row+high' - eh2, wide=> ew2, high=> eh2, start_angle=> 225.0, fill_angle=> -45.0 } # Top quarter # botleft - eh2 # corner
] ]
),
gd::COLOR ( lowerright_bevel_color, # ARC # ORIGIN # SHAPE
[ gd::ARCS [ # =============== # ============== # =========
{ col=> col+wide' - ew2, row=> row, wide=> ew2, high=> eh2, start_angle=> 45.0, fill_angle=> -45.0 }, # Left 3/4 # topright - ew2 # corner
{ col=> col+wide', row=> row+eh, wide=> 0, high=> high' - eh2, start_angle=> 90.0, fill_angle=> -180.0 }, # Botleft 1/4 # topright + eh # vertical
{ col=> col+wide' - ew2, row=> row+high' - eh2, wide=> ew2, high=> eh2, start_angle=> 0.0, fill_angle=> -90.0 }, # All but topright # botright - 22 # corner
{ col=> col+ew, row=> row+high', wide=> wide' - ew2, high=> 0, start_angle=> 0.0, fill_angle=> -180.0 }, # Bothalf # botleft + ew # horizontal
{ col=> col, row=> row+high' - eh2, wide=> ew2, high=> eh2, start_angle=> 270.0, fill_angle=> -45.0 } # Noon->1:30 # botleft - eh2 # corner
] ]
)
]
)
];
};
fun make_rounded_pictureframe' # Used by rounded_pictureframe for GROOVE and RIDGE.
#
( upperleft_bevel_color: c64::Rgb,
lowerright_bevel_color: c64::Rgb,
thick: Int,
corner_high: Int,
corner_wide: Int,
outerbox as { col, row, wide, high }: g2d::Box
)
=
{ inner_thick = thick / 2;
outer_thick = thick - inner_thick;
innerbox
=
{ col => col + outer_thick,
row => row + outer_thick,
#
wide => wide - outer_thick * 2,
high => high - outer_thick * 2
};
outer = make_rounded_pictureframe ( upperleft_bevel_color, lowerright_bevel_color, outer_thick, corner_wide, corner_high, outerbox);
inner = make_rounded_pictureframe (lowerright_bevel_color, upperleft_bevel_color, inner_thick, corner_wide, corner_high, innerbox);
outer @ inner;
};
stipulate
# The table below is used for a quick approximation in
# computing a new point parallel to a given line
# An index into the table is 128 times the slope of the
# original line (the slope must always be between 0.0
# and 1.0). The value of the table entry is 128 times
# the amount to displace the new line in row for each unit
# of perpendicular distance. In other words, the table
# maps from the tangent of an angle to the inverse of
# its cosine. If the slope of the original line is greater
# than 1, then the displacement is done in col rather than in row.
#
shift_table
=
{ fun compute i
=
{ tangent = (float i) / 128.0;
#
f8b::truncate ((128.0 / math::cos (math::atan tangent)) + 0.5);
};
v = vector::from_fn (129, compute);
\\ i = vector::get (v, i);
};
herein
# Given two points on a line, compute a point on a
# new line that is parallel to the given line and
# a given distance away from it.
#
fun shift_line (p1 as { col, row }, p2, distance)
=
{ fun (<<) (w, i) = unt::to_int (unt::(<<) (unt::from_int w, i));
fun (>>) (w, i) = unt::to_int (unt::(>>) (unt::from_int w, i));
infix my << >>;
(g2d::point::subtract (p2, p1))
->
{ col=>dx, row=>dy };
my (dy, dy_neg) = if (dy < 0) (-dy, TRUE); else (dy, FALSE); fi;
my (dx, dx_neg) = if (dx < 0) (-dx, TRUE); else (dx, FALSE); fi;
fun adjust (dy, dx)
=
if (distance > 0) ((( distance * shift_table((dy << 0u7) / dx)) + 64) >> 0u7);
else -(((-distance * shift_table((dy << 0u7) / dx)) + 64) >> 0u7); # Our >> op won't work with negative numbers, hence the double-negation trick.
fi;
if (dy <= dx )
#
dy = adjust (dy, dx);
{ col, row=> row + (if dx_neg dy; else -dy;fi) };
else
dx = adjust (dx, dy);
{ col=> col + (if dy_neg -dx; else dx;fi), row };
fi;
};
end;
fun last2pts [] => raise exception lib_base::IMPOSSIBLE "three_d::last2Pts";
last2pts [v1, v2] => (v1, v2);
last2pts (v ! vs) => last2pts vs;
end;
#####################################################################
# draw3DPoly draws a polygon of given thickness. The widening occurs
# on the left of the polygon as it is traversed. If the thickness
# is negative, the widening occurs on the right. Duplicate points
# are ignored. If there are less than two distinct points, nothing
# is drawn.
#
# The main loop below (loop2) is executed once for each vertex in
# the polgon. At the beginning of each iteration things get like this:
#
# poly1 /
# * /
# | /
# b1 * poly0
# | |
# | |
# | |
# | |
# | |
# | | p1 p2
# b2 *--------------------*
# |
# |
# *----*--------------------*
# poly2 newb1 newb2
#
# For each interation, we:
# (a) Compute poly2 (the border corner corresponding to p1)
# As part of this process, compute a new b1 and b2 value
# for the next side (p1-p2) of the polygon.
# (b) Draw the polygon (poly0, poly1, poly2, p1)
#
# The above situation doesn't exist until two points have
# been processed. We start with the last two points in the list
# (in loop0) to get an initial b1 and b2. Then, in loop1, we
# use the first point to get a new b1 and b2, with which we
# can calculate an initial poly1 (poly0 is the last point in
# the list). At this point, we can start the main loop.
#
# If two consecutive segments of the polygon are parallel,
# then things get more complex. (See findIntersect).
# Consider the following diagram:
#
# poly1
# *----b1-----------b2------a
# \
# \
# *---------*----------* b
# poly0 p2 p1 /
# /
# --*--------*----c
# newB1 newB2
#
# Instead of using the intersection and p1 as the last two points
# in the polygon and as poly1 and poly0 in the next iteration, we
# use a and b, and b and c, respectively.
#
# Do the computation in three stages:
# 1. Compute a point "perp" such that the line p1-perp
# is perpendicular to p1-p2.
# 2. Compute the points a and c by intersecting the lines
# b1-b2 and newb1-newb2 with p1-perp.
# 3. Compute b by shifting p1-perp to the right and
# intersecting it with p1-p2.
#####################################################################
fun make_polygon3d (_,_,_, [ ]) => []; # Used by polygon3d for FLAT, RAISED and SUNKEN.
make_polygon3d (_,_,_, [_]) => [];
make_polygon3d
( upperleft_bevel_color: c64::Rgb,
lowerright_bevel_color: c64::Rgb,
thick: Int,
points as (i_p ! _)
)
=>
loop0 (p1, p2 ! points)
where
(last2pts points) -> (p1, p2);
fun calc_off_points (v1, v2) # Given (v1,v2) return (b1,b2) parallel to (v1,v2) but offset perpendicularly by 'thick' pixels. Thus, (v1,v2) and (b1,b2) form a rectangle.
=
{
b1 = shift_line (v1, v2, thick);
#
(b1, g2d::point::add (b1, g2d::point::subtract (v2, v1)));
};
fun find_intersect (p1, p2, newb1, newb2, b1, b2)
=
case (g2d::line::intersection ((newb1, newb2), (b1, b2)))
#
THE col => (col, p1, col);
#
NULL =>
(poly2, poly3, c)
where
(g2d::line::rotate_90_degrees_counterclockwise (p1, p2))
->
(_, perp);
#
poly2 = the (g2d::line::intersection ((p1, perp), (b1, b2)));
c = the (g2d::line::intersection ((p1, perp), (newb1, newb2)));
shift1 = shift_line (p1, perp, thick);
shift2 = g2d::point::add (shift1, g2d::point::subtract (perp, p1));
poly3 = the (g2d::line::intersection ((p1, p2), (shift1, shift2)));
end;
esac;
fun draw (p0, p1, p2, p3)
=
{
(g2d::point::subtract (p3, p0))
->
{ col => dx, # We color lines (polygons) "bottom" if pointing into the lower-right halfplane from the origin, else "top".
row => dy #
}; # "top" /
# /
ul = upperleft_bevel_color; # O
lr = lowerright_bevel_color; # / "bottom"
# /
color = if (dx > 0) if (dy <= dx) lr; else ul; fi; #
elif (dy < dx) lr; else ul; fi; # NB: We might reasonably use more colors here. In the original code Reppy+Gansner only
# had 256 colors (colortable size), so they had to economize, but we have 24-bit
gd::COLOR (color, [ gd::FILLED_POLYGON [p0, p1, p2, p3] ]); # color and consequently can use as many as we want/need: we could take inner-product
}; # of polygon normal with lighting vector and interpolate between our two given colors.
fun loop2 (p1,[], b1, b2, poly0, poly1, result) # Main loop. This loop is executed once for each vertex in the input polygon.
=>
if (p1 != i_p)
#
(calc_off_points (p1, i_p)) -> (newb1, newb2);
(find_intersect (p1, i_p, newb1, newb2, b1, b2)) -> (poly2, poly3, _);
result = (draw (poly0, poly1, poly2, poly3)) ! result; #
result;
else
result;
fi;
loop2 (p1, p2 ! points, b1, b2, poly0, poly1, result)
=>
if (p1 == p2)
#
loop2 (p1, points, b1, b2, poly0, poly1, result);
else
(calc_off_points (p1, p2)) -> (newb1, newb2);
(find_intersect (p1, p2, newb1, newb2, b1, b2)) -> (poly2, poly3, c);
result = (draw (poly0, poly1, poly2, poly3)) ! result; #
loop2 (p2, points, newb1, newb2, poly3, c, result);
fi;
end;
fun loop1 (p1,[], _, _) => []; # More initialization.
loop1 (p1, p2 ! points, b1, b2)
=>
if (p1 == p2)
#
loop1 (p1, points, b1, b2);
else
(calc_off_points (p1, p2)) -> (newb1, newb2);
(find_intersect (p1, p2, newb1, newb2, b1, b2)) -> (poly2, poly3, c);
loop2 (p2, points, newb1, newb2, poly3, c, []);
fi;
end;
fun loop0 (_,[]) => []; # Initialization: Find two distinct points, then start up loop1.
loop0 (p1, p2 ! points)
=>
if (p1 == p2)
#
loop0 (p2, points);
else
(calc_off_points (p1, p2)) -> (b1, b2);
reverse (loop1 (p2, points, b1, b2));
fi;
end;
end;
end; # fun make_polygon3d
fun make_polygon3d'
( upperleft_bevel_color: c64::Rgb,
lowerright_bevel_color: c64::Rgb,
thick: Int,
points
)
=
{ halfthick = thick / 2;
#
outer = make_polygon3d ( upperleft_bevel_color, lowerright_bevel_color, halfthick, points);
inner = make_polygon3d (lowerright_bevel_color, upperleft_bevel_color, -halfthick, points);
outer @ inner;
};
herein
fun pictureframe
( p as { upperleft_bevel_color, lowerright_bevel_color, ... }: Gadget_Palette)
( { box, thick, relief }: Pictureframe)
=
case relief
#
FLAT => make_pictureframe ( upperleft_bevel_color, upperleft_bevel_color, thick, box);
RAISED => make_pictureframe ( upperleft_bevel_color, lowerright_bevel_color, thick, box);
SUNKEN => make_pictureframe (lowerright_bevel_color, upperleft_bevel_color, thick, box);
RIDGE => make_pictureframe' ( upperleft_bevel_color, lowerright_bevel_color, thick, box);
GROOVE => make_pictureframe' (lowerright_bevel_color, upperleft_bevel_color, thick, box);
esac;
fun filled_pictureframe
(palette as { body_color, ... }: Gadget_Palette)
(frame as { box, thick, relief }: Pictureframe)
=
(pictureframe palette frame) # The "3D" pictureframe surround.
@
[ gd::COLOR (body_color, [ gd::BOXES [ g2d::box::make_nested_box (box, thick) ] ]) ]; # The interior fill.
fun rounded_pictureframe
( { upperleft_bevel_color, lowerright_bevel_color, ... }: Gadget_Palette)
( { box, thick, relief, corner_high, corner_wide }: Rounded_Pictureframe)
=
case relief
#
FLAT => make_rounded_pictureframe ( upperleft_bevel_color, upperleft_bevel_color, thick, corner_wide, corner_high, box);
RAISED => make_rounded_pictureframe ( upperleft_bevel_color, lowerright_bevel_color, thick, corner_wide, corner_high, box);
SUNKEN => make_rounded_pictureframe (lowerright_bevel_color, upperleft_bevel_color, thick, corner_wide, corner_high, box);
RIDGE => make_rounded_pictureframe' ( upperleft_bevel_color, lowerright_bevel_color, thick, corner_wide, corner_high, box);
GROOVE => make_rounded_pictureframe' (lowerright_bevel_color, upperleft_bevel_color, thick, corner_wide, corner_high, box);
esac;
fun polygon3d
( { upperleft_bevel_color, lowerright_bevel_color, ... }: Gadget_Palette)
( { points, thick, relief }: Polygon3d)
=
case relief
#
FLAT => make_polygon3d ( upperleft_bevel_color, upperleft_bevel_color, thick, points);
RAISED => make_polygon3d ( upperleft_bevel_color, lowerright_bevel_color, thick, points);
SUNKEN => make_polygon3d (lowerright_bevel_color, upperleft_bevel_color, thick, points);
RIDGE => make_polygon3d' ( upperleft_bevel_color, lowerright_bevel_color, thick, points);
GROOVE => make_polygon3d' (lowerright_bevel_color, upperleft_bevel_color, thick, points);
esac;
end;
stipulate
fun fontname (spec: String, pointsize: Int)
=
if (string::length_in_bytes spec < 10 or
string::extract(spec,0,THE 10) != "lucidasans"
)
sfp::sprintf' spec [ sfp::INT (pointsize * 10) ]; # The X font naming system works in tenths of a point, not in points, hence the "*10",
else sfp::sprintf' spec [ sfp::INT (pointsize ) ]; # except that lucidasans just HAD to be different from everything else.
fi;
herein
fun get_roman_fontname (pointsize: Int) = fontname (*theme.roman_font_spex, pointsize); # PUBLIC.
fun get_italic_fontname (pointsize: Int) = fontname (*theme.italic_font_spex, pointsize); # PUBLIC.
fun get_bold_fontname (pointsize: Int) = fontname (*theme.bold_font_spex, pointsize); # PUBLIC.
end;
fun get_roman_font (pointsize: Int) # PUBLIC.
=
{ fontname = *theme.get_roman_fontname pointsize;
#
g = get__guiboss_to_hostwindow theme;
g.get_font [ fontname ];
};
fun get_italic_font (pointsize: Int) # PUBLIC.
=
{ fontname = *theme.get_italic_fontname pointsize;
#
g = get__guiboss_to_hostwindow theme;
g.get_font [ fontname ];
};
fun get_bold_font (pointsize: Int) # PUBLIC.
=
{ fontname = *theme.get_bold_fontname pointsize;
#
g = get__guiboss_to_hostwindow theme;
g.get_font [ fontname ];
};
# Finally we replace the dummy theme fns with the real ones:
#
theme.text_color := text_color;
theme.textfield_color := textfield_color;
#
theme.surround_color := surround_color;
#
theme.body_color := body_color;
theme.body_color_when_on := body_color_when_on;
theme.body_color_with_mousefocus := body_color_with_mousefocus;
theme.body_color_when_on_with_mousefocus := body_color_when_on_with_mousefocus;
#
theme.sunny_bevel_color := sunny_bevel_color;
theme.shady_bevel_color := shady_bevel_color;
theme.current_gadget_colors := current_gadget_colors;
#
theme.pictureframe := pictureframe;
theme.filled_pictureframe := filled_pictureframe;
theme.rounded_pictureframe := rounded_pictureframe;
theme.polygon3d := polygon3d;
#
theme.get_roman_fontname := get_roman_fontname;
theme.get_italic_fontname := get_italic_fontname;
theme.get_bold_fontname := get_bold_fontname;
#
theme.get_roman_font := get_roman_font;
theme.get_italic_font := get_italic_font;
theme.get_bold_font := get_bold_font;
to = make_replyqueue();
#
put_in_oneshot (reply_oneshot, (me_slot, { theme })); # Return value from widget_theme_egg'().
(take_from_mailslot me_slot) # Input args from widget_theme_egg'().
->
{ me, imports, run_gun', end_gun' };
block_until_mailop_fires run_gun'; # Wait for the starting gun.
run (theme_q, { me, imports, to, end_gun' }); # Will not return.
}
where
theme_q = make_mailqueue (get_current_microthread()): Theme_Q;
fun do_something (i: Int) # PUBLIC.
=
put_in_mailqueue (theme_q,
#
\\ ({ me, imports, ... }: Runstate)
=
imports.int_sink i # Demonstrate use of imports.
);
# fun widgetspace (options: gt::Widgetspace_Arg) # PUBLIC.
# =
# { reply_oneshot = make_oneshot_maildrop(): Oneshot_Maildrop( psi::Widgetspace_Egg );
# #
# put_in_mailqueue (theme_q,
# #
# \\ ({ me, ... })
# =
# { (psi::make_widgetspace_egg options NULL) -> widgetspace_egg;
# #
# put_in_oneshot (reply_oneshot, widgetspace_egg);
# }
# );
#
# get_from_oneshot reply_oneshot;
# };
end;
fun process_options (options: List(Option), { name })
=
{ my_name = REF name;
#
apply do_option options
where
fun do_option (MICROTHREAD_NAME n) = my_name := n;
end;
{ name => *my_name };
};
##########################################################################################
# PUBLIC.
#
fun make_widget_theme_egg (options: List(Option)) # PUBLIC. PHASE 1: Construct our state and initialize from 'options'.
=
{ (process_options (options, { name => "tmp" }))
->
{ name };
me = REF ();
\\ () = { reply_oneshot = make_oneshot_maildrop(): Oneshot_Maildrop( (Me_Slot, Exports) ); # PUBLIC. PHASE 2: Start our microthread and return our Exports to caller.
#
xlogger::make_thread name (startup reply_oneshot); # Note that startup() is curried.
(get_from_oneshot reply_oneshot) -> (me_slot, exports);
fun phase3 # PUBLIC. PHASE 3: Accept our Imports, then wait for Run_Gun to fire.
(
imports: Imports,
run_gun': Run_Gun,
end_gun': End_Gun
)
=
{
put_in_mailslot (me_slot, { me, imports, run_gun', end_gun' });
};
(exports, phase3);
};
};
};
end;