## text-widget.pkg
#
# A simple text widget: currently this only supports one fixed-width font (9x15).
# Compiled by:
# src/lib/x-kit/widget/xkit-widget.sublib### "[Television] won't be able to hold on
### to any market it captures after the
### first six months.
###
### "People will soon get tired of staring
### at a plywood box every night."
###
### -- Darryl F Zanuck, 1946 (Movie studio head + producer.)
stipulate
include package threadkit; # threadkit is from src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.pkg #
package g2d = geometry2d; # geometry2d is from src/lib/std/2d/geometry2d.pkg package xc = xclient; # xclient is from src/lib/x-kit/xclient/xclient.pkg #
package wg = widget; # widget is from src/lib/x-kit/widget/old/basic/widget.pkgherein
# This package is used in:
#
# src/lib/x-kit/demo/tactic-tree/src/manager-g.pkg # src/lib/x-kit/widget/old/text/virtual-terminal.pkg #
# Also, these three mention text_widget::Char_Point:
# src/lib/x-kit/widget/old/fancy/graphviz/text/text-display.pkg # src/lib/x-kit/widget/old/fancy/graphviz/text/text-canvas.pkg # src/lib/x-kit/widget/old/fancy/graphviz/text/view-buffer.pkg package text_widget
: Text_Widget # Text_Widget is from src/lib/x-kit/widget/old/text/text-widget.api {
caextract = rw_vector_slice_of_chars::to_vector
o
rw_vector_slice_of_chars::make_slice;
fun impossible (f, msg)
=
raise exception lib_base::IMPOSSIBLE("text_widget." + f + ": " + msg);
Char_Point
=
CHAR_POINT { col: Int,
row: Int
};
fun min (a: Int, b) = a < b ?? a :: b;
fun max (a: Int, b) = a > b ?? a :: b;
font_name = "9x15";
pad = 2;
tot_pad = pad+pad;
# Get the character dimensions from a (fixed-width) font
#
fun font_info font
=
{ (xc::font_high font)
->
{ ascent, descent };
(ascent + descent, xc::text_width font "M", ascent);
};
# A description of the various size parameters of a text window
#
Text_Size
=
TEXT_SIZE {
size: g2d::Size,
#
rows: Int,
cols: Int,
#
char_high: Int,
char_wide: Int,
#
ascent: Int
};
# Make a text window size descriptor from a window size and font.
#
fun make_text_size (window_size as { wide, high }, font)
=
{ (font_info font)
->
(char_high, char_wide, ascent);
TEXT_SIZE {
size => window_size,
rows => int::quot (high - tot_pad, char_high),
cols => int::quot (wide - tot_pad, char_wide),
char_high,
char_wide,
ascent
};
};
# Return TRUE if the character coordinate is in the text window
#
fun in_text_window (TEXT_SIZE { rows, cols, ... }, CHAR_POINT { row, col } )
=
((0 <= row) and (row < rows)) and
((0 <= col) and (col < cols));
# Clip a string to insure that it does not exceed the text length
#
fun clip_string (TEXT_SIZE { cols, ... }, col, s)
=
{ len = string::length_in_bytes s;
#
col + len <= cols ?? s
:: substring (s, 0, cols-col);
};
# *** The text buffer ***
# This is a two dimensional array of characters with highlighting information.
#
stipulate
Text_Line
=
TEXT_LINE
( rw_vector_of_chars::Rw_Vector,
List ((Int, Int)) # Highlight-region list. Each pairs gives (col, len?) of one highlighted region.
);
herein
stipulate
Text_Buf # Start abstype-replacement recipe -- see http://successor-ml.org/index.php?title=Degrade_abstype_to_derived_form
= #
TEXT_BUF #
{ size: g2d::Size, #
arr: rw_vector::Rw_Vector( Text_Line ) #
}; #
herein #
Text_Buf = Text_Buf; # End of abstype-replacement recipe.
stipulate
# Reverse first arg and prepend it to second arg:
#
fun reverse_and_prepend ([], l) => l;
reverse_and_prepend (x ! r, l) => reverse_and_prepend (r, x ! l);
end;
# Update the highlight region list of a line to reflect the writing of a
# length "len" normal-mode string starting in column "col".
fun ins_n (_, _, [] : List( (Int, Int) ) ) # "ins_n" == "insert normal" (non-highlighted) text. Except we're overwriting, not inserting.
=>
[];
ins_n (col, len, format)
=>
prefix (format, [])
where
end_col = col+len;
#
fun prefix ([], _)
=>
format; # The written text falls after all highlight regions
prefix ((c, n) ! r, l)
=>
{ end_c = c+n;
#
if (end_c <= col)
#
prefix (r, (c, n) ! l); # This highlighted region is unaffected by the written text because it is entirely before the insertion point.
elif (end_col <= c)
#
format; # Written text is not within any highlighted region.
elif (c < col)
if (end_c <= end_col)
#
suffix ((c, col-c) ! l, r);
else
reverse_and_prepend (l, (c, col-c) ! (end_col, end_c-end_col) ! r);
fi;
elif (end_c <= end_col)
#
suffix (l, r); # Inserted text covers highlighed region (c, n)
else
reverse_and_prepend (l, (end_col, end_c-end_col) ! r);
fi;
};
end
also
fun suffix (pre, [])
=>
reverse_and_prepend (pre, []);
suffix (pre, (c, n) ! r)
=>
{ end_c = c+n;
#
if (end_c <= end_col)
#
suffix (pre, r);
elif (c < end_col)
#
reverse_and_prepend (pre, (end_col, end_c-end_col) ! r);
else
reverse_and_prepend (pre, r);
fi;
};
end;
end; # fun ins_n
end;
# Update the highlight region list of a line to reflect the writing of a
# length len highlighted string starting in column col.
#
fun ins_h (col, len, [] : List( (Int, Int) ) ) # "ins_h" == "insert highlighted" text. Except we're overwriting, not inserting.
=>
[(col, len)];
ins_h (col, len, format)
=>
{
end_col = col+len;
#
fun prefix ([], l)
=>
reverse_and_prepend (l, [(col, len)]);
prefix ((c, n) ! r, l)
=>
{ end_c = c+n;
#
if (end_c < col)
#
prefix (r, (c, n) ! l);
elif (end_col < c)
#
reverse_and_prepend (l, (col, len) ! (c, n) ! r);
elif (c < col)
#
if (end_c < end_col)
#
suffix (l, c, end_col, r);
else
format;
fi;
elif (end_c < end_col)
#
suffix (l, col, end_col, r);
else
reverse_and_prepend (l, (col, end_c-col) ! r);
fi;
};
end
also
fun suffix (pre, col, end_col, [])
=>
reverse_and_prepend (pre, [(col, end_col-col)]);
suffix (pre, col, end_col, (c, n) ! r)
=>
{ end_c = c+n;
#
if (c > end_col)
#
reverse_and_prepend (pre, (col, end_col-col) ! (c, n) ! r);
elif (end_c < end_col)
#
suffix (pre, col, end_col, r);
else
reverse_and_prepend (pre, (col, end_c-col) ! r);
fi;
};
end;
prefix (format, []);
}; # fun ins_h clause
end; # fun ins_h
fun left_shift (col, delta, format)
=
{ end_col = col + delta;
#
fun filter []
=>
[];
filter ((c, n) ! r)
=>
{ endc = c+n;
#
if (c < col)
#
if (endc <= col)
#
(c, n) ! (filter r);
elif (endc <= end_col)
(c, col-c) ! (filter r);
else
(c, col-c) ! (end_col-delta, endc-end_col) ! (filter r);
fi;
elif (c < end_col)
if (endc <= end_col)
#
filter r;
else
(end_col-delta, endc-end_col) ! (filter r);
fi;
else
(c-delta, n) ! (map (\\ (c, n) = (c-delta, n)) r);
fi;
};
end;
filter format;
}; # fun left_shift
fun right_shift (col, end_col, delta, format)
=
filter format
where
fun filter []
=>
[];
filter ((c, n) ! r)
=>
if (c+n <= col)
#
(c, n) ! (filter r);
else
if (c < col)
#
(c, min (n+delta, end_col-c)) ! (filter r);
else
c' = c + delta;
if (c' < end_col)
#
(c', min (n, end_col-c')) ! (filter r);
else
[];
fi;
fi;
fi;
end;
end; # fun right_shift
fun new_text_ln cols
=
TEXT_LINE (rw_vector_of_chars::make_rw_vector (cols, ' '), []);
# Write a string into a bytearray starting at col.
#
fun write_string (ba, col, str)
=
{ fun cpy (i, j)
=
{ rw_vector_of_chars::set (ba, i, string::get_byte_as_char (str, j));
#
cpy (i+1, j+1);
};
(cpy (col, 0))
except
_ = ();
};
# Copy a block of nchars from fromcol to tocol.
# NOTE: the updating of the highlight list is not exact, as
# we assume copyText is followed by a clearLine or a writeText,
# which will restore consistency.
# we also assume that all characters to the right of
# min (fromcol, tocol) are affected.
#
fun copy_text (TEXT_BUF { arr, size=>{ wide, ... }}, row, fromcol, tocol, nchars)
=
{ (rw_vector::get (arr, row))
->
TEXT_LINE (ba, format);
delta = tocol - fromcol;
fun copy_string (0, _, _)
=>
();
#
copy_string (count, index, inc)
=>
{ rw_vector_of_chars::set (ba, index+delta, rw_vector_of_chars::get (ba, index));
copy_string (count - 1, index+inc, inc);
};
end;
if (delta > 0)
#
copy_string (nchars, fromcol+nchars - 1, -1);
rw_vector::set (arr, row, TEXT_LINE (ba, right_shift (fromcol, wide, delta, format)));
else
copy_string (nchars, fromcol, 1);
rw_vector::set (arr, row, TEXT_LINE (ba, left_shift (tocol, -delta, format)));
fi;
};
herein # reverse_and_prepend
# Create a text buffer of the specified size:
#
fun make_text_buf (TEXT_SIZE { rows, cols, ... } )
=
loop (rows, [])
where
fun loop (0, l) => TEXT_BUF { size=>{ wide=>cols, high=>rows }, arr=>rw_vector::from_list l };
loop (i, l) => loop (i - 1, (new_text_ln cols) ! l);
end;
end;
# Write a string in normal mode into a text rw_vector:
#
fun write_ntext (TEXT_BUF { arr, ... }, row, col, str)
=
{ (rw_vector::get (arr, row))
->
TEXT_LINE (ba, format);
write_string (ba, col, str);
rw_vector::set (arr, row, TEXT_LINE (ba, ins_n (col, string::length_in_bytes str, format)));
};
# Write a string in highlighted mode into a text rw_vector:
#
fun write_htext (TEXT_BUF { arr, ... }, row, col, str)
=
{ my TEXT_LINE (ba, format) = rw_vector::get (arr, row);
write_string (ba, col, str);
rw_vector::set (arr, row, TEXT_LINE (ba, ins_h (col, string::length_in_bytes str, format)));
};
# Insert a string into a text rw_vector, shifting chars to the right:
#
fun insert_buf_text (
tbuf as TEXT_BUF { size=>{ wide, ... }, ... }, row, col, str, highlight
)
=
{ slen = size str;
eolcnt = wide - col - slen;
if (eolcnt > 0)
copy_text (tbuf, row, col, col+slen, eolcnt);
fi;
highlight ?? write_htext (tbuf, row, col, str)
:: write_ntext (tbuf, row, col, str);
};
# Clear the given line of text
#
fun clear_text_ln (TEXT_BUF { arr, ... }, CHAR_POINT { row, col } )
=
{ (rw_vector::get (arr, row))
->
TEXT_LINE (ba, format);
if (col == 0)
#
rw_vector::set (arr, row, new_text_ln (rw_vector_of_chars::length ba));
else
fun clr i
=
{ rw_vector_of_chars::set (ba, i, ' ');
clr (i+1);
};
new_format
=
ins_n (col, (rw_vector_of_chars::length ba) - col, format);
(clr col)
except
_ = ();
rw_vector::set (arr, row, TEXT_LINE (ba, new_format));
fi;
};
# Delete count chars at the given position
#
fun delete_text_chars (tbuf as TEXT_BUF { size=>{ wide, ... }, ... }, row, col, count)
=
{ eolcnt = wide - col - count;
#
if (eolcnt > 0)
#
copy_text (tbuf, row, col+count, col, eolcnt);
clear_text_ln (tbuf, CHAR_POINT { row, col => wide-count } );
else clear_text_ln (tbuf, CHAR_POINT { row, col } );
fi;
};
# Clear the given block of text
#
fun clear_text { text => TEXT_BUF { arr=>ar, ... }, from, to }
=
loop from
where
cols = { (rw_vector::get (ar, 0)) -> TEXT_LINE (ba, _);
#
rw_vector_of_chars::length ba;
};
fun clear_ln i
=
rw_vector::set (ar, i, new_text_ln cols);
fun loop i
=
if (i < to)
#
clear_ln i;
loop (i+1);
fi;
end;
# Move a block of text up; "from" is the bottom of the text to be moved,
# "to" is the line to move "from" to, and "nlines" is the size of the
# block being moved. It is assumed that the top line of the moved
# block will end up at the top of the screen.
#
fun move_text_up { text as TEXT_BUF { arr=>ar, ... }, from, to, nlines }
=
{ fun copy (i, j)
=
if (i <= to)
#
rw_vector::set (ar, i, rw_vector::get (ar, j));
copy (i+1, j+1);
fi;
copy (0, from-to);
clear_text { text, from => to+1, to => from+1 };
};
# Move a block of text down; "from" is the top of the text to be moved,
# "to" is the line to move "from" to, and "nlines" is the size of the
# block being moved. It is assumed that the bottom line of the moved
# block will end up at the bottom of the screen.
#
fun move_text_down { text as TEXT_BUF { arr=>ar, ... }, from, to, nlines }
=
{ rows = rw_vector::length ar;
#
fun copy (i, j)
=
if (i >= to)
#
rw_vector::set (ar, i, rw_vector::get (ar, j));
copy (i - 1, j - 1);
fi;
copy (rows - 1, (from + nlines) - 1);
clear_text { text, from, to };
};
# Delete a block of text; "from" is the start of the block, "nlines" is the
# number of lines to delete. The text below the delete block is scrolled up
# to fill the space, with blank lines filling from the bottom.
#
fun delete_text { text as TEXT_BUF { arr=>ar, ... }, from, nlines }
=
{ rows = rw_vector::length ar;
#
fun copy (i, j)
=
if (j < rows)
#
rw_vector::set (ar, i, rw_vector::get (ar, j));
copy (i+1, j+1);
fi;
copy (from, from+nlines);
clear_text { text, from => rows-nlines, to => rows };
};
# Extract the text starting in column "col" of length "len" in row "row".
# This is returned as a list of strings: the first in normal mode, the
# second in highlighted mode, the third in normal, etc.
#
fun explode_row { text => TEXT_BUF { arr=>text, ... }, row, col, len }
=
case (rw_vector::get (text, row))
#
TEXT_LINE (ba, [])
=>
[caextract (ba, col, THE len)];
TEXT_LINE (ba, l)
=>
{ end_col = col + len;
#
fun ext (col, len)
=
caextract (ba, col, THE len);
fun prefix []
=>
[ext (col, len)];
prefix ((c, n) ! r)
=>
{ end_c = c+n;
#
if (end_c <= col)
#
prefix r;
elif (end_col <= c)
#
[ext (col, len)];
elif (c < col)
#
if (end_c < end_col)
#
suffix (end_c, r, [ext (col, end_c-col), ""]);
else
["", ext (col, len)];
fi;
else
if (end_c < end_col)
#
suffix (end_c, r, [ext (c, n), ext (col, c-col)]);
else
[ext (col, c-col), ext (c, end_col-c)];
fi;
fi;
};
end
also
fun suffix (i, [], l)
=>
reverse_and_prepend (l, [ext (i, end_col-i)]);
suffix (i, (c, n) ! r, l)
=>
{ end_c = c+n;
#
if (end_col <= c)
#
reverse_and_prepend (l, [ext (i, end_col-i)]);
elif (end_c < end_col)
#
suffix (end_c, r, ext (c, n) ! ext (i, c-i) ! l);
else
reverse_and_prepend (l, [ext (i, c-i), ext (c, end_col-c)]);
fi;
};
end;
prefix l;
};
esac;
# Resize a text buffer. If the new size is smaller, then stuff is
# dropped from the bottom and right. If the new size is larger, then
# blank space is added to the bottom and right.
#
fun resize_text_buf (TEXT_BUF { arr=>old_a, ... }, new_size as TEXT_SIZE { rows, cols, ... } )
=
new_tb
where
(make_text_buf new_size)
->
(new_tb as (TEXT_BUF { arr=>new_a, ... } ));
fun copy row
=
{ (rw_vector::get (new_a, row)) -> TEXT_LINE (new_ba, _);
(rw_vector::get (old_a, row)) -> TEXT_LINE (old_ba, old_hl);
fun cpy col
=
{ rw_vector_of_chars::set (new_ba, col, rw_vector_of_chars::get (old_ba, col));
cpy (col+1);
};
fun clip_hl ([], l)
=>
reverse_and_prepend (l, []);
clip_hl ((c, n) ! r, l)
=>
if (c >= cols)
#
reverse_and_prepend (l, []);
elif (c+n <= cols)
#
clip_hl (r, (c, n) ! l);
else
reverse_and_prepend (l, [(c, cols-c)]);
fi;
end;
rw_vector::set (new_a, row, TEXT_LINE (new_ba, clip_hl (old_hl, [])));
(cpy 0)
except
_ = ();
copy (row+1);
};
(copy 0) except _ => ();
end;
end; # fun resize_text_buf
end; # reverse_and_prepend stipulate
end; # Text_Buf stipulate (abstype replacement recipie).
end; # Text_Line stipulate
# *** The text window ***
# This is a dumb text window that
# supports drawing text in normal
# and highlighted mode:
#
stipulate
Text_Window # Start of abstype-replacement recipe -- see http://successor-ml.org/index.php?title=Degrade_abstype_to_derived_form
= #
TEXT_WINDOW { #
#
root_window: wg::Root_Window, #
#
window: xc::Window, #
font: xc::Font, #
#
rows: Int, #
cols: Int, #
#
char_high: Int, #
char_wide: Int, #
char_ascent: Int, #
#
draw_text: { col: Int, row: Int, s: String } -> Void, #
highlight_text: { col: Int, row: Int, s: String } -> Void, #
stipple: { col: Int, row: Int, highlight: Bool } -> Void, #
clear_line: { row: Int, start_col: Int, end_col: Int } -> Void, #
clear_blk: { start_row: Int, end_row: Int } -> Void, #
#
char_blt #
: #
{ row: Int, #
from: Int, #
to: Int, #
nchars: Int #
} #
-> #
Mailop( List( g2d::Box ) ), #
#
line_blt: { from: Int, to: Int, nlines: Int } -> Mailop( List( g2d::Box ) ) #
}; #
herein /* Text_Window */ #
Text_Window = Text_Window; # End of abstype-replacement recipe.
stipulate /* char_blt */
# Blt a block of text within a line
#
fun char_blt (window, TEXT_SIZE { char_high, char_wide, size=>{ wide, ... }, ... } )
=
blt
where
pixel_blt
=
xc::pixel_blt_mailop
(xc::drawable_of_window window)
xc::default_pen;
fun blt { row, from, to, nchars }
=
{ yyy = (char_high * row) + pad;
#
pixel_blt
{
from => xc::FROM_WINDOW window,
#
to_pos
=>
{ col => pad + to*char_wide,
row => yyy
},
from_box
=>
{ col => pad + from*char_wide,
row => yyy,
wide => nchars*char_wide,
high => char_high
}
};
};
end; # fun char_blt
# Blt a block of text by lines:
#
fun line_blt (window, TEXT_SIZE { char_high, char_wide, size=>{ wide, ... }, ... } )
=
blt
where
pixel_blt
=
xc::pixel_blt_mailop
(xc::drawable_of_window window)
xc::default_pen;
text_wide = wide - tot_pad;
fun blt { from, to, nlines }
=
{ from_y = (char_high * from) + pad;
to_y = (char_high * to ) + pad;
pixel_blt
{
from => xc::FROM_WINDOW window,
to_pos => { col=>pad, row=>to_y },
from_box
=>
{ col => pad,
row => from_y,
wide => text_wide,
high => (char_high * nlines)
}
};
};
end; # fun line_blt
# A stipple pattern for the cursor:
#
cursor_stipple_data
=
(16, [[
"0x8888", "0x2222", "0x1111", "0x4444",
"0x8888", "0x2222", "0x1111", "0x4444",
"0x8888", "0x2222", "0x1111", "0x4444",
"0x8888", "0x2222", "0x1111", "0x4444"
]]);
herein /* char_blt */
# Make a text window of the given size:
#
fun make_text_window (root_window, window, font, size)
=
{ size -> TEXT_SIZE { size=>{ wide, high }, rows, cols, char_high, char_wide, ascent };
#
my (pen, highlighter, normal_stipple, highlight_stipple)
=
{
black = xc::black;
white = xc::white;
stipple = wg::ro_pixmap root_window "lightGray";
( xc::make_pen [xc::p::FOREGROUND (xc::rgb8_from_rgb black), xc::p::BACKGROUND (xc::rgb8_from_rgb white)],
xc::make_pen [xc::p::FOREGROUND (xc::rgb8_from_rgb white), xc::p::BACKGROUND (xc::rgb8_from_rgb black)],
#
xc::make_pen [xc::p::FOREGROUND (xc::rgb8_from_rgb black), xc::p::FILL_STYLE_STIPPLED, xc::p::STIPPLE stipple],
xc::make_pen [xc::p::FOREGROUND (xc::rgb8_from_rgb white), xc::p::FILL_STYLE_STIPPLED, xc::p::STIPPLE stipple]
);
};
fun cc_to_pt { row, col }
=
{ x => (col * char_wide) + pad,
y => (row * char_high) + pad
};
fun draw_text (clear, draw) { row, col, s }
=
{ my { x, y } = cc_to_pt { row, col };
clear ( { col=>x, row=>y, wide=>char_wide*(string::length_in_bytes s), high=>char_high } );
draw ({ col=>x, row=>y+ascent }, s);
};
fun stipple { row, col, highlight }
=
{ my { x, y }
=
cc_to_pt { row, col };
box = ({ col=>x, row=>y, wide=>char_wide, high=>char_high } );
highlight ?? xc::fill_box (xc::drawable_of_window window) highlight_stipple box
:: xc::fill_box (xc::drawable_of_window window) normal_stipple box;
};
clr_box
=
xc::clear_box (xc::drawable_of_window window);
fun clear_ln { row, start_col, end_col }
=
{ my { x, y }
=
cc_to_pt { row, col=>start_col };
clr_box ({ col=>x, row=>y, wide=>(end_col-start_col)*char_wide, high=>char_high } );
};
fun clear_blk { start_row, end_row }
=
{
my { x, y }
=
cc_to_pt { row=>start_row, col=>0 };
clr_box ({ col=>x, row=>y, wide=>(wide-tot_pad), high=>(end_row - start_row)*char_high } );
};
TEXT_WINDOW {
root_window,
window,
font,
rows, cols,
char_high,
char_wide,
char_ascent => ascent,
draw_text
=>
draw_text
( clr_box,
#
xc::draw_transparent_string
#
(xc::drawable_of_window window)
pen
font
),
highlight_text
=>
draw_text
( xc::fill_box (xc::drawable_of_window window) pen,
xc::draw_transparent_string (xc::drawable_of_window window) highlighter font
),
stipple,
clear_line => clear_ln,
clear_blk,
char_blt => char_blt (window, size),
line_blt => line_blt (window, size)
};
}; # fun make_text_window
# Create a new text window descriptor
# to reflect a change in the window size:
#
fun resize_text_window (TEXT_WINDOW { window, font, root_window, ... }, new_size)
=
make_text_window (root_window, window, font, new_size);
# Draw a string in normal mode
# at the given position:
#
fun draw_ntext { window=>TEXT_WINDOW { draw_text, ... }, row, col, text }
=
draw_text { row, col, s=>text };
# Draw a string in highlight mode
# at the given position:
#
fun draw_htext { window=>TEXT_WINDOW { highlight_text, ... }, row, col, text }
=
highlight_text { row, col, s=>text };
# Stipple a normal mode character position:
#
fun stipple_nchar { window=>TEXT_WINDOW { stipple, ... }, row, col }
=
stipple { row, col, highlight=>FALSE };
# Stipple a highlight mode character position:
#
fun stipple_hchar { window=>TEXT_WINDOW { stipple, ... }, row, col }
=
stipple { row, col, highlight=>TRUE };
# Clear a character:
#
fun clear_window_char (TEXT_WINDOW { clear_line, ... }, CHAR_POINT { row, col } )
=
clear_line { row, start_col => col, end_col => col+1 };
# Clear from a character position
# to the end of the line:
#
fun clear_window_ln (TEXT_WINDOW { clear_line, cols, ... }, CHAR_POINT { row, col } )
=
clear_line { row, start_col => col, end_col => cols };
# Clear from a row to the end
# of the screen:
#
fun clear_window { window => TEXT_WINDOW { clear_blk, ... }, from, to }
=
clear_blk { start_row => from, end_row => to };
# Delete characters;
#
fun delete_window_chars (TEXT_WINDOW { clear_line, char_blt, cols, ... }, CHAR_POINT { row, col }, count)
=
{ eolcnt = cols - col - count;
if (eolcnt > 0)
mailop = char_blt { row, from=>col+count, to=>col, nchars=>eolcnt };
clear_line { row, start_col => cols-count, end_col => cols };
block_until_mailop_fires mailop;
else
clear_line { row, start_col => col, end_col => cols };
[];
fi;
};
# Insert text:
#
fun insert_window_text (tw, CHAR_POINT { row, col }, str, highlight)
=
{ tw -> TEXT_WINDOW { draw_text, highlight_text, char_blt, cols, ... };
count = size str;
txtfn = if highlight highlight_text;
else draw_text;
fi;
eolcnt = cols - col - count;
if (eolcnt <= 0)
#
txtfn { row, col, s=>str };
[];
else
mailop = char_blt { row, from=>col, to=>col+count, nchars=>eolcnt };
txtfn { row, col, s=>str };
block_until_mailop_fires mailop;
fi;
};
# Scroll a region of text up; "from" is the bottom line of the text, "to"
# is where "from" is move to, and "nlines" is the size of the block.
#
fun scroll_window_up { window=>TEXT_WINDOW { line_blt, clear_blk, ... }, from, to, nlines=>0 }
=>
{ clear_blk { start_row=>to+1, end_row=>from+1 };
[];
};
scroll_window_up { window=>TEXT_WINDOW { line_blt, clear_blk, ... }, from, to, nlines }
=>
{ mailop = line_blt { from=>from-to, to=>0, nlines };
#
clear_blk { start_row=>to+1, end_row=>from+1 };
block_until_mailop_fires mailop;
};
end;
# Scroll a region of text down; "from" is the top line of the text, "to"
# is where "from" is moved to, and "nlines" is the size of the block.
#
fun scroll_window_down { window=>TEXT_WINDOW { clear_blk, ... }, from, to, nlines=>0 }
=>
{ clear_blk { start_row=>from, end_row=>to };
[];
};
scroll_window_down { window=>TEXT_WINDOW { line_blt, clear_blk, ... }, from, to, nlines }
=>
{ mailop = line_blt { from, to, nlines };
#
clear_blk { start_row=>from, end_row=>to };
block_until_mailop_fires mailop;
};
end;
# Delete a region of text; "from" is the start of the block, "nlines" is the
# number of lines to delete. The text below the delete block is scrolled up
# to fill the space, with blank lines filling from the bottom.
#
fun delete_window_lines { window=>TEXT_WINDOW { rows, clear_blk, ... }, from, to, nlines=>0 }
=>
{ clear_blk { start_row=>from, end_row=>rows };
[];
};
delete_window_lines { window=>TEXT_WINDOW { rows, line_blt, clear_blk, ... }, from, to, nlines }
=>
{ mailop = line_blt { from=>to, to=>from, nlines };
#
clear_blk { start_row=>from+nlines, end_row=>rows };
block_until_mailop_fires mailop;
};
end;
end; # char_blt stipulate
end; # text_window stipulate (abstype replacement)
# *** The internal text widget state ***
# The internal state of the text widget consists of the current size, a text
# buffer, a text window and a cursor.
#
Text = TEXT { size: Text_Size,
txt_buf: Text_Buf,
txt_window: Text_Window,
cursor: { is_on: Bool, pos: Char_Point }
};
# Draw the cursor
#
fun draw_cursor (TEXT { txt_buf, txt_window, cursor=> { pos=>CHAR_POINT { row, col }, ... }, ... } )
=
case (explode_row { text=>txt_buf, row, col, len=>1 } )
("" ! _ ) => stipple_hchar { window=>txt_window, col, row };
_ => stipple_nchar { window=>txt_window, col, row };
esac;
# Erase the cursor:
#
fun erase_cursor (TEXT { txt_buf, txt_window, cursor=> { pos=>CHAR_POINT { row, col }, ... }, ... } )
=
case (explode_row { text=>txt_buf, row, col, len=>1 } )
[] => clear_window_char (txt_window, CHAR_POINT { row, col } );
("" ! s ! _) => draw_htext { window=>txt_window, col, row, text=>s };
(" " ! _) => clear_window_char (txt_window, CHAR_POINT { row, col } );
(s ! _) => draw_ntext { window=>txt_window, col, row, text=>s };
esac;
# Redraw damaged lines (but not the cursor):
#
fun redraw_text (TEXT { size, txt_buf, txt_window, ... }, damage)
=
{ size -> TEXT_SIZE { rows, cols, char_high, char_wide, ... };
#
damage_vec = rw_vector::make_rw_vector (rows, NULL);
fun mark (i, min_col, max_col)
=
case (rw_vector::get (damage_vec, i))
#
THE (a, b)
=>
rw_vector::set (damage_vec, i, THE (min (min_col, a), max (max_col, b)));
NULL
=>
rw_vector::set (damage_vec, i, THE (min_col, max_col));
esac;
fun mark_damage []
=>
();
mark_damage ({ col=>x, row=>y, wide, high } ! r)
=>
{ top_ln = int::quot (y - pad, char_high);
bot_ln = int::min (int::quot((y - pad) + high + (char_high - 1), char_high), rows);
min_c = int::quot (x - pad, char_wide);
max_c = int::min (int::quot((x - pad) + wide + (char_wide - 1), char_wide), cols);
fun f i
=
if (i < bot_ln)
#
mark (i, min_c, max_c);
f (i+1);
fi;
f top_ln;
mark_damage r;
};
end;
fun redraw_damaged_lines row
=
{ case (rw_vector::get (damage_vec, row))
#
NULL => ();
THE (min_col, max_col)
=>
{
strs = explode_row {
text=>txt_buf, row, col=>min_col, len=>max_col-min_col };
fun draw_n (_, []) => ();
draw_n (i, "" ! r) => draw_h (i, r);
draw_n (i, s ! r)
=>
{ draw_ntext { window=>txt_window, row, col=>i, text=>s };
draw_h (i + string::length_in_bytes s, r);
};
end
also
fun draw_h (_, [])
=>
();
draw_h (i, s ! r)
=>
{ draw_htext { window=>txt_window, row, col=>i, text=>s };
draw_n (i + string::length_in_bytes s, r);
};
end;
draw_n (min_col, strs);
};
esac;
redraw_damaged_lines (row+1);
};
# file::print "redraw start\n";
mark_damage damage;
(redraw_damaged_lines 0)
except
_ = ();
# file::print "redraw done\n";
};
# Redraw (including the cursor)
#
fun redraw (txt as TEXT { cursor, ... }, damage)
=
{ redraw_text (txt, damage);
case cursor
#
{ is_on=>TRUE, pos } => draw_cursor txt;
_ => ();
esac;
};
# Complete a area operation by redrawing any missing rectangles:
#
fun repair (_, []) => ();
repair (txt, rl) => redraw_text (txt, rl);
end;
# Resize the text buffer and text window:
#
fun resize (TEXT { txt_buf, txt_window, ... }, font, { wide, high, ... }: g2d::Box)
=
{ new_size = make_text_size ({ wide, high }, font);
# * DO WE NEED TO REFRESH?? *
# file::print "resize start\n";
TEXT {
txt_buf => resize_text_buf (txt_buf, new_size),
txt_window => resize_text_window (txt_window, new_size),
size => new_size,
cursor => { is_on => FALSE, pos => CHAR_POINT { row=>0, col=>0 }}
};
};
# Return the size info of the widget state:
#
fun get_info (TEXT { size, ... } )
=
size;
# Return the cursor info of the widget state:
#
fun get_cursor_info (TEXT { cursor, ... } )
=
cursor;
# Scroll the text from line "from" up "n" lines:
#
fun scroll_up (txt, from, n)
=
{ txt -> TEXT { size=>TEXT_SIZE { rows, ... }, txt_buf, txt_window, cursor };
#
to = from - n;
blk_size = to + 1;
interfere = case cursor
#
{ is_on=>TRUE, pos => CHAR_POINT { row, ... } }
=>
(from >= row);
_ => FALSE;
esac;
if (n > 0 and -1 <= to and from < rows)
#
if interfere
#
erase_cursor txt;
move_text_up { text=>txt_buf, from, to, nlines=>blk_size };
repair (txt, scroll_window_up { window=>txt_window, from, to, nlines=>blk_size } );
draw_cursor txt;
else
move_text_up { text=>txt_buf, from, to, nlines=>blk_size };
repair (txt, scroll_window_up { window=>txt_window, from, to, nlines=>blk_size } );
fi;
fi;
}; # fun scroll_up
# Scroll the text starting at line "from" down "n" lines.
#
fun scroll_down (txt, from, n)
=
{ txt -> TEXT { size=>TEXT_SIZE { rows, ... }, txt_buf, txt_window, cursor };
#
to = from + n;
blk_size = rows - to;
interfere
=
case cursor
{ is_on=>TRUE, pos => CHAR_POINT { row, ... } } => from <= row;
_ => FALSE;
esac;
if (n > 0 and 0 <= from and to <= rows)
#
if interfere
#
erase_cursor txt;
move_text_down { text=>txt_buf, from, to, nlines=>blk_size };
repair (txt, scroll_window_down { window=>txt_window, from, to, nlines=>blk_size } );
draw_cursor txt;
else
move_text_down { text=>txt_buf, from, to, nlines=>blk_size };
repair (txt, scroll_window_down { window=>txt_window, from, to, nlines=>blk_size } );
fi;
fi;
}; # fun scroll_down
# Delete "nlines" starting from "from"
#
fun delete_lines (txt, from, nlines)
=
{ txt -> TEXT { size=>TEXT_SIZE { rows, ... }, txt_buf, txt_window, cursor };
#
to = from + nlines;
blk_size = rows - to;
interfere
=
case cursor
#
{ is_on=>TRUE, pos => CHAR_POINT { row, ... } }
=>
from <= row;
_ =>
FALSE;
esac;
if (nlines > 0 and 0 <= from and to <= rows)
#
if interfere
#
erase_cursor txt;
delete_text { text=>txt_buf, from, nlines };
repair (txt, delete_window_lines { window=>txt_window, from, to, nlines=>blk_size } );
draw_cursor txt;
else
delete_text { text=>txt_buf, from, nlines };
repair (txt, delete_window_lines { window=>txt_window, from, to, nlines=>blk_size } );
fi;
fi;
};
# Clear from "pos" to the end of the line
#
fun clear_eol (txt, pos as CHAR_POINT { row, col } )
=
{ txt -> TEXT { size, txt_buf, txt_window, cursor };
interfere
=
case cursor
#
{ is_on=>TRUE, pos=>CHAR_POINT { row=>cr, col=>cc } }
=>
cr == row and col <= cc;
_ => FALSE;
esac;
if (in_text_window (size, pos))
#
clear_text_ln (txt_buf, pos);
clear_window_ln (txt_window, pos);
interfere ?: draw_cursor txt;
fi;
};
# Clear from "pos" to the end of the screen:
#
fun clear_eos (txt, pos as CHAR_POINT { row, col } )
=
{ my (pos as CHAR_POINT { row, ... } )
=
col != 0 ?? { clear_eol (txt, pos); CHAR_POINT { row=>row+1, col=>0 }; }
:: pos;
txt -> TEXT { size as TEXT_SIZE { rows, ... }, txt_buf, txt_window, cursor };
interfere
=
case cursor
#
{ is_on=>TRUE, pos => CHAR_POINT { row=>cr, ... } }
=>
row <= cr;
_ => FALSE;
esac;
if (in_text_window (size, pos))
#
clear_text { text => txt_buf, from => row, to => rows };
clear_window { window => txt_window, from => row, to => rows };
interfere ?: draw_cursor txt;
fi;
};
# Will text drawing interfere with cursor?
#
fun fix_cursor (TEXT { cursor=> { is_on=>FALSE, ... }, ... }, _, _)
=>
();
fix_cursor (txt, CHAR_POINT { row, col }, str)
=>
{ txt -> TEXT { cursor=> { pos=>CHAR_POINT { row=>cr, col=>cc }, ... }, ... };
#
if (cr == row
and cc >= col
and cc < col + string::length_in_bytes str
)
draw_cursor txt;
fi;
};
end;
# Draw "str" at "pos" in normal mode
#
fun write_string (txt, pos as CHAR_POINT { row, col }, str)
=
{ txt -> TEXT { size, txt_buf, txt_window, ... };
#
if (in_text_window (size, pos))
#
str = clip_string (size, col, str);
write_ntext (txt_buf, row, col, str);
draw_ntext { window=>txt_window, row, col, text=>str };
fix_cursor (txt, pos, str);
fi;
};
# Draw "str" at "pos" in highlighted mode
#
fun highlight_string (txt, pos as CHAR_POINT { row, col }, str)
=
{ txt -> TEXT { size, txt_buf, txt_window, ... };
#
if (in_text_window (size, pos))
#
str = clip_string (size, col, str);
write_htext (txt_buf, row, col, str);
draw_htext { window=>txt_window, row, col, text=>str };
fix_cursor (txt, pos, str);
fi;
};
# Insert text at pos.
#
fun insert_text (txt, pos as CHAR_POINT { row, col }, str, highlight)
=
{ txt -> TEXT { size, txt_buf, txt_window, cursor };
#
interfere
=
case cursor
#
{ is_on=>TRUE, pos=>CHAR_POINT { row=>cr, col=>cc } }
=>
(cr == row) and (col <= cc);
_ => FALSE;
esac;
if (in_text_window (size, pos))
#
str = clip_string (size, col, str);
insert_buf_text (txt_buf, row, col, str, highlight);
repair (txt, insert_window_text (txt_window, pos, str, highlight));
interfere ?: draw_cursor txt;
fi;
};
# Delete count characters at position pos.
# Fill with spaces on right.
# Assume count > 0.
#
fun delete_chars (txt, pos as CHAR_POINT { row, col }, count)
=
{ txt -> TEXT { size, txt_buf, txt_window, cursor };
#
interfere
=
case cursor
#
{ is_on=>TRUE, pos=>CHAR_POINT { row=>cr, col=>cc } }
=>
cr == row and col <= cc;
_ => FALSE;
esac;
if (in_text_window (size, pos))
#
delete_text_chars (txt_buf, row, col, count);
repair (txt, delete_window_chars (txt_window, pos, count));
interfere ?: draw_cursor txt;
fi;
};
fun move_cursor (txt, new_pos)
=
{ txt -> TEXT { size, txt_buf, txt_window, cursor as { is_on, pos } };
#
if (in_text_window (size, new_pos) and (pos != new_pos))
#
new_txt = TEXT { size, txt_buf, txt_window, cursor => { is_on, pos=>new_pos } };
if is_on
erase_cursor txt;
draw_cursor new_txt;
fi;
new_txt;
else
txt;
fi;
};
fun set_cursor (txt as TEXT { size, txt_buf, txt_window, cursor => { is_on, pos }}, on)
=
{ new_txt = TEXT { size, txt_buf, txt_window, cursor => { is_on => on, pos } };
#
case (is_on, on)
( TRUE, FALSE) => erase_cursor txt;
(FALSE, TRUE ) => draw_cursor new_txt;
_ => ();
esac;
new_txt;
};
# ** The text widget ***
# The text widget is represented by a plea/reply pair of communication
# channels.
#
Plea_Mail
= GET_INFO
| GET_CURSOR_INFO
| SCROLL_UP { from: Int, nlines: Int }
| SCROLL_DOWN { from: Int, nlines: Int }
| DELETE_LINES { lnum: Int, nlines: Int }
| CLEAR_LINE Char_Point
| CLEAR_SCR Char_Point
| WRITE_STRING { pos: Char_Point, str: String }
| HIGHLIGHT_STRING { pos: Char_Point, str: String }
| INSERT_TEXT { pos: Char_Point, str: String, highlight: Bool }
| DELETE_CHARS { pos: Char_Point, count: Int }
| MOVE_CURSOR Char_Point
| SET_CURSOR Bool
;
Reply_Mail
= INFO Text_Size
| CURSOR_INFO { is_on: Bool, pos: Char_Point }
;
Text_Widget
=
TEXT_WIDGET
{
widget: wg::Widget,
query: Plea_Mail -> Reply_Mail,
cmd: Plea_Mail -> Void
};
# Create a new text widget:
#
fun make_text_widget
root_window
{ rows: Int,
cols: Int
}
=
{ rows = max (rows, 1);
cols = max (cols, 1);
plea_slot = make_mailslot ();
reply_slot = make_mailslot ();
plea' = take_from_mailslot' plea_slot;
font = xc::find_else_open_font (wg::xsession_of root_window) font_name;
(font_info font)
->
(char_high, char_wide, _);
fun realize_widget { kidplug, window, window_size }
=
{ (xc::ignore_mouse_and_keyboard kidplug)
->
xc::KIDPLUG { from_other', to_mom, ... };
tsz = make_text_size (window_size, font);
text = TEXT {
size => tsz,
txt_buf => make_text_buf tsz,
txt_window => make_text_window (root_window, window, font, tsz),
cursor => { is_on => FALSE, pos=>CHAR_POINT { row=>0, col=>0 }}
};
fun imp_loop text
=
{
fun do_other envelope
=
case (xc::get_contents_of_envelope envelope)
#
xc::ETC_REDRAW damage
=>
{ redraw (text, damage);
imp_loop text;
};
xc::ETC_RESIZE new_r
=>
imp_loop (resize (text, font, new_r));
xc::ETC_OWN_DEATH
=>
thread_exit { success => TRUE };
_ => impossible("macroExpand",
"[text_widget: unexpected CI message]");
esac;
fun do_plea (GET_INFO)
=>
{ put_in_mailslot (reply_slot, INFO (get_info text));
imp_loop text;
};
do_plea (GET_CURSOR_INFO)
=>
{ put_in_mailslot (reply_slot, CURSOR_INFO (get_cursor_info text));
imp_loop text;
};
do_plea (SCROLL_UP { from, nlines } )
=>
{ scroll_up (text, from, nlines);
imp_loop text;
};
do_plea (SCROLL_DOWN { from, nlines } )
=>
{ scroll_down (text, from, nlines);
imp_loop text;
};
do_plea (DELETE_LINES { lnum, nlines } )
=>
{ delete_lines (text, lnum, nlines);
imp_loop text;
};
do_plea (CLEAR_LINE cc)
=>
{ clear_eol (text, cc);
imp_loop text;
};
do_plea (CLEAR_SCR cc)
=>
{ clear_eos (text, cc);
imp_loop text;
};
do_plea (HIGHLIGHT_STRING { pos, str } )
=>
{ highlight_string (text, pos, str);
imp_loop text;
};
do_plea (WRITE_STRING { pos, str } )
=>
{ write_string (text, pos, str);
imp_loop text;
};
do_plea (INSERT_TEXT { pos, str, highlight } )
=>
{ insert_text (text, pos, str, highlight);
imp_loop text;
};
do_plea (DELETE_CHARS { pos, count } )
=>
{ delete_chars (text, pos, count);
imp_loop text;
};
do_plea (MOVE_CURSOR cc)
=>
imp_loop (move_cursor (text, cc));
do_plea (SET_CURSOR on)
=>
imp_loop (set_cursor (text, on));
end;
block_until_mailop_fires (
cat_mailops
[
from_other' ==> do_other,
plea' ==> do_plea
]
);
};
xlogger::make_thread "text_widget_imp" {.
#
imp_loop text;
};
();
};
TEXT_WIDGET
{
query => (\\ plea = { put_in_mailslot (plea_slot, plea); take_from_mailslot reply_slot; }),
cmd => (\\ plea = put_in_mailslot (plea_slot, plea)),
widget => wg::make_widget
{
root_window,
args => \\ () = { background => NULL },
size_preference_thunk_of
=>
\\ () = { col_preference => wg::INT_PREFERENCE { start_at=>tot_pad, step_by=>char_wide, min_steps=>1, best_steps=>cols, max_steps=>NULL },
row_preference => wg::INT_PREFERENCE { start_at=>tot_pad, step_by=>char_high, min_steps=>1, best_steps=>rows, max_steps=>NULL }
},
realize_widget
}
};
}; # fun make_text_widget
fun as_widget (TEXT_WIDGET { widget, ... } )
=
widget;
fun get_info (TEXT_WIDGET { query, ... } )
=
case (query GET_INFO)
#
INFO info => info;
_ => impossible ("getInfo", "[]");
esac;
fun char_size_of tw
=
{ (get_info tw)
->
TEXT_SIZE { rows, cols, ... };
{ rows, cols };
};
fun size_of tw
=
{ (get_info tw)
->
TEXT_SIZE { size, ... };
size;
};
fun point_to_coordinate tw point
=
{ (get_info tw)
->
TEXT_SIZE { size, char_high, char_wide, ... };
(g2d::point::clip (point, size))
->
{ col, row };
CHAR_POINT {
row => int::quot (row - pad, char_high),
col => int::quot (col - pad, char_wide)
};
};
fun coordinate_to_box tw (CHAR_POINT { row, col } )
=
{ (get_info tw)
->
TEXT_SIZE { char_wide, char_high, rows, cols, ... };
row = if (row < 0) 0; elif (row < rows) row; else (rows - 1); fi;
col = if (col < 0) 0; elif (col < cols) col; else (cols - 1); fi;
{ col => (col*char_wide) + pad,
row => (row*char_high) + pad,
#
wide => char_wide,
high => char_high
};
};
fun scroll_up (TEXT_WIDGET { cmd, ... } ) arg = cmd (SCROLL_UP arg);
fun scroll_down (TEXT_WIDGET { cmd, ... } ) arg = cmd (SCROLL_DOWN arg);
fun write_text (TEXT_WIDGET { cmd, ... } ) { at, text }
=
cmd (WRITE_STRING { pos=>at, str=>text } );
fun highlight_text (TEXT_WIDGET { cmd, ... } ) { at: Char_Point, text: String }
=
cmd (HIGHLIGHT_STRING { pos=>at, str=>text } );
fun insert_line (TEXT_WIDGET { cmd, ... } ) { lnum, text }
=
{ cmd (SCROLL_DOWN { from=>lnum, nlines=>1 } );
cmd (WRITE_STRING { pos=>CHAR_POINT { row=>lnum, col=>0 }, str=>text } );
};
fun insert_text (TEXT_WIDGET { cmd, ... } ) { at, text => ""}
=>
();
insert_text (TEXT_WIDGET { cmd, ... } ) { at, text }
=>
cmd (INSERT_TEXT { pos=>at, str=>text, highlight=>FALSE } );
end;
fun insert_highlight_text (TEXT_WIDGET { cmd, ... } ) { at: Char_Point, text: String }
=
cmd (INSERT_TEXT { pos=>at, str=>text, highlight=>TRUE } );
fun delete_line (TEXT_WIDGET { cmd, ... } ) lnum = cmd (DELETE_LINES { lnum, nlines => 1 } );
fun delete_lines (TEXT_WIDGET { cmd, ... } ) arg = cmd (DELETE_LINES arg);
fun delete_chars (TEXT_WIDGET { cmd, ... } ) { at: Char_Point, count: Int }
=
if (count > 0)
cmd (DELETE_CHARS { pos=>at, count } );
fi;
fun clear_to_eol (TEXT_WIDGET { cmd, ... } ) coord = cmd (CLEAR_LINE coord);
fun clear_to_eos (TEXT_WIDGET { cmd, ... } ) coord = cmd (CLEAR_SCR coord);
fun clear (TEXT_WIDGET { cmd, ... } )
=
cmd (CLEAR_SCR (CHAR_POINT { col=>0, row=>0 } ));
fun get_cursor_info (TEXT_WIDGET { query, ... } )
=
case (query GET_CURSOR_INFO)
#
CURSOR_INFO info => info;
_ => impossible ("getCursorInfo", "[]");
esac;
fun get_cursor_point tw
=
(get_cursor_info tw).pos;
fun move_cursor (TEXT_WIDGET { cmd, ... } ) pos = cmd (MOVE_CURSOR pos);
fun cursor_on (TEXT_WIDGET { cmd, ... } ) = cmd (SET_CURSOR TRUE);
fun cursor_off (TEXT_WIDGET { cmd, ... } ) = cmd (SET_CURSOR FALSE);
}; # package text_widget
end;