XTkCollectionsImpl.mesa
Copyright Ó 1989, 1991 by Xerox Corporation. All rights reserved.
Christian Jacobi, July 3, 1989 2:25:25 pm PDT
Christian Jacobi, June 12, 1992 10:42 am PDT
DIRECTORY
Rope,
Xl,
XTkCollections,
XTk,
XTkFriends;
XTkCollectionsImpl:
CEDAR
MONITOR
IMPORTS Xl, XTk, XTkCollections, XTkFriends
EXPORTS XTkCollections
SHARES XTk =
BEGIN OPEN XTk, XTkCollections;
collectionClass:
PUBLIC Class ¬ InitSuperClass[];
InitSuperClass:
PROC []
RETURNS [csc: ImplementorClass] = {
csc ¬ XTkFriends.CreateClass[[
key: $collectionSuper, classNameHint: $Collection,
wDataNum: 1, cDataNum: 1,
initInstPart: CollectionInitInstPart,
removeChildLR: NIL,
internalEnumerateChildren: InternalEnumerateChildren,
pleaseResizeChild: XTkFriends.PropagateUpPleaseResizeChild
]];
csc.cClassData[csc.cDataIdx] ¬
NEW[CollectionClassPartRec ¬ [
addChildLR: AddChildInFirstPlaceLR,
addChildrenLR: DefaultAddChildrenLR,
enumerateChildren: BasicEnumerateChildren
]];
};
dymmyChildren: REF ChildrenData ~ NEW[ChildrenData[0]];
GetCollectionClassPart:
PROC [collection: CollectionWidget]
RETURNS [CollectionClassPart] =
INLINE {
RETURN [ NARROW[XTkFriends.ClassPart[collection, collectionClass]] ]
};
CollectionInitInstPart: XTk.InitInstancePartProc = {
ip: CollectionInstPart ~ NEW[CollectionInstPartRec ¬ [children: dymmyChildren]];
IF widget.s.geometry.borderWidth<0 THEN widget.s.geometry.borderWidth ¬ 0;
XTkFriends.AssignInstPart[widget, collectionClass, ip];
};
Create:
PUBLIC
PROC [widgetSpec: XTk.WidgetSpec ¬ [], children:
LIST
OF Widget ¬
NIL, childCount:
NAT ¬ 0]
RETURNS [widget: CollectionWidget] = {
widget ¬ XTk.CreateWidget[widgetSpec, collectionClass];
IF childCount>0 THEN AssertEmptySlotsLR[widget, childCount]; --creation
IF children#NIL THEN AddChildrenLR[widget, children, FALSE]; --creation
};
RemoveChild:
PUBLIC
PROC [collection: CollectionWidget, child: Widget, reConsiderNow:
BOOL ¬
TRUE, preventDestruction:
BOOL ¬
FALSE] = {
rootTQ: Xl.TQ ~ collection.rootTQ;
action: PROC = {RemoveChildLR[collection, child, reConsiderNow, preventDestruction]};
IF rootTQ=
NIL
THEN action[] --container is not yet stuck into shell...
ELSE Xl.CallWithLock[rootTQ, action];
};
RemoveChildLR:
PUBLIC
PROC [collection: CollectionWidget, child: Widget, reConsiderNow:
BOOL ¬
TRUE, preventDestruction:
BOOL ¬
FALSE] = {
done: BOOL;
IF child.parent#collection THEN ERROR;
child.s.mapping ¬ MAX[unconfigured, child.s.mapping];
done ¬ XTkFriends.RemoveChildLR[collection, child];
IF done
THEN {
IF child.state<screened
THEN
XTkFriends.ConfigureLR[child, [], unconfigured, TRUE];
IF preventDestruction
THEN XTkFriends.ForgetScreenLR[child]
ELSE XTkFriends.OrphanizeLR[child, normal]
};
IF reConsiderNow THEN XTkFriends.ReconfigureChildrenLR[collection]
};
AddChild:
PUBLIC
PROC [collection: CollectionWidget, newChild: Widget, position:
REF ¬
NIL, reConsiderNow:
BOOL ¬
TRUE] = {
rootTQ: Xl.TQ ~ collection.rootTQ;
action: PROC = {AddChildLR[collection, newChild, position, reConsiderNow]};
IF rootTQ=
NIL
THEN action[] --container is not yet stuck into shell...
ELSE Xl.CallWithLock[rootTQ, action];
};
AddChildLR:
PUBLIC
PROC [collection: CollectionWidget, newChild: Widget, position:
REF ¬
NIL, reConsiderNow:
BOOL ¬
TRUE] = {
classPart: CollectionClassPart ~ GetCollectionClassPart[collection];
SELECT newChild.parent
FROM
NIL, collection => XTkFriends.AssignParentAndCheckScreenLR[newChild, collection];
ENDCASE => ERROR;
IF newChild.s.mapping=dontUse THEN newChild.s.mapping ¬ mapped;
classPart.addChildLR[collection, newChild, position, reConsiderNow];
};
AddChildren:
PUBLIC
PROC [collection: CollectionWidget, children:
LIST
OF Widget, reConsiderNow:
BOOL ¬
TRUE] = {
rootTQ: Xl.TQ ~ collection.rootTQ;
action: PROC = {AddChildrenLR[collection, children, reConsiderNow]};
IF rootTQ=
NIL
THEN action[] --container is not yet stuck into shell...
ELSE Xl.CallWithLock[rootTQ, action];
};
AddChildrenLR:
PUBLIC
PROC [collection: CollectionWidget, children:
LIST
OF Widget, reConsiderNow:
BOOL ¬
TRUE] = {
classPart: CollectionClassPart ~ GetCollectionClassPart[collection];
FOR l:
LIST
OF Widget ¬ children, l.rest
WHILE l#
NIL
DO
SELECT l.first.parent
FROM
NIL, collection => XTkFriends.AssignParentAndCheckScreenLR[l.first, collection];
ENDCASE => ERROR;
IF l.first.s.mapping=dontUse THEN l.first.s.mapping ¬ mapped;
ENDLOOP;
classPart.addChildrenLR[collection, children, reConsiderNow];
};
EnumerateChildren:
PUBLIC
PROC [collection: CollectionWidget, eachChild: EachChildProc, data:
REF ¬
NIL] = {
classPart: CollectionClassPart ~ GetCollectionClassPart[collection];
classPart.enumerateChildren[collection, eachChild, data];
};
Find:
PROC [ip: CollectionInstPart, child: Widget ¬
NIL, start:
NAT ¬ 0]
RETURNS [
INT¬-1] = {
FOR i:
NAT
IN [start..ip.slotsUsed)
DO
IF ip.children[i]=child THEN RETURN [i];
ENDLOOP;
};
RemoveXWindowsLR:
PROC [child: Widget] = {
IF child#
NIL
THEN {
p: Widget ¬ child.parent;
IF p#NIL THEN XTkFriends.ForgetScreenLR[child];
};
};
RemoveAndSquezeLR:
PROC [ip: CollectionInstPart, child: Widget]
RETURNS [idx:
INT] = {
idx ¬ Find[ip, child];
IF idx>=0
THEN {
ip.sizing ¬ NIL;
FOR i:
INT
IN (idx..ip.slotsUsed)
DO
ip.children[i-1] ¬ ip.children[i];
ENDLOOP;
ip.slotsUsed ¬ ip.slotsUsed-1;
ip.children[ip.slotsUsed] ¬ [NIL];
};
};
AssertEmptySlotsLR:
PUBLIC
PROC [collection: CollectionWidget, num:
NAT] = {
--Makes shure collection has at least num empty children slots
--Must be called on rootTQ only!!
ip: CollectionInstPart ~ GetCollectionInstPart[collection];
AssertEmptySlotsILR[ip, num];
};
AssertEmptySlotsILR:
PROC [ip: CollectionInstPart, num:
NAT] = {
oldCount: NAT ¬ ip.children.count;
IF num<1 THEN num ¬ 7;
IF ip.slotsUsed+num<=oldCount THEN RETURN;
IF ip.hasEmptySlots
THEN {
FOR i:
INT
IN [0..ip.slotsUsed)
DO
IF ip.children[i].child=NIL THEN {num ¬ num-1; IF num = 0 THEN RETURN};
ENDLOOP;
};
IF ip.slotsUsed+num<=oldCount THEN RETURN;
BEGIN
newCount: NAT ¬ MAX[oldCount+5, oldCount+oldCount+1, ip.slotsUsed+num];
newCd: REF ChildrenData ~ NEW[ChildrenData[newCount]];
ip.sizing ¬ NIL;
FOR i:
INT
IN [0..ip.slotsUsed)
DO
newCd.children[i] ¬ ip.children.children[i];
ENDLOOP;
ip.children ¬ newCd;
END;
};
RemoveChildInPlaceLR:
PUBLIC
PROC [widget, child: Widget]
RETURNS [done:
BOOL ¬
FALSE] = {
RemoveInPlaceLR:
PROC [ip: CollectionInstPart, child: Widget]
RETURNS [idx:
INT] = {
idx ¬ Find[ip, child];
IF idx>=0
THEN {
ip.sizing ¬ NIL;
ip.children[idx] ¬ [NIL];
IF idx+1=ip.slotsUsed
THEN ip.slotsUsed ¬ ip.slotsUsed-1
ELSE ip.hasEmptySlots ¬ TRUE;
};
};
ip: CollectionInstPart ~ GetCollectionInstPart[widget];
IF child=NIL THEN ERROR;
IF RemoveInPlaceLR[ip, child]>=0
THEN {
done ¬ TRUE;
RemoveXWindowsLR[child];
XTk.NoteChildChange[widget];
};
};
RemoveChildAndSqueezeLR:
PUBLIC
PROC [widget, child: Widget]
RETURNS [done:
BOOL ¬
FALSE] = {
SqueezeNRemoveLR:
PROC [ip: CollectionInstPart, child: Widget]
RETURNS [found:
BOOL¬
FALSE] = {
nextToUse, nextToWatch: NAT ¬ 0;
WHILE nextToWatch<ip.slotsUsed
DO
c: XTk.Widget ¬ ip.children[nextToWatch].child; nextToWatch ¬ nextToWatch+1;
SELECT
TRUE
FROM
c=NIL OR c.state=dead => {ip.sizing ¬ NIL; LOOP};
c=child => {found ¬ TRUE; ip.sizing ¬ NIL; LOOP};
ENDCASE => {
ip.children[nextToUse].child ¬ c; nextToUse ¬ nextToUse+1;
};
ENDLOOP;
FOR empty: NAT IN [nextToUse..ip.slotsUsed) DO ip.children[empty] ¬ [NIL] ENDLOOP;
ip.slotsUsed ¬ nextToUse;
ip.hasEmptySlots ¬ FALSE;
};
ip: CollectionInstPart ~ GetCollectionInstPart[widget];
IF child=NIL THEN ERROR;
IF SqueezeNRemoveLR[ip, child].found
THEN {
done ¬ TRUE;
RemoveXWindowsLR[child];
XTk.NoteChildChange[widget];
};
};
AddChildInFirstPlaceLR:
PUBLIC
PROC [collection: CollectionWidget, newChild: Widget, position:
REF, reConsiderNow:
BOOL] = {
IncludeHardLR:
PROC [ip: CollectionInstPart, newChild: Widget] = {
IncludeLR:
PROC [ip: CollectionInstPart, w: Widget]
RETURNS [
INT¬-1] = {
IF ip.hasEmptySlots
THEN {
idx: INT ~ Find[ip, NIL];
IF idx<0 THEN ERROR; --there was no empty slot
ip.children[idx] ¬ [w];
IF Find[ip, NIL, idx+1]<0 THEN ip.hasEmptySlots ¬ FALSE;
RETURN [idx]
};
IF ip.slotsUsed<ip.children.count
THEN {
idx: NAT ~ ip.slotsUsed;
ip.children[idx] ¬ [w];
ip.slotsUsed ¬ idx+1;
RETURN [idx];
};
-- no space available ! --
};
idx: INT ¬ IncludeLR[ip, newChild];
IF idx<0
THEN {
AssertEmptySlotsILR[ip, 1];
[] ¬ IncludeLR[ip, newChild];
};
};
ip: CollectionInstPart ~ GetCollectionInstPart[collection];
IF newChild=NIL OR newChild.parent#collection THEN ERROR;
IF Find[ip, newChild]>=0 THEN ERROR; --tried to include multiple times
IncludeHardLR[ip, newChild];
XTk.NoteChildChange[collection];
IF reConsiderNow THEN XTkFriends.ReconfigureChildrenLR[collection];
};
DefaultAddChildrenLR:
PROC [collection: CollectionWidget, children:
LIST
OF Widget, reConsiderNow:
BOOL] = {
classPart: CollectionClassPart ~ GetCollectionClassPart[collection];
FOR l:
LIST
OF Widget ¬ children, l.rest
WHILE l#
NIL
DO
classPart.addChildLR[collection, l.first, NIL, (l.rest#NIL AND reConsiderNow)];
ENDLOOP;
};
CountChildren:
PROC [collection: CollectionWidget]
RETURNS [n:
INT ¬ 0] = {
ip: CollectionInstPart ~ GetCollectionInstPart[collection];
FOR i:
NAT
IN [0..ip.slotsUsed)
DO
c: Widget ¬ ip.children[i];
IF c#NIL AND c.state<dead THEN n ¬ n+1
ENDLOOP;
};
BasicEnumerateChildren:
PUBLIC
PROC [collection: CollectionWidget, eachChild: EachChildProc, data:
REF ¬
NIL] = {
ip: CollectionInstPart ~ GetCollectionInstPart[collection];
FOR i:
NAT
IN [0..ip.slotsUsed)
DO
c: Widget ¬ ip.children[i];
IF c#
NIL
AND c.state<dead
THEN
IF eachChild[collection, c, data, i].stop THEN RETURN;
ENDLOOP;
};
InternalEnumerateChildren: XTk.InternalEnumerateChildrenProc = {
ip: CollectionInstPart ~ GetCollectionInstPart[self];
FOR i:
NAT
IN [0..ip.slotsUsed)
DO
c: Widget ¬ ip.children[i];
IF c#
NIL
AND c.state<dead
THEN {
IF proc[self, c, data].stop THEN {stop ¬ TRUE; RETURN};
};
ENDLOOP;
};
NewCollectionClassPart:
PUBLIC
PROC [class: XTk.ImplementorClass]
RETURNS [newClassPart: CollectionClassPart] = {
oldClassPart: CollectionClassPart ~ NARROW[class.cClassData[collectionClass.cDataIdx]];
newClassPart ¬ NEW[CollectionClassPartRec ¬ oldClassPart];
class.cClassData[collectionClass.cDataIdx] ¬ newClassPart;
};
END.