<> <> <> <> <> <<>> DIRECTORY AtomButtons, Basics, Feedback, GGCoreOps, GGCoreTypes, Imager, ImagerColor, ImagerColorPrivate, ImagerTransformation, Rope; GGCoreOpsImpl: CEDAR PROGRAM IMPORTS Feedback, Imager, ImagerColor, ImagerColorPrivate, ImagerTransformation, Rope EXPORTS GGCoreOps = BEGIN Problem: PUBLIC SIGNAL [msg: Rope.ROPE] = Feedback.Problem; EachEventProc: TYPE = GGCoreOps.EachEventProc; EachRopeProc: TYPE = PROC [thisRope: Rope.ROPE] RETURNS [done: BOOL _ FALSE]; EventListt: TYPE = REF EventListtObj; -- spelled with two t's to indicate a "List and a Tail pointer" EventListtObj: TYPE = GGCoreTypes.EventListtObj; Event: TYPE = GGCoreTypes.Event; RopeListt: TYPE = REF RopeListtObj; RopeListtObj: TYPE = GGCoreTypes.RopeListtObj; ScalarButton: TYPE = AtomButtons.ScalarButton; NewEventListt: PUBLIC PROC [] RETURNS [listt: EventListt] = { listt _ NEW[EventListtObj _ [NIL, NIL]]; }; FlushEventListt: PUBLIC PROC [listt: EventListt] = { listt.list _ NIL; listt.tail _ NIL; }; AppendEvent: PUBLIC PROC [event: Event, listt: EventListt] = { IF listt.tail = NIL THEN { IF NOT listt.list = NIL THEN ERROR; listt.tail _ listt.list _ LIST[event]; } ELSE { listt.tail.rest _ LIST[event]; listt.tail _ listt.tail.rest; }; }; GetEventList: PUBLIC PROC [listt: EventListt] RETURNS [list: LIST OF Event] = { list _ listt.list; }; NoEvents: PUBLIC PROC [listt: EventListt] RETURNS [BOOL] = { RETURN[listt.list = NIL]; }; ForEachEvent: PUBLIC PROC [listt: EventListt, eachEventProc: EachEventProc] = { done: BOOL _ FALSE; FOR list: LIST OF Event _ listt.list, list.rest UNTIL list = NIL DO done _ eachEventProc[list.first]; IF done THEN RETURN; ENDLOOP; }; <<>> NewRopeListt: PUBLIC PROC [] RETURNS [listt: RopeListt] = { listt _ NEW[RopeListtObj _ [NIL, NIL]]; }; FlushRopeListt: PUBLIC PROC [listt: RopeListt] = { listt.list _ NIL; listt.tail _ NIL; }; AppendRope: PUBLIC PROC [rope: Rope.ROPE, listt: RopeListt] = { IF listt.tail = NIL THEN { IF NOT listt.list = NIL THEN ERROR; listt.tail _ listt.list _ LIST[rope]; } ELSE { listt.tail.rest _ LIST[rope]; listt.tail _ listt.tail.rest; }; }; NoRopes: PUBLIC PROC [listt: RopeListt] RETURNS [BOOL] = { RETURN[listt.list = NIL]; }; ForEachRope: PUBLIC PROC [listt: RopeListt, eachRopeProc: EachRopeProc] = { done: BOOL _ FALSE; FOR list: LIST OF Rope.ROPE _ listt.list, list.rest UNTIL list = NIL DO done _ eachRopeProc[list.first]; IF done THEN RETURN; ENDLOOP; }; <<>> <> <<>> StartList: PUBLIC PROC [] RETURNS [entityList, ptr: LIST OF REF ANY] = { ptr _ entityList _ NIL; }; AddEntity: PUBLIC PROC [entity: REF ANY, entityList, ptr: LIST OF REF ANY] RETURNS [newList, newPtr: LIST OF REF ANY] = { IF ptr = NIL THEN { IF NOT entityList = NIL THEN ERROR; newPtr _ newList _ CONS[entity, NIL]; RETURN; } ELSE { newList _ entityList; ptr.rest _ CONS[entity, NIL]; newPtr _ ptr.rest; }; }; <<>> List: PUBLIC PROC [ref1, ref2, ref3: REF ANY _ NIL] RETURNS [LIST OF REF ANY] = { RETURN[ SELECT TRUE FROM ref2=NIL => LIST[ref1], ref3=NIL => LIST[ref1, ref2], ENDCASE => LIST[ref1, ref2, ref3] ]; }; <> <<>> StartRealList: PUBLIC PROC [] RETURNS [entityList, ptr: LIST OF REAL] = { ptr _ entityList _ NIL; }; AddReal: PUBLIC PROC [entity: REAL, entityList, ptr: LIST OF REAL] RETURNS [newList, newPtr: LIST OF REAL] = { IF ptr = NIL THEN { IF NOT entityList = NIL THEN ERROR; newPtr _ newList _ CONS[entity, NIL]; RETURN; } ELSE { newList _ entityList; ptr.rest _ CONS[entity, NIL]; newPtr _ ptr.rest; }; }; AppendRealList: PUBLIC PROC [list1, list2: LIST OF REAL] RETURNS [result: LIST OF REAL] = { pos: LIST OF REAL; newCell: LIST OF REAL; <> IF list1 = NIL THEN RETURN[list2]; result _ CONS[list1.first, NIL]; pos _ result; FOR l: LIST OF REAL _ list1.rest, l.rest UNTIL l = NIL DO newCell _ CONS[l.first, NIL]; pos.rest _ newCell; pos _ newCell; ENDLOOP; pos.rest _ list2; }; RealCompareProc: TYPE = PROC[r1: REAL, r2: REAL] RETURNS [Basics.Comparison]; SortRealList: PUBLIC PROC [list: LIST OF REAL, ascending: BOOL _ TRUE] RETURNS [sortedList: LIST OF REAL] = { <> CompareAscending: RealCompareProc = { IF r1 < r2 THEN RETURN[less]; IF r1 > r2 THEN RETURN[greater] ELSE RETURN[equal]; }; CompareDescending: RealCompareProc = { IF r1 > r2 THEN RETURN[less]; IF r1 < r2 THEN RETURN[greater] ELSE RETURN[equal]; }; IF ascending THEN sortedList _ UniqueSortRealList[list, CompareAscending] ELSE sortedList _ UniqueSortRealList[list, CompareDescending]; }; <<>> SortRealListAux: PUBLIC PROC [list: LIST OF REAL, compareProc: RealCompareProc] RETURNS [LIST OF REAL] = { <<... destructively sorts the given list in increasing order according to compareProc. The sort is not stable, so order of equal elements is not preserved.>> InnerSort: PROC [head: LIST OF REAL, max: NAT] RETURNS [new, next: LIST OF REAL] = { mid: LIST OF REAL _ (new _ head).rest; IF mid = NIL THEN RETURN; next _ mid.rest; IF compareProc[new.first, mid.first] = greater THEN { <> mid.rest _ new; new _ mid; mid _ head; }; mid.rest _ NIL; IF next = NIL THEN RETURN; <> next _ (mid _ next).rest; IF next # NIL THEN { <> temp: LIST OF REAL _ next; next _ temp.rest; temp.rest _ NIL; IF compareProc[mid.first, temp.first] = greater THEN { <> mid.rest _ NIL; temp.rest _ mid; mid _ temp} }; <> new _ MergeRealList[new, mid, compareProc]; IF next = NIL THEN RETURN; <> FOR depth: NAT IN [2..max) DO [mid, next] _ InnerSort[next, depth]; new _ MergeRealList[new, mid, compareProc]; IF next = NIL THEN RETURN; ENDLOOP; }; IF list = NIL OR list.rest = NIL THEN RETURN [list]; RETURN [InnerSort[list, 32].new]; }; MergeRealList: PUBLIC PROC [x,y: LIST OF REAL, compareProc: RealCompareProc] RETURNS [new: LIST OF REAL] = { <<... destructively merges two lists according to compareProc. If the input lists are sorted in increasing order, then the output list will be sorted in increasing order.>> <> <> tail: LIST OF REAL _ NIL; <> IF x = NIL THEN RETURN [y]; IF y = NIL THEN RETURN [x]; new _ x; IF compareProc[x.first, y.first] = greater THEN {new _ y; y _ x; x _ new}; <> DO <> DO tail _ x; x _ x.rest; IF x = NIL THEN {tail.rest _ y; RETURN}; IF compareProc[x.first, y.first] = greater THEN EXIT; ENDLOOP; tail.rest _ y; <> DO tail _ y; y _ y.rest; IF y = NIL THEN {tail.rest _ x; RETURN}; IF compareProc[x.first, y.first] = less THEN EXIT; ENDLOOP; tail.rest _ x; ENDLOOP; }; UniqueSortRealList: PUBLIC PROC [list: LIST OF REAL, compareProc: RealCompareProc] RETURNS[LIST OF REAL] = { lag: LIST OF REAL _ list _ SortRealListAux[list, compareProc]; WHILE lag # NIL DO rest: LIST OF REAL _ lag.rest; IF rest = NIL THEN EXIT; IF compareProc[lag.first, rest.first] = equal THEN lag.rest _ rest.rest ELSE lag _ rest; ENDLOOP; RETURN[list]; }; <<>> <> <<>> StartBoolList: PUBLIC PROC [] RETURNS [entityList, ptr: LIST OF BOOL] = { ptr _ entityList _ NIL; }; AddBool: PUBLIC PROC [entity: BOOL, entityList, ptr: LIST OF BOOL] RETURNS [newList, newPtr: LIST OF BOOL] = { IF ptr = NIL THEN { IF NOT entityList = NIL THEN ERROR; newPtr _ newList _ CONS[entity, NIL]; RETURN; } ELSE { newList _ entityList; ptr.rest _ CONS[entity, NIL]; newPtr _ ptr.rest; }; }; AppendBoolList: PUBLIC PROC [list1, list2: LIST OF BOOL] RETURNS [result: LIST OF BOOL] = { pos: LIST OF BOOL; newCell: LIST OF BOOL; <> IF list1 = NIL THEN RETURN[list2]; result _ CONS[list1.first, NIL]; pos _ result; FOR l: LIST OF BOOL _ list1.rest, l.rest UNTIL l = NIL DO newCell _ CONS[l.first, NIL]; pos.rest _ newCell; pos _ newCell; ENDLOOP; pos.rest _ list2; }; <<>> <> <<>> StartNATList: PUBLIC PROC [] RETURNS [entityList, ptr: LIST OF NAT] = { ptr _ entityList _ NIL; }; AddNAT: PUBLIC PROC [entity: NAT, entityList, ptr: LIST OF NAT] RETURNS [newList, newPtr: LIST OF NAT] = { IF ptr = NIL THEN { IF NOT entityList = NIL THEN ERROR; newPtr _ newList _ CONS[entity, NIL]; RETURN; } ELSE { newList _ entityList; ptr.rest _ CONS[entity, NIL]; newPtr _ ptr.rest; }; }; AppendNATs: PUBLIC PROC [list1, list2: LIST OF NAT] RETURNS [result: LIST OF NAT] = { pos: LIST OF NAT; newCell: LIST OF NAT; <> IF list1 = NIL THEN RETURN[list2]; result _ CONS[list1.first, NIL]; pos _ result; FOR l: LIST OF NAT _ list1.rest, l.rest UNTIL l = NIL DO newCell _ CONS[l.first, NIL]; pos.rest _ newCell; pos _ newCell; ENDLOOP; pos.rest _ list2; }; <<>> <> <<>> StartScalarButtonList: PUBLIC PROC [] RETURNS [entityList, ptr: LIST OF ScalarButton] = { ptr _ entityList _ NIL; }; AddScalarButton: PUBLIC PROC [entity: ScalarButton, entityList, ptr: LIST OF ScalarButton] RETURNS [newList, newPtr: LIST OF ScalarButton] = { IF ptr = NIL THEN { IF NOT entityList = NIL THEN ERROR; newPtr _ newList _ CONS[entity, NIL]; RETURN; } ELSE { newList _ entityList; ptr.rest _ CONS[entity, NIL]; newPtr _ ptr.rest; }; }; AppendScalarButtons: PUBLIC PROC [list1, list2: LIST OF ScalarButton] RETURNS [result: LIST OF ScalarButton] = { pos: LIST OF ScalarButton; newCell: LIST OF ScalarButton; <> IF list1 = NIL THEN RETURN[list2]; result _ CONS[list1.first, NIL]; pos _ result; FOR l: LIST OF ScalarButton _ list1.rest, l.rest UNTIL l = NIL DO newCell _ CONS[l.first, NIL]; pos.rest _ newCell; pos _ newCell; ENDLOOP; pos.rest _ list2; }; PUChoiceList: PUBLIC PROC [r0, r1, r2, r3, r4, r5, r6, r7, r8, r9, r10, r11, r12, r13, r14, r15, r16, r17, r18, r19: AtomButtons.PopUpChoice _ [] ] RETURNS [list: AtomButtons.PopUpChoices] = { OPEN AtomButtons; InnerCons: PROC[r: PopUpChoice] = {rList _ CONS[r, rList]; }; rList: PopUpChoices; IF r0.action#NIL THEN InnerCons[r0]; IF r1.action#NIL THEN InnerCons[r1]; IF r2.action#NIL THEN InnerCons[r2]; IF r3.action#NIL THEN InnerCons[r3]; IF r4.action#NIL THEN InnerCons[r4]; IF r5.action#NIL THEN InnerCons[r5]; IF r6.action#NIL THEN InnerCons[r6]; IF r7.action#NIL THEN InnerCons[r7]; IF r8.action#NIL THEN InnerCons[r8]; IF r9.action#NIL THEN InnerCons[r9]; IF r10.action#NIL THEN InnerCons[r10]; IF r11.action#NIL THEN InnerCons[r11]; IF r12.action#NIL THEN InnerCons[r12]; IF r13.action#NIL THEN InnerCons[r13]; IF r14.action#NIL THEN InnerCons[r14]; IF r15.action#NIL THEN InnerCons[r15]; IF r16.action#NIL THEN InnerCons[r16]; IF r17.action#NIL THEN InnerCons[r17]; IF r18.action#NIL THEN InnerCons[r18]; IF r19.action#NIL THEN InnerCons[r19]; FOR dummy: PopUpChoices _ rList, dummy.rest UNTIL dummy=NIL DO list _ CONS[dummy.first, list]; ENDLOOP; }; <<>> <> <<>> BreakIntervalMOD: PUBLIC PROC [start, end, mod: NAT] RETURNS [s1, e1, s2, e2: INT] = { IF start >= mod OR end >= mod THEN ERROR; IF start <= end THEN RETURN[start, end, -1, -1]; RETURN[0, end, start, mod-1]; }; BreakIntervalMODLen: PUBLIC PROC [start, len, mod: NAT] RETURNS [s1, len1, s2, len2: INT] = { < [0, 3, 6, 1].>> < [2, 5, -1, -1].>> < [0, 7, 6, 1]. -- repeats 6 twice>> IF start >= mod OR len > mod + 1 THEN ERROR; IF start + len -1 < mod THEN RETURN[start, len, -1, -1]; RETURN[0, start+len-mod, start, mod-start]; }; InMODRegion: PUBLIC PROC [test: NAT, start, end, mod: NAT] RETURNS [BOOL] = { IF start = end THEN RETURN [test = start]; IF start < end THEN RETURN [test IN [start..end]]; RETURN [test IN [start..mod) OR test IN [0..end]]; }; <<>> <> ExtractRGB: PUBLIC PROC [color: ImagerColor.ConstantColor] RETURNS [r,g,b: REAL] = { rgb: ImagerColor.RGB; IF color=NIL THEN ERROR Problem["NIL color for ExtractRGB"]; rgb _ ImagerColorPrivate.RGBFromColor[color]; r _ rgb.R; g _ rgb.G; b _ rgb.B; }; EquivalentColors: PUBLIC PROC [color1, color2: Imager.Color] RETURNS [equal: BOOL _ FALSE] = { <> r1, g1, b1, r2, g2, b2: REAL; epsilon: REAL _ 1.0E-2; success: BOOL _ TRUE; IF color1=color2 THEN RETURN[TRUE]; IF color1=NIL OR color2=NIL THEN RETURN[FALSE]; WITH color1 SELECT FROM color1Constant: ImagerColor.ConstantColor => { WITH color2 SELECT FROM color2Constant: ImagerColor.ConstantColor => { [r1, g1, b1] _ ExtractRGB[color1Constant]; [r2, g2, b2] _ ExtractRGB[color2Constant]; equal _ (r1=r2 AND g1=g2 AND b1=b2) OR (ABS[r1-r2] equal _ FALSE; }; color1SampledBlack: ImagerColor.SampledBlack => { WITH color2 SELECT FROM color2SampledBlack: ImagerColor.SampledBlack => { equal _ color1SampledBlack.pa = color2SampledBlack.pa AND color1SampledBlack.clear = color2SampledBlack.clear <> }; ENDCASE => equal _ FALSE; }; color1SampledColor: ImagerColor.SampledColor => { WITH color2 SELECT FROM color2SampledColor: ImagerColor.SampledColor => { equal _ color1SampledColor.pa = color2SampledColor.pa AND color1SampledColor.colorOperator = color2SampledColor.colorOperator <> }; ENDCASE => equal _ FALSE; }; ENDCASE => equal _ FALSE; }; SetColor: PUBLIC PROC [dc: Imager.Context, color: Imager.Color, m: Imager.Transformation _ NIL] = { <> IF color = NIL THEN RETURN; WITH color SELECT FROM sampledBlack: ImagerColor.SampledBlack => { IF m # NIL THEN Imager.SetSampledBlack[dc, sampledBlack.pa, ImagerTransformation.Concat[sampledBlack.um, m], sampledBlack.clear] ELSE Imager.SetSampledBlack[dc, sampledBlack.pa, sampledBlack.um, sampledBlack.clear]; }; sampledColor: ImagerColor.SampledColor => { IF m # NIL THEN Imager.SetSampledColor[dc, sampledColor.pa, ImagerTransformation.Concat[sampledColor.um, m], sampledColor.colorOperator] ELSE Imager.SetSampledColor[dc, sampledColor.pa, sampledColor.um, sampledColor.colorOperator]; } ENDCASE => Imager.SetColor[dc, color]; }; TransformColor: PUBLIC PROC [color: Imager.Color, viewView: ImagerTransformation.Transformation] RETURNS [newColor: Imager.Color] = { <> WITH color SELECT FROM sampledBlack: ImagerColor.SampledBlack => { sampledBlack.um _ ImagerTransformation.Concat[sampledBlack.um, viewView]; }; sampledColor: ImagerColor.SampledColor => { sampledColor.um _ ImagerTransformation.Concat[sampledColor.um, viewView]; } ENDCASE => {}; newColor _ color; }; CopyColor: PUBLIC PROC [color: Imager.Color] RETURNS [copy: Imager.Color] = { WITH color SELECT FROM sampledBlack: ImagerColor.SampledBlack => { copy _ ImagerColor.MakeSampledBlack[sampledBlack.pa, ImagerTransformation.Copy[sampledBlack.um], sampledBlack.clear]; }; sampledColor: ImagerColor.SampledColor => { copy _ ImagerColor.MakeSampledColor[sampledColor.pa, ImagerTransformation.Copy[sampledColor.um], sampledColor.colorOperator]; } ENDCASE => copy _ color; }; <> BoolToRope: PUBLIC PROC [bool: BOOL] RETURNS [rope: Rope.ROPE] = { <> rope _ IF bool THEN "T" ELSE "F"; }; RopeToBool: PUBLIC PROC [rope: Rope.ROPE] RETURNS [bool: BOOL] = { <> SELECT TRUE FROM Rope.Equal[rope, "F", FALSE] => bool _ FALSE; Rope.Equal[rope, "T", FALSE] => bool _ TRUE; ENDCASE => ERROR; }; END.