## pen-old.pkg
#
# "A pen is similar to the graphics context provided by xlib.
# The principal differences are that pens are immutable, do
# not specify a font, and can specify clipping rectangles and
# dashlists (which are handled separately in the X protocol)."
# -- p16 http://mythryl.org/pub/exene/1993-lib.ps
# (John H Reppy's 1993 eXene library manual.)
# Compiled by:
# src/lib/x-kit/xclient/xclient-internals.sublib# Support for symbolic names for pen component values.
stipulate
package rc = range_check; # range_check is from src/lib/std/2d/range-check.pkg package dt = draw_types_old; # draw_types_old is from src/lib/x-kit/xclient/src/window/draw-types-old.pkg package xt = xtypes; # xtypes is from src/lib/x-kit/xclient/src/wire/xtypes.pkg package v2w = value_to_wire; # value_to_wire is from src/lib/x-kit/xclient/src/wire/value-to-wire.pkg package g2d = geometry2d; # geometry2d is from src/lib/std/2d/geometry2d.pkg package rwv = rw_vector; # rw_vector is from src/lib/std/src/rw-vector.pkg package vec = vector; # vector is from src/lib/std/src/vector.pkgherein
package pen_old {
include package geometry2d; # geometry2d is from src/lib/std/2d/geometry2d.pkg exception BAD_PEN_TRAIT;
# These are the properties
# distinguishing one pen from
# another:
#
package p {
#
Pen_Trait
= FUNCTION xt::Graphics_Op
| PLANE_MASK xt::Plane_Mask
| FOREGROUND rgb8::Rgb8
| BACKGROUND rgb8::Rgb8
| LINE_WIDTH Int
| LINE_STYLE_SOLID
| LINE_STYLE_ON_OFF_DASH
| LINE_STYLE_DOUBLE_DASH
| CAP_STYLE_NOT_LAST
| CAP_STYLE_BUTT
| CAP_STYLE_ROUND
| CAP_STYLE_PROJECTING
| JOIN_STYLE_MITER
| JOIN_STYLE_ROUND
| JOIN_STYLE_BEVEL
| FILL_STYLE_SOLID
| FILL_STYLE_TILED
| FILL_STYLE_STIPPLED
| FILL_STYLE_OPAQUE_STIPPLED
| FILL_RULE_EVEN_ODD
| FILL_RULE_WINDING
| ARC_MODE_CHORD
| ARC_MODE_PIE_SLICE
| CLIP_BY_CHILDREN
| INCLUDE_INFERIORS
#
| RO_PIXMAP dt::Ro_Pixmap
| STIPPLE dt::Ro_Pixmap
| CLIP_MASK dt::Ro_Pixmap
| CLIP_MASK_NONE
| CLIP_MASK_UNSORTED_BOXES List( Box )
| CLIP_MASK_YSORTED_BOXES List( Box )
| CLIP_MASK_YXSORTED_BOXES List( Box )
| CLIP_MASK_YXBANDED_BOXES List( Box )
| CLIP_ORIGIN Point
#
| STIPPLE_ORIGIN Point
#
| DASH_OFFSET Int
| DASH_FIXED Int
| DASH_LIST List(Int)
;
};
stipulate
include package pen_guts; # pen_guts is from src/lib/x-kit/xclient/src/window/pen-guts.pkg fun check_list chkfn l
=
{ apply (\\ x = { chkfn x; ();})
l;
l;
};
fun check_item chkfn
=
\\ v = if (chkfn v) v;
else raise exception BAD_PEN_TRAIT;
fi;
check_card16 = unt::from_int o (check_item rc::valid16);
check_card8 = unt::from_int o (check_item rc::valid8);
check_point = check_item g2d::valid_point;
check_box = check_item g2d::valid_box;
check_boxes = check_list check_box;
check_card8s = check_list check_card8;
# Map a pen trait to its slot and representation
#
fun trait_to_rep (p::FUNCTION xt::OP_COPY)
=>
(0, IS_DEFAULT);
trait_to_rep (p::FUNCTION gr_op)
=>
(0, IS_WIRE (v2w::graph_op_to_wire gr_op));
trait_to_rep (p::PLANE_MASK (xt::PLANEMASK mask))
=>
(1, IS_WIRE mask);
trait_to_rep (p::FOREGROUND rgb8)
=>
{ i = rgb8::rgb8_to_int rgb8;
i == 0 ?? (2, IS_DEFAULT)
:: (2, IS_WIRE (unt::from_int i));
};
trait_to_rep (p::BACKGROUND rgb8)
=>
{ i = rgb8::rgb8_to_int rgb8;
i == 1 ?? (3, IS_DEFAULT)
:: (3, IS_WIRE (unt::from_int i));
};
trait_to_rep (p::LINE_WIDTH 0 ) => (4, IS_DEFAULT);
trait_to_rep (p::LINE_WIDTH wd) => (4, IS_WIRE (check_card16 wd));
trait_to_rep (p::LINE_STYLE_SOLID ) => (5, IS_DEFAULT);
trait_to_rep (p::LINE_STYLE_ON_OFF_DASH) => (5, IS_WIRE 0u1);
trait_to_rep (p::LINE_STYLE_DOUBLE_DASH) => (5, IS_WIRE 0u2);
trait_to_rep (p::CAP_STYLE_NOT_LAST ) => (6, IS_WIRE 0u0);
trait_to_rep (p::CAP_STYLE_BUTT ) => (6, IS_DEFAULT);
trait_to_rep (p::CAP_STYLE_ROUND ) => (6, IS_WIRE 0u2);
trait_to_rep (p::CAP_STYLE_PROJECTING) => (6, IS_WIRE 0u3);
trait_to_rep (p::JOIN_STYLE_MITER) => (7, IS_DEFAULT);
trait_to_rep (p::JOIN_STYLE_ROUND) => (7, IS_WIRE 0u1);
trait_to_rep (p::JOIN_STYLE_BEVEL) => (7, IS_WIRE 0u2);
trait_to_rep (p::FILL_STYLE_SOLID ) => (8, IS_DEFAULT);
trait_to_rep (p::FILL_STYLE_TILED ) => (8, IS_WIRE 0u1);
trait_to_rep (p::FILL_STYLE_STIPPLED ) => (8, IS_WIRE 0u2);
trait_to_rep (p::FILL_STYLE_OPAQUE_STIPPLED) => (8, IS_WIRE 0u3);
trait_to_rep (p::FILL_RULE_EVEN_ODD) => (9, IS_DEFAULT);
trait_to_rep (p::FILL_RULE_WINDING ) => (9, IS_WIRE 0u1);
trait_to_rep (p::RO_PIXMAP (dt::RO_PIXMAP ({ pixmap_id, ... }: dt::Rw_Pixmap))) => (10, IS_PIXMAP pixmap_id);
trait_to_rep (p::STIPPLE (dt::RO_PIXMAP ({ pixmap_id, ... }: dt::Rw_Pixmap))) => (11, IS_PIXMAP pixmap_id);
trait_to_rep (p::STIPPLE_ORIGIN pt) => (12, IS_POINT (check_point pt));
trait_to_rep (p::CLIP_BY_CHILDREN ) => (13, IS_DEFAULT);
trait_to_rep (p::INCLUDE_INFERIORS) => (13, IS_WIRE 0u1);
trait_to_rep (p::CLIP_ORIGIN ({ col=>0, row=>0 } )) => (14, IS_DEFAULT);
trait_to_rep (p::CLIP_ORIGIN pt) => (14, IS_POINT (check_point pt));
trait_to_rep (p::CLIP_MASK_NONE) => (15, IS_DEFAULT);
trait_to_rep (p::CLIP_MASK (dt::RO_PIXMAP ({ pixmap_id, ... }: dt::Rw_Pixmap))) => (15, IS_PIXMAP pixmap_id);
trait_to_rep (p::CLIP_MASK_UNSORTED_BOXES r) => (15, IS_BOXES (xt::UNSORTED_ORDER, check_boxes r));
trait_to_rep (p::CLIP_MASK_YSORTED_BOXES r) => (15, IS_BOXES (xt::YSORTED_ORDER, check_boxes r));
trait_to_rep (p::CLIP_MASK_YXSORTED_BOXES r) => (15, IS_BOXES (xt::YXSORTED_ORDER, check_boxes r));
trait_to_rep (p::CLIP_MASK_YXBANDED_BOXES r) => (15, IS_BOXES (xt::YXBANDED_ORDER, check_boxes r));
trait_to_rep (p::DASH_OFFSET 0) => (16, IS_DEFAULT);
trait_to_rep (p::DASH_OFFSET n) => (16, IS_WIRE (check_card16 n));
trait_to_rep (p::DASH_FIXED 4) => (17, IS_DEFAULT);
trait_to_rep (p::DASH_FIXED n) => (17, IS_WIRE (check_card8 n));
trait_to_rep (p::DASH_LIST dashes) => (17, IS_DASHES (check_card8s dashes));
trait_to_rep (p::ARC_MODE_CHORD ) => (18, IS_WIRE 0u0);
trait_to_rep (p::ARC_MODE_PIE_SLICE) => (18, IS_DEFAULT);
end;
# Extract the non-default value mask
# from a rw_vector of pen-guts:
#
fun extract_mask vec
=
loop (0u0, 0, 0u1)
where
fun loop (m, i, b)
=
if (i < pen_slot_count)
#
case (rwv::get (vec, i))
#
IS_DEFAULT => loop (m, i+1, unt::(<<) (b, 0u1));
_ => loop (unt::bitwise_or (m, b), i+1, unt::(<<) (b, 0u1));
esac;
else
m;
fi;
end;
# Make a pen from a rw_vector of initial values
# and a list of new values
#
fun make_pen' (vec, trait_list)
=
{ fun update (slot, rep)
=
rwv::set (vec, slot, rep);
apply (\\ trait = update (trait_to_rep trait))
trait_list;
{ traits => vec::from_fn (pen_slot_count, \\ i = rwv::get (vec, i)),
bitmask => extract_mask vec
}
: Pen
;
};
herein
default_pen
=
pen_guts::default_pen;
# Create a new drawing context
# from a list of pen traits:
#
fun make_pen traits
=
make_pen' (rwv::make_rw_vector (pen_slot_count, IS_DEFAULT), traits);
# Create a new pen from an existing
# pen by functional update:
#
fun clone_pen ({ traits, ... }: Pen, new_traits)
=
make_pen' (rwv::from_fn (pen_slot_count, \\ i = vec::get (traits, i)), new_traits);
end; # stipulate
}; # package pen
end;