<> <> <> <<>> DIRECTORY AMBridge, AMTypes, IO, PrintTV, Rope, RopePrivate, Rosary; RosaryImpl: CEDAR PROGRAM IMPORTS AMBridge, IO, PrintTV, RopePrivate EXPORTS Rosary ~ BEGIN OPEN Rosary; Malformed: PUBLIC ERROR ~ CODE; ROPE: TYPE ~ Rope.ROPE; NonNeg: PROC [x: INT] RETURNS [INT] ~ RopePrivate.NonNeg; Size: PUBLIC PROC [r: Ref] RETURNS [INT] ~ { RETURN [IF r = NIL THEN 0 ELSE r.size] }; InlineSize: PROC [r: Ref] RETURNS [INT] ~ INLINE { RETURN [IF r = NIL THEN 0 ELSE r.size] }; BoundsCheck: PROC [i: INT, max: INT] ~ INLINE { boundsCheck: [0..0] ~ MIN[max-i, 0]; }; Fetch: PUBLIC PROC [base: Ref, index: INT] RETURNS [Item] ~ { BoundsCheck[index, InlineSize[base]-1]; DO WITH base SELECT FROM f: REF Rep.leaf => {RETURN [f.item]}; c: REF Rep.concat => { pos: INT ~ c.base.size; IF index < pos THEN base _ c.base ELSE {base _ c.rest; index _ index-pos}; }; ENDCASE => ERROR Malformed; ENDLOOP; }; FetchRun: PUBLIC PROC [base: Ref, index: INT] RETURNS [Run] ~ { BoundsCheck[index, InlineSize[base]-1]; DO WITH base SELECT FROM f: REF Rep.leaf => {RETURN [[f.item, f.size-index]]}; c: REF Rep.concat => { pos: INT ~ c.base.size; IF index < pos THEN base _ c.base ELSE {base _ c.rest; index _ index-pos}; }; ENDCASE => ERROR Malformed; ENDLOOP; }; FromItem: PUBLIC PROC [item: Item, repeat: INT] RETURNS [Ref] ~ { r: REF Rep.leaf _ NEW[Rep.leaf]; r.size _ repeat; r.height _ 1; r.item _ item; RETURN [r]; }; Substr: PUBLIC PROC [base: Ref, start: INT, len: INT] RETURNS [Ref] ~ { [[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: Ref] RETURNS [Ref] ~ { <> IF base=NIL THEN RETURN [rest] ELSE IF rest=NIL THEN RETURN [base] ELSE { r: REF Rep.concat _ NEW[Rep.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: Ref] RETURNS [Ref] ~ { 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: Ref] RETURNS [Ref] ~ { RETURN [Concat[Concat[r0,r1], Concat[Concat[r2, r3], r4]]]; }; CatSegments: PUBLIC PROC [s0, s1, s2: Segment] RETURNS [Ref] ~ { a: ARep; -- An extensible array that is very cheap if it is small. aN: INT _ 0; AElement: TYPE ~ Ref; 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 Rep.leaf _ NEW[Rep.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 Rep.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 Rep.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 [Ref] ~ { <> 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]; 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..segment.start+size] THEN ERROR BadSegment; WITH segment.base SELECT FROM concat: REF Rep.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]; }; }; ENDCASE => action[segment]; }; }; FromProc: PUBLIC PROC [size: INT, proc: PUBLIC PROC RETURNS[Item]] RETURNS [Ref] ~ { 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 [Ref _ NIL] ~ { a: ARRAY [0..maxHeight] OF Ref; <> nb: NAT _ 0; b: Item _ NIL; Fold: PROC [new: Ref] ~ { 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 Rep.leaf _ NEW[Rep.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: Ref _ 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 [quit: BOOLEAN] ~ { stack: ARRAY [0..maxHeight) OF Ref; stackSize: [0..maxHeight] _ 0; s _ FixSegment[s]; DO -- exit by RETURN WITH s.base SELECT FROM c: REF Rep.concat => { pos: INT ~ c.base.size; IF s.start < pos THEN {stack[stackSize]_c.rest; stackSize_stackSize+1; s.base_c.base} ELSE {s.start _ s.start - pos; s.base _ c.rest}; }; t: REF Rep.leaf => { WHILE s.start < t.size DO IF action[t.item] THEN RETURN [TRUE]; s.start _ s.start + 1; s.size _ s.size - 1; ENDLOOP; IF stackSize = 0 THEN RETURN [FALSE]; stackSize _ stackSize - 1; s.base _ stack[stackSize]; s.start _ 0; }; ENDCASE => RETURN [FALSE]; ENDLOOP; }; MapRuns: PUBLIC PROC [s: Segment, action: RunActionType] RETURNS [quit: BOOLEAN] ~ { IF s.base # NIL THEN { s.size _ NonNeg[MIN[s.size, s.base.size-s.start]]; DO WITH s.base SELECT FROM f: REF Rep.leaf => { start: INT ~ s.start; end: INT ~ start+s.size; item: Item ~ f.item; IF action[item, s.size] THEN RETURN [TRUE]; EXIT; }; c: REF Rep.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; }; ENDCASE => ERROR Malformed; ENDLOOP; }; RETURN [FALSE]; }; FetchBuffer: PUBLIC PROC [base: Ref, index: INT, maxCount: [0..bufferSize]] RETURNS [b: Buffer] ~ { stack: ARRAY [0..maxHeight) OF Ref; stackSize: [0..maxHeight] _ 0; b.count _ 0; DO -- exit by RETURN WITH base SELECT FROM c: REF Rep.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 Rep.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; }; ENDCASE => RETURN; ENDLOOP; }; FromList: PUBLIC PROC [list: LIST OF REF] RETURNS [Ref] ~ { 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: Ref] 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]; }; 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: Ref => { 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 => itemTV _ AMBridge.TVForROPE[rope]; ENDCASE => { itemTV _ AMBridge.TVForReadOnlyReferent[item]; IF item # NIL THEN IO.PutRope[stream, "^"]; }; PrintTV.Print[tv: itemTV, put: stream, depth: depth, 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].quit THEN IO.PutRope[stream, "..."]; IO.PutRope[stream, "]"]; RETURN [useOld: FALSE]; }; ENDCASE => NULL; RETURN [useOld: TRUE]; }; PrintTV.RegisterTVPrintProc[[CODE[Rep]], TVPrint]; END.