<<>> <> <> <> <> <> <> <<>> DIRECTORY AtomButtons, Basics, Feedback, GGCoreOps, GGCoreTypes, Imager, ImagerColor, ImagerTransformation, Rope; GGCoreOpsImpl: CEDAR PROGRAM IMPORTS Feedback, Imager, ImagerColor, 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] = { [[R: r, G: g, B: b]] Ź ImagerColor.RGBFromColor[ImagerColor.NarrowToOpConstantColor[color]]; }; 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.