VTablesImpl:
CEDAR
MONITOR
LOCKS data
USING data: TableData
IMPORTS Buttons, Imager, Labels, Rope, RuntimeError, VFonts, ViewerOps
EXPORTS VTables
= BEGIN OPEN VTables;
ROPE: TYPE = Rope.ROPE;
Viewer: TYPE = ViewerClasses.Viewer;
TableData: TYPE = REF TableDataRep;
TableDataRep:
TYPE =
MONITORED
RECORD [
rows, columns: NAT ¬ 0,
installed, locked, staticSize: BOOL ¬ FALSE,
live: BOOL ¬ TRUE,
condition: CONDITION,
xRuleWidth: INTEGER ¬ 1,
yRuleWidth: INTEGER ¬ 1,
rowWidths: WidthSeq ¬ NIL,
colWidths: WidthSeq ¬ NIL,
width: INTEGER ¬ 0,
height: INTEGER ¬ 0,
request: INTEGER ¬ 0,
rowSeq: RowSeq];
RowSeq: TYPE = REF RowSeqRep;
RowSeqRep:
TYPE =
RECORD [
rowData: SEQUENCE nRows: NAT OF RowData];
RowData: TYPE = REF RowDataRep;
RowDataRep: TYPE = RECORD [colData: SEQUENCE nCols: NAT OF Entry];
Entry:
TYPE =
RECORD [
border: Border, useMaxSize: BOOL,
xoff,yoff: Offset, viewer: Viewer] ¬ NullEntry;
NullEntry: Entry = [NullBorder, TRUE, 0, 0, NIL];
Offset: TYPE = INTEGER;
textXoff: Offset ¬ 4; -- hack for $Text x offset
textYoff: Offset ¬ 1; -- hack for $Text y offset
wHack: INTEGER ¬ 12; -- hack for entry size calculated by text
hHack: INTEGER ¬ 3; -- hack for entry size calculated by text
WidthSeq: TYPE = REF WidthSeqRep;
WidthSeqRep: TYPE = RECORD [widths: SEQUENCE size: NAT OF INTEGER];
AcquireLock:
ENTRY
PROC [data: TableData, painting:
BOOL ¬
FALSE]
RETURNS [
BOOL] = {
acquire the lock on the data; if requireInstalled then we wait for installation as well; return the live flag; if FALSE is returned, the lock is not held
ENABLE UNWIND => NULL;
IF data #
NIL
THEN
WHILE data.live
DO
IF painting AND NOT data.installed THEN {data.request ¬ data.request + 1; EXIT};
IF NOT data.locked THEN {data.locked ¬ TRUE; RETURN [TRUE]};
WAIT data.condition;
ENDLOOP;
RETURN [FALSE];
};
ReleaseLock:
ENTRY
PROC [data: TableData, installed:
BOOL] = {
release the data lock; if install, then set the installed flag as well; then notify everyone else that the world is OK
data.locked ¬ FALSE;
data.installed ¬ installed;
BROADCAST data.condition;
};
SetInstalled:
ENTRY
PROC [data: TableData, installed:
BOOL] = {
data.installed ¬ installed;
BROADCAST data.condition;
};
NewRowSeq:
PROC [rows,columns:
NAT]
RETURNS [RowSeq] = {
rowSeq: RowSeq ¬ NEW[RowSeqRep[rows]];
FOR i:
NAT
IN [0..rows)
DO
rowSeq[i] ¬ NEW[RowDataRep[columns]]
ENDLOOP;
RETURN [rowSeq];
};
NewWidthSeq:
PROC [width:
NAT]
RETURNS [ws: WidthSeq] = {
ws ¬ NEW[WidthSeqRep[width]];
FOR i:
NAT
IN [0..width)
DO
ws[i] ¬ 0
ENDLOOP
};
RecalculateWidths:
PROC [data: TableData] = {
rowWidths: WidthSeq ¬ data.rowWidths;
colWidths: WidthSeq ¬ data.colWidths;
FOR row:
NAT
IN [0..data.rows)
DO
rowWidths[row] ¬ 0;
FOR col:
NAT
IN [0..data.columns)
DO
ent: Entry ¬ data.rowSeq[row][col];
v: Viewer ¬ ent.viewer;
IF row = 0 THEN colWidths[col] ¬ 0;
IF v #
NIL
THEN {
w: INTEGER ¬ v.ww + ABS[ent.xoff];
h: INTEGER ¬ v.wh + ABS[ent.yoff];
IF w > colWidths[col] THEN colWidths[col] ¬ w;
IF h > rowWidths[row] THEN rowWidths[row] ¬ h;
};
ENDLOOP;
ENDLOOP;
};
Create:
PUBLIC
PROC [
columns, rows:
INTEGER ¬ 1, name:
ROPE ¬
NIL, parent: Viewer ¬
NIL,
xRuleWidth:
INTEGER ¬ 1, yRuleWidth:
INTEGER ¬ 1,
x, y, w, h:
INTEGER ¬ 0, scrollable:
BOOL ¬
FALSE]
RETURNS [table: VTable ¬
NIL] =
TRUSTED {
data: TableData ¬ NEW[TableDataRep];
IF columns <= 0 OR rows <= 0 THEN RETURN [NIL];
IF name = NIL THEN name ¬ " ";
data.rows ¬ rows;
data.columns ¬ columns;
data.rowSeq ¬ NewRowSeq[rows, columns];
data.rowWidths ¬ NewWidthSeq[rows];
data.colWidths ¬ NewWidthSeq[columns];
data.xRuleWidth ¬ xRuleWidth;
data.yRuleWidth ¬ yRuleWidth;
data.staticSize ¬ w > 0 OR h > 0;
data.width ¬ w;
data.height ¬ h;
IF parent =
NIL
THEN
parent ¬
ViewerOps.CreateViewer [
flavor: $Container,
info: [name: name, column: right, iconic: TRUE],
paint: TRUE];
table ¬
ViewerOps.CreateViewer [
flavor: $VTable,
info: [
name: name, parent: parent, wx: x, wy: y, ww: w,
wh: h, data: data, border: FALSE, scrollable: scrollable],
paint: FALSE]
};
SetRowsAndColumns:
PUBLIC
PROC [table: VTable, rows, columns:
NAT ¬ 0] =
TRUSTED {
sets the number of rows and columns; can be used to either grow or shrink the table
data: TableData ¬ NARROW[table.data];
IF data #
NIL
AND AcquireLock[data]
THEN {
IF rows # data.rows
OR columns # data.columns
THEN {
ENABLE UNWIND => ReleaseLock[data, FALSE];
newRowSeq: RowSeq ¬ NewRowSeq[rows, columns];
SetInstalled[data, FALSE];
IF rows # data.rows
THEN {
newRowWidths: WidthSeq ¬ NewWidthSeq[rows];
FOR i:
NAT
IN [0..
MIN[rows, data.rows])
DO
newRowWidths[i] ¬ data.rowWidths[i];
ENDLOOP;
data.rowWidths ¬ newRowWidths;
};
IF columns # data.columns
THEN {
newColWidths: WidthSeq ¬ NewWidthSeq[columns];
FOR i:
NAT
IN [0..
MIN[columns, data.columns])
DO
newColWidths[i] ¬ data.colWidths[i];
ENDLOOP;
data.colWidths ¬ newColWidths;
};
FOR row:
NAT
IN [0..data.rows)
DO
FOR col:
NAT
IN [0..data.columns)
DO
oldEntry: Entry ¬ data.rowSeq[row][col];
IF row < rows
AND col < columns
THEN {
copy the entry (if any) from the old world
newRowSeq[row][col] ¬ oldEntry;
}
ELSE {
delete the old viewer
IF oldEntry.viewer #
NIL
THEN
ViewerOps.DestroyViewer[oldEntry.viewer, FALSE];
};
ENDLOOP;
ENDLOOP;
data.rows ¬ rows;
data.columns ¬ columns;
data.rowSeq ¬ newRowSeq; -- make this the last gasp
};
ReleaseLock[data, data.installed];
};
};
Install:
PUBLIC
PROC [table: VTable, paint:
BOOL ¬
TRUE] =
TRUSTED {
data: TableData ¬ NARROW[table.data];
IF data #
NIL
AND AcquireLock[data]
THEN {
ENABLE UNWIND => ReleaseLock[data, FALSE];
rows: NAT ¬ data.rows;
columns: NAT ¬ data.columns;
minX: INTEGER ¬ 0;
minY: INTEGER ¬ 0;
maxX: INTEGER ¬ minX;
maxY: INTEGER ¬ minY;
xRule: CARDINAL ¬ data.xRuleWidth;
yRule: CARDINAL ¬ data.yRuleWidth;
rowWidths: WidthSeq ¬ data.rowWidths;
colWidths: WidthSeq ¬ data.colWidths;
w: INTEGER ¬ table.ww;
h: INTEGER ¬ table.wh;
RecalculateWidths[data];
determine the row spacing
minY ¬ xRule;
FOR i:
NAT
IN [0..rows)
DO
row: RowData ¬ data.rowSeq[i];
rowWidth: INTEGER ¬ rowWidths[i];
minX ¬ yRule;
FOR j:
NAT
IN [0..columns)
DO
e: Entry ¬ row[j];
v: Viewer ¬ e.viewer;
colWidth: INTEGER ¬ colWidths[j];
IF v #
NIL
THEN {
vw: INTEGER ¬ v.ww;
vh: INTEGER ¬ v.wh;
IF e.useMaxSize
THEN {
vw ¬ colWidth-ABS[e.xoff];
vh ¬ rowWidth-ABS[e.yoff];
};
ViewerOps.EstablishViewerPosition[v, minX+e.xoff, minY+e.yoff, vw, vh];
};
minX ¬ minX + colWidth + yRule
ENDLOOP;
minY ¬ minY + rowWidth + xRule
ENDLOOP;
data.width ¬ minX;
data.height ¬ minY;
IF
NOT data.staticSize
THEN {
w ¬ data.width; h ¬ data.height};
ViewerOps.EstablishViewerPosition[table, table.wx, table.wy, w, h];
ReleaseLock[data, TRUE];
IF paint OR data.request # 0 THEN ViewerOps.PaintViewer[table, client];
};
};
GetTableEntry:
PUBLIC
PROC [table: VTable, row, column:
NAT ¬ 0]
RETURNS [v: Viewer ¬
NIL] =
TRUSTED {
retrieve the viewer at the given row and column
data: TableData ¬ NARROW[table.data];
IF data #
NIL
AND AcquireLock[data]
THEN {
IF row >= data.rows OR column >= data.columns THEN ReleaseAndFault[data];
v ¬ data.rowSeq[row][column].viewer;
ReleaseLock[data, data.installed];
};
};
SwapTableEntries:
PUBLIC
PROC
[table: VTable, row1, column1, row2, column2:
NAT ¬ 0, swapBorders:
BOOL ¬
FALSE]
=
TRUSTED {
swap the given table entries
data: TableData ¬ NARROW[table.data];
v: Viewer ¬ NIL;
IF data #
NIL
AND AcquireLock[data]
THEN {
IF row1 >= data.rows
OR column1 >= data.columns
OR row2 >= data.rows
OR column2 >= data.columns
THEN
ReleaseAndFault[data];
{
e1: Entry ¬ data.rowSeq[row1][column1];
e2: Entry ¬ data.rowSeq[row2][column2];
IF swapBorders
THEN {
data.rowSeq[row1][column1] ¬ e2;
data.rowSeq[row2][column2] ¬ e1}
ELSE {
data.rowSeq[row1][column1].viewer ¬ e2.viewer;
data.rowSeq[row2][column2].viewer ¬ e1.viewer}};
ReleaseLock[data, FALSE];
};
};
SetTableEntry:
PUBLIC
PROC [
table: VTable, row, column:
NAT ¬ 0,
name:
ROPE ¬
NIL, flavor:
ATOM ¬
NIL,
proc: Buttons.ButtonProc ¬
NIL, clientData:
REF ¬
NIL,
w, h:
INTEGER ¬ 0, xoff, yoff:
INTEGER ¬ 0,
border: Border ¬ FullBorder, font: VFonts.Font ¬
NIL,
displayStyle:
ATOM ¬
NIL, useMaxSize:
BOOL ¬
FALSE] =
TRUSTED {
v: Viewer ¬ NIL;
parent: Viewer ¬ table;
data: TableData ¬ NARROW[table.data];
flat: ROPE ¬ name.Flatten[];
textH, textW: INTEGER ¬ 0;
old: Entry ¬ NullEntry;
new: Entry ¬ NullEntry;
IF data #
NIL
AND AcquireLock[data]
THEN {
IF row >= data.rows
OR column >= data.columns
THEN
ReleaseAndFault[data];
old ¬ data.rowSeq[row][column];
IF font = NIL THEN font ¬ VFonts.defaultFont;
IF flat.Size[] # 0
THEN {
textW ¬ VFonts.StringWidth[flat, font];
textH ¬ VFonts.FontHeight[font];
};
SetInstalled[data, FALSE]; -- do this here!
{
ENABLE UNWIND => ReleaseLock[data, FALSE];
IF flavor = NIL THEN flavor ¬ $Label;
IF proc # NIL THEN flavor ¬ $Button;
IF name = NIL THEN name ¬ "";
IF textW > w THEN w ¬ textW + wHack;
IF textH > h THEN h ¬ textH + hHack;
new.xoff ¬ xoff;
new.yoff ¬ yoff;
new.useMaxSize ¬ useMaxSize;
SELECT flavor
FROM
$Button => {
v ¬
Buttons.Create [
info: [name: name, parent: parent, wx: 0, wy: 0, ww: w, wh: h, border: FALSE],
proc: proc,
clientData: clientData,
fork: TRUE,
paint: FALSE,
font: font];
IF displayStyle #
NIL
THEN
Buttons.SetDisplayStyle[v, displayStyle, FALSE];
};
$Label => {
v ¬
Labels.Create [
info: [parent: parent, name: name, wx: 0, wy: 0, ww: w, wh: h,
border: FALSE], font: font, paint: FALSE];
IF displayStyle #
NIL
THEN
Labels.SetDisplayStyle[v, displayStyle, FALSE];
};
$Text => {
h ¬ h - textYoff; -- make height of text, labels & buttons similar
v ¬ ViewerOps.CreateViewer [
flavor: $Text,
info: [parent: parent, wx: 0, wy: 0, ww: w, wh: h, scrollable: FALSE, border: FALSE],
paint: FALSE];
v.class.set[v, name, FALSE];
new.xoff ¬ textXoff + xoff;
new.yoff ¬ textYoff + yoff;
};
$Viewer =>
WITH clientData
SELECT
FROM
vv: Viewer => v ¬ vv;
ENDCASE;
ENDCASE =>
v ¬ ViewerOps.CreateViewer [
flavor: flavor,
info: [name: name, parent: parent, wx: 0, wy: 0, ww: w, wh: h, data: clientData, border: FALSE]];
IF old.viewer # v
AND old.viewer #
NIL
THEN
ViewerOps.DestroyViewer[old.viewer, FALSE];
new.viewer ¬ v;
new.border ¬ border;
data.rowSeq[row][column] ¬ new;
};
ReleaseLock[data, FALSE];
};
};
GetEntryBorder:
PUBLIC
PROC [table: VTable, row, column:
NAT ¬ 0]
RETURNS [border: Border ¬ NullBorder] = {
get the current table entry at the given row and column
data: TableData ¬ NARROW[table.data];
IF data #
NIL
AND AcquireLock[data]
THEN {
IF row >= data.rows OR column >= data.columns THEN ReleaseAndFault[data];
border ¬ data.rowSeq[row][column].border;
ReleaseLock[data, data.installed];
};
};
SetEntryBorder:
PUBLIC
PROC
[table: VTable, row, column:
NAT ¬ 0, border: Border ¬ FullBorder] = {
get the current table entry at the given row and column
data: TableData ¬ NARROW[table.data];
IF data #
NIL
AND AcquireLock[data]
THEN {
IF row >= data.rows OR column >= data.columns THEN ReleaseAndFault[data];
data.rowSeq[row][column].border ¬ border;
ReleaseLock[data, FALSE];
};
};
GetEntryOffset:
PUBLIC
PROC [table: VTable, row, column:
NAT ¬ 0]
RETURNS [xoff,yoff:
INTEGER ¬ 0] = {
get the current offsets of the given entry
data: TableData ¬ NARROW[table.data];
IF data #
NIL
AND AcquireLock[data]
THEN {
IF row >= data.rows OR column >= data.columns THEN ReleaseAndFault[data];
xoff ¬ data.rowSeq[row][column].xoff;
yoff ¬ data.rowSeq[row][column].yoff;
ReleaseLock[data, data.installed];
};
};
SetEntryOffset:
PUBLIC
PROC
[table: VTable, row, column:
NAT ¬ 0, xoff,yoff:
INTEGER ¬ 0] = {
set the current table border at the given row and column; reinstallation is required
data: TableData ¬ NARROW[table.data];
IF data #
NIL
AND AcquireLock[data]
THEN {
IF row >= data.rows OR column >= data.columns THEN ReleaseAndFault[data];
data.rowSeq[row][column].xoff ¬ xoff;
data.rowSeq[row][column].yoff ¬ yoff;
ReleaseLock[data, FALSE];
};
};
GetRowsAndColumns:
PUBLIC
PROC [table: VTable]
RETURNS [rows, columns:
NAT ¬ 0] = {
data: TableData ¬ NARROW[table.data];
IF data #
NIL
AND AcquireLock[data]
THEN {
rows ¬ data.rows;
columns ¬ data.columns;
ReleaseLock[data, data.installed];
};
};
ExchangeRows:
PUBLIC
PROC [table: VTable, row1,row2:
NAT ¬ 0] = {
exchange the two given rows; reinstallation is required
data: TableData ¬ NARROW[table.data];
IF data #
NIL
AND AcquireLock[data]
THEN {
IF row1 >= data.rows OR row2 >= data.rows THEN ReleaseAndFault[data];
{
-- exchange the rows
temp: RowData ¬ data.rowSeq[row1];
data.rowSeq[row1] ¬ data.rowSeq[row2];
data.rowSeq[row2] ¬ temp};
ReleaseLock[data, FALSE];
};
};
ExchangeColumns:
PUBLIC
PROC [table: VTable, column1,column2:
NAT ¬ 0] = {
exchange the two given columns; reinstallation is required
data: TableData ¬ NARROW[table.data];
IF data #
NIL
AND AcquireLock[data]
THEN {
IF column1 >= data.columns
OR column2 >= data.columns
THEN
ReleaseAndFault[data];
FOR row:
NAT
IN [0..data.rows)
DO
temp: Entry ¬ data.rowSeq[row][column1];
data.rowSeq[row][column1] ¬ data.rowSeq[row][column2];
data.rowSeq[row][column2] ¬ temp;
ENDLOOP;
ReleaseLock[data, FALSE];
};
};
paint and destroy procedures
TablePainter: ViewerClasses.PaintProc =
TRUSTED {
[self: ViewerClasses.Viewer, context: Imager.Context, whatChanged: REF ANY, clear: BOOL] RETURNS [quit: BOOL ← FALSE]
Just paint the rules for the table; the children will be painted after this painting.
table: VTable ¬ self;
WITH self.data
SELECT
FROM
data: TableData =>
IF AcquireLock[data,
TRUE]
THEN {
ENABLE UNWIND => ReleaseLock[data, FALSE];
xPos: INTEGER ¬ 0;
xLim: INTEGER ¬ data.width;
yPos: INTEGER ¬ 0;
yLim: INTEGER ¬ data.height;
rows: NAT ¬ data.rows;
columns: NAT ¬ data.columns;
xWidth: INTEGER ¬ data.xRuleWidth;
yWidth: INTEGER ¬ data.yRuleWidth;
Imager.SetColor[context, Imager.black];
paint the horizontals
FOR row:
NAT
DECREASING
IN [0..rows]
DO
yLast: INTEGER ¬ yPos + xWidth;
xPos ¬ 0;
FOR col:
NAT
IN [0..columns)
DO
prev: Border ¬
IF row = rows THEN NullBorder ELSE data.rowSeq[row][col].border;
this: Border ¬
IF row = 0 THEN NullBorder ELSE data.rowSeq[row-1][col].border;
xLast: INTEGER ¬ xPos + data.colWidths[col] + yWidth;
IF prev.down
OR this.up
THEN {
include this edge
Imager.MaskBox[context, [xPos, yPos, xLast+yWidth, yLast]]};
xPos ¬ xLast;
ENDLOOP;
IF row = 0 THEN EXIT;
yPos ¬ yLast + data.rowWidths[row-1];
ENDLOOP;
paint the verticals
xPos ¬ 0;
FOR col:
NAT
IN [0..columns]
DO
xLast: INTEGER ¬ xPos + yWidth;
yPos ¬ 0;
FOR row:
NAT
DECREASING
IN [0..rows)
DO
prev: Border ¬
IF col = 0
THEN
NullBorder ELSE
data.rowSeq[row][col-1].border;
this: Border ¬
IF col = columns
THEN NullBorder
ELSE data.rowSeq[row][col].border;
yLast: INTEGER ¬ yPos + data.rowWidths[row] + xWidth;
IF prev.right
OR this.left
THEN {
include this edge
Imager.MaskBox[context, [xPos, yPos, xLast, yLast + xWidth]]};
yPos ¬ yLast;
ENDLOOP;
IF col = columns THEN EXIT;
xPos ¬ xLast + data.colWidths[col];
ENDLOOP;
data.request ¬ 0;
ReleaseLock[data, TRUE];
RETURN [FALSE];
};
ENDCASE;
RETURN [TRUE]; -- don't try to paint the children!
};
TableDestroy: ViewerClasses.DestroyProc = {
[self: Viewer]
WITH self.data
SELECT
FROM
data: TableData =>
IF AcquireLock[data]
THEN {
data.live ¬ FALSE;
self.data ¬ NIL;
ReleaseLock[data, FALSE];
};
ENDCASE;
};
other procedures
MakeViewerClass:
PROC =
TRUSTED {
vTableClass: ViewerClasses.ViewerClass ¬ NEW[ViewerClasses.ViewerClassRec];
vTableClass.icon ¬ tool;
vTableClass.paint ¬ TablePainter;
vTableClass.destroy ¬ TableDestroy;
vTableClass.topDownCoordSys ¬ TRUE;
ViewerOps.RegisterViewerClass[$VTable, vTableClass]
};
ReleaseAndFault:
PROC [data: TableData] =
TRUSTED {
ReleaseLock[data, data.installed];
ERROR RuntimeError.BoundsFault;
};
DummyButtonProc: Buttons.ButtonProc = {
[parent: REF ANY, clientData: REF ANY ← NIL, mouseButton: Menus.MouseButton ← red, shift: BOOL ← FALSE, control: BOOL ← FALSE]
WITH parent
SELECT
FROM
v: ViewerClasses.Viewer => ViewerOps.BlinkViewer[v];
ENDCASE;
};
instance: Viewer ¬ NIL;
TestInstance:
PROC [useText:
BOOL ¬
TRUE] = {
instance ¬ Create[3, 3, "test"];
SetTableEntry[instance, 0, 0, "0-0 button *", $Button, DummyButtonProc];
IF useText
THEN
SetTableEntry[instance, 0, 1, "0-1 text **", $Text];
SetTableEntry[instance, 0, 2, "0-2 label ***"];
SetTableEntry[instance, 1, 0, "1-0 label ****"];
SetTableEntry[instance, 1, 1, "1-1 button *", $Button, DummyButtonProc];
IF useText
THEN
SetTableEntry[instance, 1, 2, "1-2 text **", $Text];
IF useText
THEN
SetTableEntry[instance, 2, 0, "2-0 text ***", $Text];
SetTableEntry[instance, 2, 1, "2-1 label ****"];
SetTableEntry[instance, 2, 2, "2-2 button ****", $Button, DummyButtonProc];
SetEntryBorder[instance, 2, 2, NullBorder];
Install[instance]
};
MakeViewerClass[]
END.