<> <> <> <<>> DIRECTORY AMBridge USING [IsRemote, ReadOnlyRefFromTV, TVForATOM, TVForReadOnlyReferent, TVForROPE], AMTypes USING [TV], Basics USING [NonNegative], IO USING [PutRope], PrintTV USING [Print, RefPrintProc, RegisterTVPrintProc, TVPrintProc], Rope USING [ROPE], Rosary USING [ActionType, Buffer, bufferSize, Item, MapRunsProc, maxHeight, nullSegment, RosaryRep, ROSARY, Run, RunActionType, Segment, SubstrProc]; RosaryImpl: CEDAR PROGRAM IMPORTS AMBridge, Basics, IO, PrintTV EXPORTS Rosary ~ BEGIN OPEN Rosary; Malformed: PUBLIC ERROR ~ CODE; NonNeg: PROC [value: INT] RETURNS [INT] ~ Basics.NonNegative; Size: PUBLIC PROC [r: ROSARY] RETURNS [INT] ~ { RETURN [IF r = NIL THEN 0 ELSE r.size] }; InlineSize: PROC [r: ROSARY] RETURNS [INT] ~ INLINE { RETURN [IF r = NIL THEN 0 ELSE r.size] }; BoundsCheck: PROC [i: INT, max: INT] ~ INLINE { < max or i < 0;>> boundsCheck: [0..0] ~ MIN[max-NonNeg[i], 0]; }; Fetch: PUBLIC PROC [base: ROSARY, index: INT] RETURNS [Item] ~ { BoundsCheck[index, InlineSize[base]-1]; DO WITH base SELECT FROM f: REF RosaryRep.leaf => {RETURN [f.item]}; c: REF RosaryRep.concat => { pos: INT ~ c.base.size; IF index < pos THEN base _ c.base ELSE {base _ c.rest; index _ index-pos}; }; o: REF RosaryRep.object => { it: Item _ NIL; a: PROC [item: Item, repeat: INT] RETURNS [quit: BOOLEAN _ TRUE] ~ {it _ item}; [] _ o.mapRuns[[base, index, 1], a]; RETURN [it]; }; ENDCASE => ERROR Malformed; ENDLOOP; }; FetchRun: PUBLIC PROC [base: ROSARY, index: INT] RETURNS [Run] ~ { BoundsCheck[index, InlineSize[base]-1]; DO WITH base SELECT FROM f: REF RosaryRep.leaf => {RETURN [[f.item, f.size-index]]}; c: REF RosaryRep.concat => { pos: INT ~ c.base.size; IF index < pos THEN base _ c.base ELSE {base _ c.rest; index _ index-pos}; }; o: REF RosaryRep.object => { run: Run _ [NIL, 0]; a: PROC [item: Item, repeat: INT] RETURNS [quit: BOOLEAN _ TRUE] ~ { run _ [item, repeat] }; [] _ o.mapRuns[FixSegment[[base, index]], a]; RETURN [run] }; ENDCASE => ERROR Malformed; ENDLOOP; }; FromItem: PUBLIC PROC [item: Item, repeat: INT] RETURNS [ROSARY] ~ { r: REF RosaryRep.leaf _ NEW[RosaryRep.leaf]; r.size _ repeat; r.height _ 1; r.item _ item; RETURN [r]; }; Substr: PUBLIC PROC [base: ROSARY, start: INT, len: INT] RETURNS [ROSARY] ~ { [[base, start, len]] _ FixSegment[[base, start, len]]; IF base = NIL OR (start = 0 AND len = base.size) THEN RETURN [base]; RETURN [CatSegments[[base, start, len], nullSegment, nullSegment]]; }; LazyConcat: PROC [base, rest: ROSARY] RETURNS [ROSARY] ~ { <> IF base=NIL THEN RETURN [rest]; IF rest=NIL THEN RETURN [base]; BoundsCheck[base.size, LAST[INT]-NonNeg[rest.size]]; IF base=NIL THEN RETURN [rest] ELSE IF rest=NIL THEN RETURN [base] ELSE { r: REF RosaryRep.concat _ NEW[RosaryRep.concat]; r.size _ base.size + rest.size; r.height _ 1+MAX[base.height, rest.height]; r.base _ base; r.rest _ rest; RETURN [r]; }; }; Concat: PUBLIC PROC [base, rest: ROSARY] RETURNS [ROSARY] ~ { IF base=NIL THEN RETURN [rest]; IF rest=NIL THEN RETURN [base]; IF base.height >= maxHeight-1 OR rest.height >= maxHeight-1 THEN { RETURN [CatSegments[[base], [rest], nullSegment]]; } ELSE RETURN [LazyConcat[base, rest]]; }; Cat: PUBLIC PROC [r0, r1, r2, r3, r4: ROSARY] RETURNS [ROSARY] ~ { RETURN [Concat[Concat[r0,r1], Concat[Concat[r2, r3], r4]]]; }; CatSegments: PUBLIC PROC [s0, s1, s2: Segment] RETURNS [ROSARY] ~ { a: ARep; -- An extensible array that is very cheap if it is small. aN: INT _ 0; AElement: TYPE ~ ROSARY; d: NAT ~ 40; ARep: TYPE ~ RECORD[index: INT_0, sub: ARRAY [0..d) OF AElement, rest: REF ARep_NIL]; accel: REF ARep _ NIL; StoreA: PROC [i: INT, e: AElement] ~ { IF i-a.index < d THEN a.sub[i-a.index] _ e ELSE { IF a.rest = NIL THEN {a.rest _ accel _ NEW[ARep]; accel.index _ d}; IF i < accel.index THEN accel _ a.rest; WHILE i-accel.index >= d DO IF accel.rest = NIL THEN {accel.rest _ NEW[ARep]; accel.rest.index_accel.index+d}; accel _ accel.rest; ENDLOOP; accel.sub[i-accel.index] _ e; }; }; ASub: PROC [i: INT] RETURNS [e: AElement] ~ { IF i-a.index < d THEN e _ a.sub[i-a.index] ELSE { IF i < accel.index THEN accel _ a.rest; WHILE i-accel.index >= d DO accel _ accel.rest ENDLOOP; e _ accel.sub[i-accel.index]; }; }; nb: NAT _ 0; b: Item _ NIL; Flush: PROC ~ { IF nb > 0 THEN { f: REF RosaryRep.leaf _ NEW[RosaryRep.leaf]; f.size _ nb; f.height _ 1; f.item _ b; nb _ 0; b _ NIL; StoreA[aN, f]; aN _ aN + 1; }; }; CheckItem: PROC[new: Item] ~ { <> IF nb = 0 AND aN > 0 THEN { WITH ASub[aN-1] SELECT FROM f: REF RosaryRep.leaf => { IF f.item = new THEN { b _ new; nb _ f.size; aN _ aN - 1; }; }; ENDCASE => NULL; }; }; SaveSegment: PROC [segment: Segment] ~ { IF segment.base # NIL THEN WITH segment.base SELECT FROM f: REF RosaryRep.leaf => { CheckItem[f.item]; IF nb > 0 AND b = f.item THEN nb _ nb + segment.size ELSE { Flush[]; IF segment.start = 0 AND segment.size = f.size THEN {StoreA[aN, f]; aN _ aN + 1} ELSE {b _ f.item; nb _ segment.size}; }; }; ENDCASE => { IF segment.start = 0 AND segment.size = segment.base.size THEN NULL ELSE ERROR; Flush[]; StoreA[aN, segment.base]; aN _ aN + 1; }; }; BalanceRange: PROC [first: INT, end: INT, size: INT] RETURNS [ROSARY] ~ { <> Dbl: PROC [int: INT] RETURNS [INT] ~ INLINE { IF int > LAST[INT]/2 THEN RETURN [LAST[INT]] ELSE RETURN [int+int]; }; IF first = end THEN RETURN[NIL] ELSE IF end-first = 1 THEN RETURN[ASub[first]] ELSE { i: INT _ first+1; sizetoi: INT _ ASub[first].size; FOR sizei: INT _ ASub[i].size, ASub[i].size WHILE i < end-1 AND ((sizetoi+sizei)*2 < size OR ABS[sizetoi*2-size] > ABS[(sizetoi+sizei)*2-size]) DO sizetoi _ sizetoi + sizei; i _ i + 1; ENDLOOP; RETURN[LazyConcat[BalanceRange[first, i, sizetoi], BalanceRange[i, end, size-sizetoi]]]; }; }; s0 _ FixSegment[s0]; s1 _ FixSegment[s1]; s2 _ FixSegment[s2]; BoundsCheck[s1.size, LAST[INT]-s0.size]; BoundsCheck[s2.size, LAST[INT]-(s0.size+s1.size)]; MapSegments[s0, SaveSegment, SegmentIsBalanced]; MapSegments[s1, SaveSegment, SegmentIsBalanced]; MapSegments[s2, SaveSegment, SegmentIsBalanced]; Flush[]; RETURN [BalanceRange[0, aN, s0.size+s1.size+s2.size]] }; FixSegment: PROC [s: Segment] RETURNS [Segment] ~ { [] _ NonNeg[s.start]; [] _ NonNeg[s.size]; IF s.base = NIL THEN {[] _ NonNeg[-s.start]; s.size _ 0} ELSE {s.size _ NonNeg[MIN[s.size, s.base.size-s.start]]}; RETURN [s]; }; BadSegment: SIGNAL ~ CODE; SegmentIsBalanced: PROC [segment: Segment] RETURNS [BOOL] ~ { <> IF segment.base = NIL THEN RETURN [TRUE] ELSE { size: INT ~ segment.base.size; height: INT ~ segment.base.height; IF segment.start # 0 OR segment.size # size OR height > maxHeight OR size < minSizeForHeight[height] THEN RETURN [FALSE] ELSE RETURN [TRUE] }; }; minSizeForHeight: ARRAY [0..maxHeight) OF INT ~ InitMinSizeForHeight[]; InitMinSizeForHeight: PROC RETURNS [h: ARRAY [0..maxHeight) OF INT] ~ { h[0] _ 0; -- NIL has height 0, size 0. h[1] _ 1; -- Must have at least one element to warrant any allocation. h[2] _ 2; -- Must be at least this big to warrant any concat nodes. FOR i: NAT IN [3..maxHeight) DO <> <> IF INT.LAST - h[i-1] < h[i-2] THEN h[i] _ INT.LAST ELSE h[i] _ h[i-1] + h[i-2]; ENDLOOP; }; MapSegments: PROC[segment: Segment, action: PROC[Segment], stopDescent: PROC[Segment]RETURNS[BOOL]_NIL] ~{ IF stopDescent#NIL AND stopDescent[segment] THEN action[segment] ELSE { size: INT ~ InlineSize[segment.base]; end: INT ~ segment.start+segment.size; IF segment.start < 0 OR end NOT IN [segment.start..size] THEN ERROR BadSegment; WITH segment.base SELECT FROM concat: REF RosaryRep.concat => { pos: INT ~ concat.base.size; IF segment.start < pos THEN { MapSegments[[concat.base, segment.start, MIN[end, pos]-segment.start], action, stopDescent]; }; IF end > pos THEN { newStart: INT _ MAX[segment.start-pos, 0]; newEnd: INT _ end-pos; MapSegments[[concat.rest, newStart, newEnd-newStart], action, stopDescent]; }; }; object: REF RosaryRep.object => { s: ROSARY ~ object.substr[segment.base, segment.start, segment.size]; IF InlineSize[s] # segment.size THEN ERROR Malformed; action[[s, 0, segment.size]]; }; ENDCASE => action[segment]; }; }; FromProc: PUBLIC PROC [size: INT, proc: PUBLIC PROC RETURNS[Item]] RETURNS [ROSARY] ~ { p: PROC[q: PROC[item: Item, repeat: INT _ 1]] ~ { FOR i: INT IN [0..size) DO q[proc[], 1]; ENDLOOP; }; RETURN [FromProcProc[p]]; }; FromProcProc: PUBLIC PROC [p: PROC[q: PROC[item: Item, repeat: INT]]] RETURNS [ROSARY _ NIL] ~ { a: ARRAY [0..maxHeight] OF ROSARY; <> nb: NAT _ 0; b: Item _ NIL; Fold: PROC [new: ROSARY] ~ { i: NAT _ 0; DO IF a[i] = NIL THEN {a[i] _ new; EXIT}; new _ LazyConcat[a[i], new]; a[i] _ NIL; IF i < maxHeight THEN i _ i + 1; ENDLOOP; }; Flush: PROC ~ { IF nb > 0 THEN { f: REF RosaryRep.leaf _ NEW[RosaryRep.leaf]; f.size _ nb; f.height _ 1; f.item _ b; nb _ 0; Fold[f]; }; }; q: PROC[item: Item, repeat: INT] ~ { IF nb > 0 AND item = b THEN {nb _ nb + repeat} ELSE {Flush[]; b _ item; nb _ repeat}; }; ref: ROSARY _ NIL; p[q]; Flush[]; FOR i: NAT IN [0..maxHeight] DO IF a[i] # NIL THEN { ref _ LazyConcat[a[i], ref]; }; ENDLOOP; RETURN [ref]; }; Map: PUBLIC PROC [s: Segment, action: ActionType] RETURNS [BOOLEAN] ~ { fixedSegment: Segment ~ FixSegment[s]; stack: ARRAY [0..maxHeight) OF ROSARY; stackSize: [0..maxHeight] _ 0; <> currentBase: ROSARY _ fixedSegment.base; currentIndex: INT _ fixedSegment.start; residual: INT _ fixedSegment.size; IF residual = 0 THEN RETURN [FALSE]; DO -- exit by RETURN WITH currentBase SELECT FROM c: REF RosaryRep.concat => { pos: INT ~ c.base.size; IF currentIndex < pos THEN {stack[stackSize]_c.rest; stackSize_stackSize+1; currentBase_c.base} ELSE {currentIndex _ currentIndex - pos; currentBase _ c.rest}; }; t: REF RosaryRep.leaf => { WHILE currentIndex < t.size DO IF action[t.item] THEN RETURN [TRUE]; currentIndex _ currentIndex + 1; IF (residual _ residual - 1) = 0 THEN RETURN [FALSE]; ENDLOOP; IF stackSize = 0 THEN RETURN [FALSE]; stackSize _ stackSize - 1; currentBase _ stack[stackSize]; currentIndex _ 0; }; o: REF RosaryRep.object => { a: PROC [item: Item, repeat: INT] RETURNS [quit: BOOLEAN _ FALSE] ~ { FOR k: INT IN [0..repeat) DO IF action[item] THEN RETURN [TRUE]; currentIndex _ currentIndex + 1; IF (residual _ residual - 1) = 0 THEN RETURN [TRUE]; ENDLOOP; }; IF o.mapRuns[FixSegment[[currentBase, currentIndex, residual]], a] THEN RETURN [residual#0]; IF stackSize = 0 THEN RETURN [FALSE]; stackSize _ stackSize - 1; currentBase _ stack[stackSize]; currentIndex _ 0; }; ENDCASE => RETURN [FALSE]; ENDLOOP; }; MapRuns: PUBLIC PROC [s: Segment, action: RunActionType] RETURNS [quit: BOOLEAN] ~ { s _ FixSegment[s]; IF s.base # NIL THEN { s.size _ NonNeg[MIN[s.size, s.base.size-s.start]]; DO WITH s.base SELECT FROM f: REF RosaryRep.leaf => { IF action[f.item, s.size] THEN RETURN [TRUE]; EXIT; }; c: REF RosaryRep.concat => { IF s.start < c.base.size THEN { IF MapRuns[[c.base, s.start, s.size], action].quit THEN RETURN [TRUE]; }; s.start _ s.start - c.base.size; IF s.start < 0 THEN { s.size _ s.size + s.start; s.start _ 0; }; s.base _ c.rest; IF s.size <= 0 THEN EXIT; }; o: REF RosaryRep.object => { IF o.mapRuns[FixSegment[s], action] THEN RETURN [TRUE]; EXIT; }; ENDCASE => ERROR Malformed; ENDLOOP; }; RETURN [FALSE]; }; FetchBuffer: PUBLIC PROC [base: ROSARY, index: INT, maxCount: [0..bufferSize]] RETURNS [b: Buffer] ~ { stack: ARRAY [0..maxHeight) OF ROSARY; stackSize: [0..maxHeight] _ 0; BoundsCheck[index, InlineSize[base]]; b.count _ 0; DO -- exit by RETURN WITH base SELECT FROM c: REF RosaryRep.concat => { pos: INT ~ c.base.size; IF index < pos THEN {stack[stackSize]_c.rest; stackSize_stackSize + 1; base_c.base} ELSE {index _ index - pos; base _ c.rest}; }; t: REF RosaryRep.leaf => { WHILE index < t.size DO IF b.count = maxCount THEN RETURN; b.a[b.count] _ t.item; index _ index + 1; b.count _ b.count + 1; ENDLOOP; IF stackSize = 0 THEN RETURN; stackSize _ stackSize - 1; base _ stack[stackSize]; index _ 0; }; o: REF RosaryRep.object => { a: PROC [item: Item, repeat: INT] RETURNS [quit: BOOLEAN _ FALSE] ~ { FOR k: INT IN [0..repeat) DO IF b.count = maxCount THEN RETURN [TRUE]; b.a[b.count] _ item; index _ index + 1; b.count _ b.count + 1; ENDLOOP; }; IF o.mapRuns[FixSegment[[base, index]], a] THEN RETURN; IF stackSize = 0 THEN RETURN; stackSize _ stackSize - 1; base _ stack[stackSize]; index _ 0; }; ENDCASE => RETURN; ENDLOOP; }; FromList: PUBLIC PROC [list: LIST OF REF] RETURNS [ROSARY] ~ { p: PROC[q: PROC[item: REF, repeat: INT _ 1]] ~ { FOR l: LIST OF REF _ list, l.rest UNTIL l = NIL DO q[l.first]; ENDLOOP; }; RETURN [FromProcProc[p]] }; ToList: PUBLIC PROC [r: ROSARY] RETURNS [LIST OF REF] ~ { head: LIST OF REF ~ LIST[NIL]; tail: LIST OF REF _ head; action: ActionType ~ { tail.rest _ LIST[item]; tail _ tail.rest; }; RETURN [head.rest]; }; DefaultSubstr: PROC [base: ROSARY, start: INT, len: INT] RETURNS [ROSARY] ~ { p: PROC[q: PROC[item: REF, repeat: INT]] ~ { a: PROC [item: Item, repeat: INT] RETURNS [quit: BOOLEAN _ FALSE] ~ { q[item, repeat] }; [] _ MapRuns[[base, start, len], a]; }; RETURN [FromProcProc[p]] }; FromObject: PUBLIC PROC [size: INT, data: REF ANY, mapRuns: MapRunsProc, substr: SubstrProc] RETURNS [ROSARY] ~ { IF substr = NIL THEN substr _ DefaultSubstr; RETURN [NEW[RosaryRep.object _ [size: size, height: 1, var: object[data: data, mapRuns: mapRuns, substr: substr]]]]; }; TVPrint: PrintTV.TVPrintProc ~ TRUSTED { IF NOT AMBridge.IsRemote[tv] THEN RETURN [RefPrint[AMBridge.ReadOnlyRefFromTV[tv], NIL, stream, depth, width, verbose]]; }; RefPrint: PrintTV.RefPrintProc ~ TRUSTED { WITH LOOPHOLE[ref, REF] SELECT FROM r: ROSARY => { size: INT ~ Size[r]; i: INT _ 0; action: ActionType ~ TRUSTED { itemTV: AMTypes.TV; WITH item SELECT FROM atom: ATOM => itemTV _ AMBridge.TVForATOM[atom]; rope: Rope.ROPE => itemTV _ AMBridge.TVForROPE[rope]; ENDCASE => { itemTV _ AMBridge.TVForReadOnlyReferent[item]; IF item # NIL THEN IO.PutRope[stream, "^"]; }; PrintTV.Print[tv: itemTV, put: stream, depth: depth-1, width: width, verbose: verbose]; i _ i + 1; IF i # size THEN IO.PutRope[stream, ", "]; quit _ (i >= width); }; IO.PutRope[stream, "ROSARY["]; IF Map[[r],action] THEN IO.PutRope[stream, "..."]; IO.PutRope[stream, "]"]; RETURN [useOld: FALSE]; }; ENDCASE => NULL; RETURN [useOld: TRUE]; }; PrintTV.RegisterTVPrintProc[[CODE[RosaryRep]], TVPrint]; END.