## draw.pkg
#
# Routines for drawing on windows and pixmaps.
#
# This is the library-internal version of this package;
# the client-level version is in:
#
# src/lib/x-kit/xclient/xclient.pkg# Compiled by:
# src/lib/x-kit/xclient/xclient-internals.sublib### "Humanity has advanced, when it has advanced,
### not because it has been sober, responsible,
### and cautious, but because it has been playful,
### rebellious, and immature."
###
### -- Tom Robbins
stipulate
include package threadkit; # threadkit is from src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.pkg #
package sn = xsession_junk; # xsession_junk is from src/lib/x-kit/xclient/src/window/xsession-junk.pkg package g2d = geometry2d; # geometry2d is from src/lib/std/2d/geometry2d.pkg package fb = font_base; # font_base is from src/lib/x-kit/xclient/src/window/font-base.pkg package di = xserver_ximp; # xserver_ximp is from src/lib/x-kit/xclient/src/window/xserver-ximp.pkg package w2x = windowsystem_to_xserver; # windowsystem_to_xserver is from src/lib/x-kit/xclient/src/window/windowsystem-to-xserver.pkg package dt = draw_types; # draw_types is from src/lib/x-kit/xclient/src/window/draw-types.pkg package pn = pen; # pen is from src/lib/x-kit/xclient/src/window/pen.pkgherein
package draw {
#
exception BAD_DRAW_PARAMETER;
stipulate
# Extract from a drawable its
# draw_fn,
# xid
# depth
#
fun info_of_drawable (dt::DRAWABLE { draw_ops, root => dt::r::WINDOW w } )
=>
{ w -> { window_id, per_depth_imps => { depth, ... }: sn::Per_Depth_Imps, ... }: sn::Window;
#
{ draw_ops, id => window_id, depth };
};
info_of_drawable (dt::DRAWABLE { draw_ops, root => dt::r::PIXMAP pm } )
=>
{ pm -> { pixmap_id, per_depth_imps => { depth, ... }: sn::Per_Depth_Imps, ... }: sn::Rw_Pixmap;
#
{ draw_ops, id => pixmap_id, depth };
};
end;
# Extract the xid and depth of a source drawable
#
fun info_of_src (dt::FROM_WINDOW ({ window_id, per_depth_imps => { depth, ... }: sn::Per_Depth_Imps, ... }: sn::Window ))
=>
(window_id, depth);
info_of_src (dt::FROM_RW_PIXMAP ({ pixmap_id, per_depth_imps => { depth, ... }: sn::Per_Depth_Imps, ... }: sn::Rw_Pixmap))
=>
(pixmap_id, depth);
info_of_src (dt::FROM_RO_PIXMAP (sn::RO_PIXMAP ({ pixmap_id, per_depth_imps => { depth, ... }: sn::Per_Depth_Imps, ... }: sn::Rw_Pixmap)))
=>
(pixmap_id, depth);
end;
# Build a drawing function from an encoding function.
#
# The functions have the basic type scheme
#
# Drawable -> Pen -> Args -> Void
#
fun draw_fn f drawable pen
=
{ (info_of_drawable drawable)
->
{ draw_ops, id, ... };
\\ x = draw_ops [ { to => id, pen, op => (f x) } ];
};
fun draw_fn2 f drawable pen
=
{ (info_of_drawable drawable)
->
{ draw_ops, id, ... };
\\ x = \\ x' = draw_ops [ { to => id, pen, op => (f x x') } ];
};
fun check_list chkfn l
=
{ apply
(\\ x = { chkfn x;
();
}
)
l;
l;
};
fun check_item chkfn
=
(\\ v = if (chkfn v) v;
else raise exception BAD_DRAW_PARAMETER;
fi
);
check_point = check_item g2d::valid_point;
check_box = check_item g2d::valid_box;
check_line = check_item g2d::valid_line;
check_arc = check_item g2d::valid_arc;
check_pts = check_list check_point;
check_boxes = check_list check_box;
check_lines = check_list check_line;
check_arcs = check_list check_arc;
herein
# Points:
#
draw_points = draw_fn (\\ pts = w2x::x::POLY_POINT (FALSE, check_pts pts));
draw_point_path = draw_fn (\\ pts = w2x::x::POLY_POINT (TRUE, check_pts pts));
draw_point = draw_fn (\\ pt = w2x::x::POLY_POINT (FALSE, [check_point pt]));
# Lines and segments:
#
draw_lines = draw_fn (\\ pts = w2x::x::POLY_LINE (FALSE, check_pts pts));
draw_path = draw_fn (\\ pts = w2x::x::POLY_LINE (TRUE, check_pts pts));
draw_segs = draw_fn (\\ lines = w2x::x::POLY_SEG (check_lines lines));
draw_seg = draw_fn (\\ seg = w2x::x::POLY_SEG [check_line seg]);
# Filled polygons:
#
fill_polygon = draw_fn (\\ { verts, shape } = w2x::x::FILL_POLY (shape, FALSE, check_pts verts));
fill_path = draw_fn (\\ { path, shape } = w2x::x::FILL_POLY (shape, TRUE, check_pts path ));
# Rectangles:
#
draw_boxes = draw_fn (\\ boxes = w2x::x::POLY_BOX (check_boxes boxes));
draw_box = draw_fn (\\ box = w2x::x::POLY_BOX [check_box box]);
fill_boxes = draw_fn (\\ boxes = w2x::x::POLY_FILL_BOX (check_boxes boxes));
fill_box = draw_fn (\\ box = w2x::x::POLY_FILL_BOX [check_box box]);
# Arcs:
#
draw_arcs = draw_fn (\\ arcs = w2x::x::POLY_ARC (check_arcs arcs));
draw_arc = draw_fn (\\ arc = w2x::x::POLY_ARC [check_arc arc]);
fill_arcs = draw_fn (\\ arcs = w2x::x::POLY_FILL_ARC (check_arcs arcs));
fill_arc = draw_fn (\\ arc = w2x::x::POLY_FILL_ARC [check_arc arc]);
# Circles:
#
fun circle_to_arc { center => { col, row }, rad }
=
{ diam = rad + rad;
{
col => col-rad, row => row-rad,
wide => diam, high => diam,
angle1 => 0, angle2 => 64*360
};
};
draw_circle = draw_fn (\\ arg = w2x::x::POLY_ARC [circle_to_arc arg]);
fill_circle = draw_fn (\\ arg = w2x::x::POLY_FILL_ARC [circle_to_arc arg]);
# Text drawing:
#
draw_transparent_string
=
draw_fn2 (
\\ ({ id, ... }: fb::Font)
=
\\ (pt, s)
=
w2x::x::POLY_TEXT8 (id, check_point pt, [w2x::t::TEXT (0, s)]
)
);
draw_opaque_string
=
draw_fn2
(\\ ({ id, ... }: fb::Font)
=
\\ (pt, s)
=
w2x::x::IMAGE_TEXT8 (id, check_point pt, s)
);
# Polytext drawing:
#
# "There are two styles of text drawing: opaque and transparent.
#
# "Opaque text [...] is drawn by first filling in the bounding box
# with the background color and then drawing the text with the
# foreground color. The function and fill-style of the pen are
# ignored, replaced in effect by OP_COPY and pn::FILL_STYLE_SOLID
#
# "In transparent text [...] the pixels corresponding to bits set in
# a character's glyph are drawn using the foreground color in the
# context of the other relevant pen values, while the other pixels
# are unmodified.
#
# "The [draw_transparent_text] function provides a user-level batching
# mechanism for drawing multiple strings of the same line with possible
# intervening font changes or horizontal shifts."
#
# -- p22-3 http://mythryl.org/pub/exene/1993-lib.ps
# (Reppy + Gansner's 1993 eXene library manual.)
package t {
#
Text = TEXT (fb::Font, List(Text_Item))
also
Text_Item = FONT (fb::Font, List(Text_Item))
| STRING String
| BLANK_PIXELS Int # Skip this many pixels before next STRING.
;
};
draw_transparent_text
=
draw_fn f
where
fun f (pt, t::TEXT ({ id=>font, ... }: fb::Font, items))
=
w2x::x::POLY_TEXT8
( font,
check_point pt,
reverse (#2 (flat (font, 0, items, [])))
)
where
fun flat (_, d, [], l)
=>
(d, l);
flat (font, d, (t::STRING s) ! r, l)
=>
flat (font, 0, r, w2x::t::TEXT (d, s) ! l);
flat (font, d, (t::BLANK_PIXELS d') ! r, l)
=>
flat (font, d+d', r, l);
flat (_, d, [t::FONT ({ id=>font, ... }: fb::Font, items)], l)
=>
flat (font, d, items, (w2x::t::FONT font) ! l);
flat (font, d, (t::FONT ({ id=>font', ... }: fb::Font, items)) ! r, l)
=>
{ (flat (font', d, items, (w2x::t::FONT font') ! l))
->
(d', l');
flat (font, d', r, (w2x::t::FONT font) ! l');
};
end;
end;
end;
# TODO: imageText (what does it mean?? * XXX BUGGO FIXME
# BLT operations # "BLT" == "Block Transfer" -- dates back to Xerox Alto bitmapped display "bitblt" days.
exception DEPTH_MISMATCH;
exception BAD_PLANE;
stipulate
# * NOTE: we should probably check that 'from' and 'to' are on the same display * XXX BUGGO FIXME
fun copy_area_fn msg_fn (to, pen, to_pos, from, from_box)
=
{ (info_of_drawable to)
->
{ id=>to_id, draw_ops, depth=>to_depth };
(info_of_src from)
->
(from_id, from_depth);
(msg_fn (check_point to_pos, from_id, from_box))
->
# (msg, result);
msg;
if (from_depth != to_depth) raise exception DEPTH_MISMATCH; fi;
draw_ops [ { to => to_id, pen, op => msg } ];
# result;
};
fun copy_plane_fn msg_fn (to, pen, to_pos, from, from_box, plane)
=
{ (info_of_drawable to) -> { id=>to_id, draw_ops, ... };
(info_of_src from) -> (from_id, from_depth);
(msg_fn (check_point to_pos, from_id, from_box, plane))
->
# (msg, result);
msg;
if (plane < 0 or from_depth <= plane) raise exception BAD_PLANE; fi;
draw_ops [ { to => to_id, pen, op => msg } ];
# result;
};
copy_area = copy_area_fn
(\\ (to_pos, from_id, from_box)
=
{
# oneshot = make_oneshot_maildrop ();
#
# (w2x::x::COPY_AREA (to_pos, from_id, from_box, oneshot), oneshot);
w2x::x::COPY_AREA (to_pos, from_id, from_box);
}
);
copy_plane = copy_plane_fn
(\\ (to_pos, from_id, from_box, plane)
=
{
# oneshot = make_oneshot_maildrop ();
#
# (w2x::x::COPY_PLANE (to_pos, from_id, from_box, plane, oneshot), oneshot);
w2x::x::COPY_PLANE (to_pos, from_id, from_box, plane);
}
);
copy_pmarea = copy_area_fn (\\ arg = (w2x::x::COPY_PMAREA arg));
copy_pmplane = copy_plane_fn (\\ arg = (w2x::x::COPY_PMPLANE arg));
# "They made us many promises,
# more than I can remember,
# fun promise_event (to_drawimp, sync_1shot) # but they never kept but one;
# = # they promised to take our land,
# { sync_mailop # and they took it." -- Red Cloud
# =
# get_from_oneshot' sync_1shot;
#
# dynamic_mailop {.
# #
# case (nonblocking_get_from_oneshot sync_1shot)
# #
# THE boxes_fn
# =>
# always' () ==> boxes_fn;
#
# NULL => {
# # dt::flush_drawimp to_drawimp;
# #
# sync_mailop ==> (\\ boxes_fn = boxes_fn ());
# };
# esac;
# };
# };
herein
fun pixel_blt to pen { from as (dt::FROM_WINDOW _), from_box, to_pos }
=>
{
# to -> dt::DRAWABLE { draw_ops, ... };
copy_area (to, pen, to_pos, from, from_box);
# sync_1shot = copy_area (to, pen, to_pos, from, from_box);
# dt::flush_drawimp to_drawimp;
# (get_from_oneshot sync_1shot) ();
};
pixel_blt to pen { from, from_box, to_pos }
=>
{ copy_pmarea (to, pen, to_pos, from, from_box);
# [];
};
end;
fun pixel_blt_mailop to pen { from as (dt::FROM_WINDOW _), from_box, to_pos }
=>
{
# to -> dt::DRAWABLE { draw_ops, ... };
copy_area (to, pen, to_pos, from, from_box);
# sync_v = copy_area (to, pen, to_pos, from, from_box);
# promise_event (to_drawimp, sync_v);
};
pixel_blt_mailop to pen { from, from_box, to_pos }
=>
{ copy_pmarea (to, pen, to_pos, from, from_box);
# always' [];
};
end;
fun plane_blt to pen { from as (dt::FROM_WINDOW _), from_box, to_pos, plane }
=>
{
# to -> dt::DRAWABLE { draw_ops, ... };
#
copy_plane (to, pen, to_pos, from, from_box, plane);
# sync_1shot = copy_plane (to, pen, to_pos, from, from_box, plane);
# dt::flush_drawimp to_drawimp;
# (get_from_oneshot sync_1shot) ();
};
plane_blt to pen { from, from_box, to_pos, plane }
=>
{ copy_pmplane (to, pen, to_pos, from, from_box, plane);
# [];
};
end;
fun plane_blt_mailop to pen { from as (dt::FROM_WINDOW _), from_box, to_pos, plane }
=>
{
# to -> dt::DRAWABLE { draw_ops, ... };
copy_plane (to, pen, to_pos, from, from_box, plane);
# sync_v = copy_plane (to, pen, to_pos, from, from_box, plane);
# promise_event (to_drawimp, sync_v);
};
plane_blt_mailop to pen { from, from_box, to_pos, plane }
=>
{ copy_pmplane (to, pen, to_pos, from, from_box, plane);
# always' [];
};
end;
fun bitblt to pen { from, from_box, to_pos }
=
plane_blt to pen { from, from_box, to_pos, plane=>0 };
fun bitblt_mailop to pen { from, from_box, to_pos }
=
plane_blt_mailop to pen { from, from_box, to_pos, plane=>0 };
fun texture_blt to pen { from, to_pos }
=
{ (dt::size_of_ro_pixmap from)
->
{ wide, high };
box = { col=>0, row=>0, wide, high };
plane_blt to pen { from=>dt::FROM_RO_PIXMAP from, from_box=>box, to_pos, plane=>0 };
();
};
fun tile_blt to pen { from, to_pos }
=
{ (dt::size_of_ro_pixmap from)
->
{ wide, high };
box = { col=>0, row=>0, wide, high };
pixel_blt to pen { from=>dt::FROM_RO_PIXMAP from, from_box=>box, to_pos };
();
};
fun copy_blt drawable pen { to_pos, from_box }
=
{ from = case drawable
#
dt::DRAWABLE { root => dt::r::WINDOW w, ... } => dt::FROM_WINDOW w;
dt::DRAWABLE { root => dt::r::PIXMAP pm, ... } => dt::FROM_RW_PIXMAP pm;
esac;
pixel_blt
drawable
pen
{ from, to_pos, from_box };
};
fun copy_blt_mailop drawable pen { to_pos, from_box }
=
{ from = case drawable
#
dt::DRAWABLE { root => dt::r::WINDOW w, ... } => dt::FROM_WINDOW w;
dt::DRAWABLE { root => dt::r::PIXMAP pm, ... } => dt::FROM_RW_PIXMAP pm;
esac;
pixel_blt_mailop
drawable
pen
{ from, to_pos, from_box };
};
end; # stipulate
# Clear part of a destination drawable.
# For windows, this fills in the background color;
# for pixmaps, this fills in all 0's (which is actually
# the default foreground pixel value).
#
stipulate
clear_pen = pn::make_pen [ pn::p::FOREGROUND rgb8::rgb8_color0 ];
herein
fun clear_box drawable
=
{ (info_of_drawable drawable)
->
{ draw_ops, id, ... };
\\ box = draw_ops [ { to => id,
pen => clear_pen,
op => (w2x::x::CLEAR_AREA (check_box box))
}
];
};
end;
# Clear the whole area of a drawable:
#
fun clear_drawable to
=
clear_box to ({ col=>0, row=>0, wide=>0, high=>0 } );
# fun flush drawable
# =
# { (info_of_drawable drawable)
# ->
# { draw_ops, ... };
#
# dt::flush_drawimp to_drawimp;
# };
# fun drawimp_thread_id_of drawable
# =
# { (info_of_drawable drawable)
# ->
# { to_drawimp, ... };
#
# dt::drawimp_thread_id_of to_drawimp;
# };
end; # stipulate
}; # package draw
end; # stipulate