## draw-old.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_old; # xsession_old is from src/lib/x-kit/xclient/src/window/xsession-old.pkg package g2d = geometry2d; # geometry2d is from src/lib/std/2d/geometry2d.pkg package fb = font_base_old; # font_base_old is from src/lib/x-kit/xclient/src/window/font-base-old.pkg package di = draw_imp_old; # draw_imp_old is from src/lib/x-kit/xclient/src/window/draw-imp-old.pkg package dt = draw_types_old; # draw_types_old is from src/lib/x-kit/xclient/src/window/draw-types-old.pkg package pn = pen_old; # pen_old is from src/lib/x-kit/xclient/src/window/pen-old.pkgherein
package draw_old {
#
exception BAD_DRAW_PARAMETER;
stipulate
# Extract from a drawable its
# draw_fn,
# xid
# depth
#
fun info_of_drawable (dt::DRAWABLE { to_drawimp, root => dt::r::WINDOW w } )
=>
{ w -> { window_id, per_depth_imps => { depth, ... }: sn::Per_Depth_Imps, ... }: dt::Window;
{ to_drawimp, id => window_id, depth };
};
info_of_drawable (dt::DRAWABLE { to_drawimp, root => dt::r::PIXMAP pm } )
=>
{ pm -> { pixmap_id, per_depth_imps => { depth, ... }: sn::Per_Depth_Imps, ... }: dt::Rw_Pixmap;
{ to_drawimp, 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, ... }: dt::Window ))
=>
(window_id, depth);
info_of_src (dt::FROM_RW_PIXMAP ({ pixmap_id, per_depth_imps => { depth, ... }: sn::Per_Depth_Imps, ... }: dt::Rw_Pixmap))
=>
(pixmap_id, depth);
info_of_src (dt::FROM_RO_PIXMAP (dt::RO_PIXMAP ({ pixmap_id, per_depth_imps => { depth, ... }: sn::Per_Depth_Imps, ... }: dt::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)
->
{ to_drawimp, id, ... };
\\ x = to_drawimp (di::d::DRAW { to => id, pen, op => (f x) } );
};
fun draw_fn2 f drawable pen
=
{ my { to_drawimp, id, ... }
=
info_of_drawable drawable;
\\ x = \\ x' = to_drawimp (di::d::DRAW { 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 = di::o::POLY_POINT (FALSE, check_pts pts));
draw_point_path = draw_fn (\\ pts = di::o::POLY_POINT (TRUE, check_pts pts));
draw_point = draw_fn (\\ pt = di::o::POLY_POINT (FALSE, [check_point pt]));
# Lines and segments:
#
draw_lines = draw_fn (\\ pts = di::o::POLY_LINE (FALSE, check_pts pts));
draw_path = draw_fn (\\ pts = di::o::POLY_LINE (TRUE, check_pts pts));
draw_segs = draw_fn (\\ lines = di::o::POLY_SEG (check_lines lines));
draw_seg = draw_fn (\\ seg = di::o::POLY_SEG [check_line seg]);
# Filled polygons:
#
fill_polygon = draw_fn (\\ { verts, shape } = di::o::FILL_POLY (shape, FALSE, check_pts verts));
fill_path = draw_fn (\\ { path, shape } = di::o::FILL_POLY (shape, TRUE, check_pts path ));
# Rectangles:
#
draw_boxes = draw_fn (\\ boxes = di::o::POLY_BOX (check_boxes boxes));
draw_box = draw_fn (\\ box = di::o::POLY_BOX [check_box box]);
fill_boxes = draw_fn (\\ boxes = di::o::POLY_FILL_BOX (check_boxes boxes));
fill_box = draw_fn (\\ box = di::o::POLY_FILL_BOX [check_box box]);
# Arcs:
#
draw_arcs = draw_fn (\\ arcs = di::o::POLY_ARC (check_arcs arcs));
draw_arc = draw_fn (\\ arc = di::o::POLY_ARC [check_arc arc]);
fill_arcs = draw_fn (\\ arcs = di::o::POLY_FILL_ARC (check_arcs arcs));
fill_arc = draw_fn (\\ arc = di::o::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 = di::o::POLY_ARC [circle_to_arc arg]);
fill_circle = draw_fn (\\ arg = di::o::POLY_FILL_ARC [circle_to_arc arg]);
# Text drawing:
#
draw_transparent_string
=
draw_fn2 (
\\ (fb::FONT { id, ... } )
=
\\ (pt, s)
=
di::o::POLY_TEXT8 (id, check_point pt, [di::t::TEXT (0, s)]
)
);
draw_opaque_string
=
draw_fn2
(\\ (fb::FONT { id, ... } )
=
\\ (pt, s)
=
di::o::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 (fb::FONT { id=>font, ... }, items))
=
di::o::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, di::t::TEXT (d, s) ! l);
flat (font, d, (t::BLANK_PIXELS d') ! r, l)
=>
flat (font, d+d', r, l);
flat (_, d, [t::FONT (fb::FONT { id=>font, ... }, items)], l)
=>
flat (font, d, items, (di::t::FONT font) ! l);
flat (font, d, (t::FONT (fb::FONT { id=>font', ... }, items)) ! r, l)
=>
{ my (d', l')
=
flat (font', d, items, (di::t::FONT font') ! l);
flat (font, d', r, (di::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)
=
{ my { id=>to_id, to_drawimp, depth=>to_depth }
=
info_of_drawable to;
my (from_id, from_depth)
=
info_of_src from;
my (msg, result)
=
msg_fn (check_point to_pos, from_id, from_box);
if (from_depth != to_depth)
#
raise exception DEPTH_MISMATCH;
fi;
to_drawimp (di::d::DRAW { 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, to_drawimp, ... };
(info_of_src from) -> (from_id, from_depth);
(msg_fn (check_point to_pos, from_id, from_box, plane))
->
(msg, result);
if (plane < 0 or from_depth <= plane)
#
raise exception BAD_PLANE;
fi;
to_drawimp (di::d::DRAW { to => to_id, pen, op => msg } );
result;
};
copy_area = copy_area_fn
(\\ (to_pos, from_id, from_box)
=
{ oneshot = make_oneshot_maildrop ();
#
(di::o::COPY_AREA (to_pos, from_id, from_box, oneshot), oneshot);
}
);
copy_plane = copy_plane_fn
(\\ (to_pos, from_id, from_box, plane)
=
{ oneshot = make_oneshot_maildrop ();
#
(di::o::COPY_PLANE (to_pos, from_id, from_box, plane, oneshot), oneshot);
}
);
copy_pmarea = copy_area_fn (\\ arg = (di::o::COPY_PMAREA arg, ()));
copy_pmplane = copy_plane_fn (\\ arg = (di::o::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 { to_drawimp, ... };
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 { to_drawimp, ... };
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 { to_drawimp, ... };
#
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 { to_drawimp, ... };
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 }
=
{ my { wide, high }
=
dt::size_of_ro_pixmap from;
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 }
=
{ my { wide, high }
=
dt::size_of_ro_pixmap from;
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)
->
{ to_drawimp, id, ... };
\\ box
=
to_drawimp (
di::d::DRAW
{ to => id,
pen => clear_pen,
op => (di::o::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)
->
{ to_drawimp, ... };
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