(* Last edited on 2000-01-12 16:33:39 by stolfi *) IF inertia > 0.0d0 AND inertia > rnd.longreal(0.0d0, 1.0d0) THEN (* Try to add a random perturbation in "[-1..+1]": *) WITH eps = rnd.integer(0,1) - rnd.integer(0,1), yp = yBest+eps DO IF yp >= yRange.lo AND yp <= yRange.hi THEN WITH cp = TotCost(u) DO IF cp < LAST(LONG) THEN yBest := yp; cBest := cp END END END END; END; PROCEDURE Dst(v: Node): Node = (* Walks forward along a polyline until a vertex of "G". *) BEGIN WHILE vertices AND v >= G.nV DO WITH ov = D.ov[v]^ DO <* ASSERT NUMBER(ov) = 1 *> v := ov[0] END END; RETURN v END Dst; PROCEDURE Org(v: Node): Node = (* Walks backwards along a polyline until a vertex of "G". *) BEGIN WHILE vertices AND v >= G.nV DO WITH iv = D.iv[v]^ DO <* ASSERT NUMBER(iv) = 1 *> v := iv[0] END END; RETURN v END Org; <* ASSERT lo > LAST(uu) OR pos[uu[lo]][0] >= x *> <* ASSERT hi < FIRST(uu) OR pos[uu[hi]][0] <= x *> IF lo <= hi THEN IF pos[uu[lo]][0] > pos[uu[hi]][0] THEN FOR i := 0 TO LAST(uu) DO Wr.PutText(stderr, "uu[" & FI(i) & "] = " & FI(uu[i]) & " x = " & FI(pos[uu[i]][0]) & "\n"); END; Wr.PutText(stderr, "x[" & FI(uu[lo]) & "] = " & FI(pos[uu[lo]][0]) & " "); Wr.PutText(stderr, "x[" & FI(uu[hi]) & "] = " & FI(pos[uu[hi]][0]) & " "); END; <* ASSERT pos[uu[lo]][1] = pos[uu[hi]][1] *> <* ASSERT pos[uu[lo]][0] <= pos[uu[hi]][0] *> END; (* Paranoia: *) IF NUMBER(vv) > 0 THEN <* ASSERT pos[vv[0]][0] <= x *> <* ASSERT pos[vv[LAST(vv)]][0] >= x *> END; FOR i := 1 TO LAST(vv) DO <* ASSERT pos[vv[i]][0] = pos[vv[0]][0] + i *> <* ASSERT pos[vv[i]][1] = y *> <* ASSERT pos[vv[i]] # pos[vv[i-1]] *> END; PROCEDURE LazyAddPolyLine( dr: GDDrawing.T; dir: Dir; u: Node; ku: Slot; v: Node; kv: Slot; rnd: Random.T; ) = (* Adds a polyline to the drawing "dr", representing the edge "(u,v)" of "G". Nodes "u" and "v" must have different "y" coordinates. May create new joint nodes, in which case may expand the "rd" tables. Each joint of the polyline will be placed, in the appropriate layer, just outside the range of abscissas of all nodes in that layer; either always on the left side, or always on the right side. Existing nodes are not moved. Does nothing if the polyline is already there. *) VAR s: Node; ks: Slot; BEGIN WITH pos = SUBARRAY(dr.pos^, 0, dr.D.nV), yu = pos[u][1] + 0, yv = pos[v][1] + 0, yDir = SGN(yv - yu), dist = ABS(yu - yv) DO <* ASSERT yu # yv *> IF dr.D.nbor(u,+dir,ku) # NoNode OR dr.D.nbor(v,-dir,kv) # NoNode THEN (* Some polyline(s) already there, do nothing *) <* ASSERT dr.D.nbor(u,+dir,ku) # NoNode AND dr.D.nbor(v,-dir,kv) # NoNode *> RETURN ELSIF dist = 1 THEN (* No new joints needed *) dr.D.addEdge(+dir,u,ku,v,kv); ELSE (* Create joints between levels "yu" and "yv" *) WITH xDir = 2 * rnd.integer(0,1) - 1 DO s := u; ks := ku; FOR k := 1 TO dist - 1 DO WITH y = yu + k*yDir, x = LazyGetFreeX(dr, y, xDir), r = dr.addJoint(x, y) DO dr.D.addEdge(+dir,s,ks,r,0); s := r; ks := 0; END END END; dr.D.addEdge(+dir,s,ks,v,kv); END END END LazyAddPolyLine; (* From AddPolyLine *) WITH x = (xu + xv) DIV 2, xDir = PickClearingDir(x, rnd) DO dir: [-1..+1]; Pushes existing vertices of layer "y" in the direction "dir", if needed, to open up space for the new node. The coordinates of those points will be "p[i]", in order from the layer nearest to "u" to the layer nearest to "v". The client must make sure that these positions are not in use by existing nodes. (* FROM MoveVertices *) wt = FLOAT(NUMBER(G.ov[v]^) + NUMBER(G.iv[v]^), LONG), PROCEDURE SortVertices(after: PROCEDURE(ya,yb: INT): BOOL): REF Vertices = VAR uR: REF Vertices := NEW(REF Vertices, NUMBER(pos)); BEGIN WITH u = uR^ DO FOR i := 0 TO LAST(pos) DO VAR j: NAT := i; BEGIN WHILE j > 0 AND after(pos[u[j-1]][1], pos[i][1]) DO u[j] := u[j-1]; DEC(j) END; u[j] := i END; END END; RETURN uR END FillSort; PROCEDURE TrimDrawing( nN: NAT; posR: REF Points; ovR: REF ARRAY OF REF Nodes; ivR: REF ARRAY OF REF Nodes; ): REF Drawing = (* Builds a new drawing with given data. Reallocates the arrays if too big. The vectors "ov[v]" and "iv[v]" for all "v" are not reallocated. *) BEGIN IF NUMBER(posR^) > 2*nN THEN WITH posC = NEW(REF Points, nN), ovC = NEW(REF ARRAY OF REF Nodes, nN), ivC = NEW(REF ARRAY OF REF Nodes, nN) DO posC^ := SUBARRAY(posR^, 0, nN); posR := posC; ovC^ := SUBARRAY(ovR^, 0, nN); ovR := ovC; ivC^ := SUBARRAY(ivR^, 0, nN); ivR := ivC; END; END; RETURN NEW(REF Drawing, pos := posR, D := Graph{ nV := nN, ov := ovR, iv := ivR }) END TrimDrawing; PROCEDURE BestRelPos(u, v: Node): [-1..+1] = VAR c: INT := 0; BEGIN (* First computes the net ``edge crossing cost'' "c = Delta(u,v)" for placing "u" before "v", defined as the weighted count of edge crossings created by placing "u" before "v", minus the weighted count of the crossings created by placing "u" after "v". Thus a positive result means that it is better to place "u" AFTER "v". If "inertia" is zero, the result is the sign of "c". If "inertia" is 1, the result is the sign of the current X-dosplacement from "v" to "u". For other values of "inertia", the the result is chosen between these two signs, with probability proportional to the inertia. *) IF u # v THEN WITH nu = nbrs[u]^, nv = nbrs[v]^ DO FOR i := 0 TO LAST(nu) DO WITH u1 = nu[i], xu1 = pos[u1][0], yu1 = pos[u1][1] DO FOR j := 0 TO LAST(nv) DO WITH v1 = nv[j], xv1 = pos[v1][0], yv1 = pos[v1][1] DO IF u1 # v1 AND yu1 = yv1 THEN WITH wtc = wt[u1]*wt[v1] DO IF xu1 > xv1 THEN INC(c, wtc) ELSE DEC(c, wtc) END; END END END END END END END END; WITH cSign = SGN(c), dSign = SGN(pos[u][0] - pos[v][0]) DO IF inertia < 0.00001d0 THEN RETURN cSign ELSIF inertia > 0.99999d0 THEN RETURN dSign ELSIF cSign = dSign THEN RETURN cSign ELSIF inertia > rnd.longreal(0.0d0, 1.0d0) THEN RETURN dSign ELSE RETURN cSign END END END BestRelPos; PROCEDURE CheckOrder(): BOOL = BEGIN FOR i := 0 TO nL-1 DO FOR j := i+1 TO nL-1 DO IF BestRelPos(w[i], w[j]) > 0 THEN Wr.PutText(stderr, "[!" & FII(w[i],w[j]) & "¡]"); RETURN FALSE END END END; RETURN TRUE END CheckOrder; PROCEDURE CountDefinitePairs(): NAT = VAR n: NAT := 0; BEGIN FOR i := 0 TO nL-1 DO FOR j := i+1 TO nL-1 DO IF BestRelPos(w[i], w[j]) # 0 THEN INC(n) END END END; RETURN n END CountDefinitePairs; PROCEDURE DumpOrder() = BEGIN Wr.PutText(stderr, "\n"); Wr.PutText(stderr, "begin graph (format of 99-02-28)\n"); Wr.PutText(stderr, "vertices = " & FI(nL) & "\n"); Wr.PutText(stderr, "edges = " & FI(CountDefinitePairs()) & "\n"); FOR i := 0 TO nL-1 DO FOR j := i+1 TO nL-1 DO IF BestRelPos(w[i], w[j]) # 0 THEN Wr.PutText(stderr, FI(i) & " " & FI(j) & "\n"); END END END; Wr.PutText(stderr, "end graph\n"); END DumpOrder; (* Paranoia: verify order: *) IF inertia = 0.0d0 THEN IF NOT CheckOrder() THEN DumpOrder() END; END; (* This code assumes that the "crossing precedence" is a partial order, i.e. there cannot be a cycle "u[0..m-1]" such that "Delta(u[i],u[i+1]) > 0" for all "i" (indices taken modulo "n"). This may be wrong, especially when "inertia" is between 0 and 1. *) FOR i := 0 TO nL-1 DO (* Try to find a minimal element among "w[i..nL-1]": *) VAR k, j: NAT; (* First candidate for minimal elem *) BEGIN k := i+1; j := k; WHILE j < nL DO (* Node "w[i]" may come to the left of "w[i+1..j-1]" *) (* Nodes "w[i+1..k-1]" are definitely not minimal. *) WITH r = BestRelPos(w[i], w[j]) DO IF r = 0 THEN IF rnd.integer(0,nL-k) = 0 THEN (* Swap "w[i]" for "w[j]"; must re-validate it. *) VAR v: Node := w[i]; BEGIN w[i] := w[j]; w[j] := v END; j := k ELSE INC(j) END ELSIF r > 0 THEN (* Take "w[j]" as candidate for minimal, and exclude "w[i]": *) VAR v: Node := w[i]; BEGIN w[i] := w[j]; w[j] := w[k]; w[k] := v END; INC(k); j := k ELSIF r < 0 THEN (* Exclude "w[j]" from candidates for minimal: *) VAR v: Node := w[k]; BEGIN w[k] := w[j]; w[j] := v END; INC(k); INC(j) END END END END; END; PROCEDURE AdjustXUp( drR: REF Drawing; <*UNUSED*> READONLY G: Graph; rnd: Random.T; ): REF Drawing = VAR changed: BOOL := FALSE; BEGIN WITH dcR = CopyDrawing(drR^), dc = dcR^, nN = dc.D.nV, pos = SUBARRAY(dc.pos^,0,nN), bb = GetBounds(pos) DO FOR y := bb[1].hi TO bb[1].lo BY -1 DO WITH ch = RecomputeLayerX(dc, y, LAST(INT), y+1, y+1, rnd) DO changed := changed OR ch END END; IF changed THEN RETURN dcR ELSE RETURN NIL END END END AdjustXUp; <*UNUSED*> PROCEDURE FixNodeX( <*UNUSED*> drR: REF Drawing; <*UNUSED*> READONLY G: Graph; <*UNUSED*> rnd: Random.T; ): REF Drawing = BEGIN RETURN NIL END FixNodeX; <*UNUSED*> PROCEDURE FixLinkX( <*UNUSED*> drR: REF Drawing; <*UNUSED*> READONLY G: Graph; <*UNUSED*> rnd: Random.T; ): REF Drawing = BEGIN RETURN NIL END FixLinkX; <*UNUSED*> PROCEDURE DisturbVertex( <*UNUSED*> drR: REF Drawing; <*UNUSED*> READONLY G: Graph; <*UNUSED*> rnd: Random.T; ): REF Drawing = BEGIN RETURN NIL END DisturbVertex; PROCEDURE RelaxLayer( drR: REF Drawing; <*UNUSED*> READONLY G: Graph; rnd: Random.T; ): REF Drawing = BEGIN WITH dcR = CopyDrawing(drR^), dc = dcR^, nN = dc.D.nV, pos = SUBARRAY(dc.pos^,0,nN), bb = GetBounds(pos), y = rnd.integer(bb[1].lo, bb[1].hi), dy = 2*rnd.integer(0,1)-1, changed = RecomputeLayerX(dc, y, y+dy, LAST(INT), y-dy, rnd) DO IF changed THEN RETURN dcR ELSE RETURN NIL END END END RelaxLayer; PROCEDURE PackVertsY( drR: REF Drawing; READONLY G: Graph; rnd: Random.T; ): REF Drawing = VAR changed: BOOL; yNew: INT; BEGIN WITH nV = G.nV, dr = drR^, pos = SUBARRAY(dr.pos^, 0, nV), yMed = MedianY(pos), posNew = NEW(REF ARRAY OF Point, nV)^, u = NEW(REF ARRAY OF Vertex, nV)^, placed = NEW(REF ARRAY OF BOOL, nV)^ DO (* Fill "u" with vertices, sorted by "ABS(y-yMed)": *) VAR j: NAT; BEGIN FOR i := 0 TO nV-1 DO placed[i] := FALSE; j := i; WITH dyi = ABS(pos[i][1] - yMed) DO WHILE j > 0 AND ABS(pos[u[j-1]][1] - yMed) > dyi DO u[j] := u[j-1]; DEC(j) END END; u[j] := i END END; (* Push each vertex in towards "yMed" as far as possible *) (* (sometimes 1 off) without reversing any descending edges. *) changed := FALSE; FOR i := 0 TO nV-1 DO WITH u = u[i], yCur = pos[u][1] DO yNew := yMed; IF yCur > yMed THEN (* Place "u" at the minimum "y" based on input nodes already placed *) WITH ivu = G.iv[u]^ DO FOR iku := 0 TO LAST(ivu) DO WITH v = ivu[iku] DO IF placed[v] AND posNew[v][1] < yCur THEN yNew := MAX(yNew, posNew[v][1]+1) END END END END; <* ASSERT yNew >= yMed *> <* ASSERT yNew <= yCur *> ELSE (* Place at the maximum "y" based on output nodes already placed: *) WITH ovu = G.ov[u]^ DO FOR oku := 0 TO LAST(ovu) DO WITH v = ovu[oku] DO IF placed[v] AND posNew[v][1] > yCur THEN yNew := MIN(yNew, posNew[v][1]-1) END END END END; <* ASSERT yNew <= yMed *> <* ASSERT yNew >= yCur *> END; posNew[u] := Point{pos[u][0], yNew}; IF yNew # yCur THEN changed := TRUE END; placed[u] := TRUE; END END; IF NOT changed THEN RETURN NIL END; (* Make a copy of the drawing and move the vertices to the new positions: *) WITH dcR = CopyDrawing(drR^), dc = dcR^, p = NEW(REF ARRAY OF Point, G.nV)^ DO FOR i := 0 TO nV-1 DO p[i] := posNew[u[i]] END; MoveVertices(u, p, G, dc, rnd); RETURN dcR END END END PackVertsY; <*UNUSED*> PROCEDURE CollapseLayers( <*UNUSED*> drR: REF Drawing; <*UNUSED*> READONLY G: Graph; <*UNUSED*> rnd: Random.T; ): REF Drawing = BEGIN RETURN NIL END CollapseLayers; PROCEDURE RecomputeNodeX( VAR dr: Drawing; (* Drawing to modify *) u: Node; (* Node to relax *) yA, yB, yC: INT; (* Reference layers (may be LAST(INT)) *) xOld: INT; (* Old X of node, to decide whether it changed. *) rnd: Random.T; (* Coin *) ): BOOL = (* Tries to set the "X" coordinate of "u" to be approximately the barycenter of the "X" coordinates of the neighbors of "u" that lie on layers "yA", "yB", or "yC" (which must be "y+1", "y", or "y-1" to be effective). Returns TRUE if something changed. *) VAR s: INT := 0; m: NAT := 0; VAR changed: BOOL := FALSE; BEGIN WITH nN = dr.D.nV, pos = SUBARRAY(dr.pos^,0,nN), ov = SUBARRAY(dr.D.ov^,0,nN), iv = SUBARRAY(dr.D.iv^,0,nN) DO WITH ovu = ov[u]^ DO FOR k := 0 TO LAST(ovu) DO WITH v = ovu[k], yv = pos[v][1] DO IF yv = yA OR yv = yB OR yv = yC THEN INC(m); s := s + pos[v][0] END END END END; WITH ivu = iv[u]^ DO FOR k := 0 TO LAST(ivu) DO WITH v = ivu[k], yv = pos[v][1] DO IF yv = yA OR yv = yB OR yv = yC THEN INC(m); s := s + pos[v][0] END END END END; WITH wt = FLOAT(MAX(1,m), LONG), y = pos[u][1] + 0, xBar = FLOAT(s, LONG)/wt, xFree = SoftClearPosition(xBar, y, wt, pos, dr.D, changed, rnd) DO pos[u][0] := xFree; IF pos[u][0] # xOld THEN changed := TRUE END; END; RETURN changed END END RecomputeNodeX; PROCEDURE FixEdgeDir( drR: REF Drawing; READONLY G: Graph; rnd: Random.T; ): REF Drawing = BEGIN WITH e = GatherEdges(G)^, nE = NUMBER(e), nN = drR.D.nV, pos = SUBARRAY(drR.pos^,0,nN), p = RandomPerm(nE, rnd)^ DO FOR i := 0 TO nE-1 DO WITH ei = e[p[i]], u = ei[0], uy = pos[u][1] + 0, v = ei[1], vy = pos[v][1] + 0 DO <* ASSERT uy # vy *> IF uy > vy THEN (* Reverse edge! Reverse edge. *) WITH ux = pos[u][0], vx = pos[v][0], dcR = CopyDrawing(drR^), dc = dcR^ DO IF rnd.integer(0,1) = 0 THEN MoveVertices(Vertices{u}, Points{Point{ux, vy - 1}}, G, dc, rnd) ELSE MoveVertices(Vertices{v}, Points{Point{vx, uy + 1}}, G, dc, rnd) END; RETURN dcR END END END END; RETURN NIL END END FixEdgeDir; (* Register(Agent{"FixNodeX", FixNodeX, NC.Ocher, FALSE }); Register(Agent{"FixLinkX", FixLinkX, NC.Brown, FALSE }); Register(Agent{"DisturbVertex", DisturbVertex, NC.Green, FALSE }); Register(Agent{"CollapseLayers", CollapseLayers, NC.Celeste, FALSE }); *) PROCEDURE Deformation(READONLY G: Graph; READONLY dr: Drawing): REAL = VAR s: REAL := 0.0; BEGIN WITH nV = G.nV, nN = dr.D.nV, ov = SUBARRAY(dr.D.ov^,0,nN), iv = SUBARRAY(dr.D.iv^,0,nN), pos = SUBARRAY(dr.pos^,0,nN) DO FOR u := nV TO nN-1 DO WITH ovu = ov[u]^, ivu = iv[u]^ DO <* ASSERT NUMBER(ovu) = 1 *> <* ASSERT NUMBER(ivu) = 1 *> WITH a = pos[ivu[0]], b = pos[u], c = pos[ovu[0]] DO <* ASSERT ABS(a[1] - c[1]) = 2 *> <* ASSERT b[1] = (a[1] + c[1]) DIV 2 *> WITH dx = FLOAT(2*b[0] - a[0] - c[0], REAL) DO s := s + dx*dx END END END END END; RETURN sqrt(s) END Deformation; PROCEDURE PickShiftDirection( k: NAT; READONLY w: Nodes; READONLY pos: Points; rnd: Random.T; ): [-1..+1] = (* Chooses a suitable direction (+1 OR -1) for shifting the node "w[k]" so as to clear its current position. *) VAR lo, hi: INT; BEGIN lo := k; WHILE lo >= 0 AND pos[w[k]][0] - pos[w[lo]][0] = k - lo DO DEC(lo) END; hi := k; WHILE hi <= LAST(w) AND pos[w[hi]][0] - pos[w[k]][0] = hi - k DO INC(hi) END; IF hi - k < k - lo THEN RETURN +1 ELSIF hi - k > k - lo THEN RETURN -1 ELSE RETURN 2*rnd.integer(0,1) - 1 END END PickShiftDirection; PROCEDURE DeleteVertexMethod(G: T; u: Vertex) = BEGIN (* Delete all edges out of the vertex "u": *) FOR dir := -1 TO +1 BY 2 DO WITH nbu = G.nb[dir][u]^ DO FOR ku := 0 TO LAST(nbu) DO WITH v = nbu[ku], nbv = G.nb[-dir][v]^, kv = FindVertex(u,nbv) DO nbv[kv] := NoVertex; DEC(G.nE); END END END END; (* Renumber the last vertex "w = nV-1" as "u": *) WITH w = G.nV-1 DO <* ASSERT u <= w *> G.nb[-1][w] := NIL; G.nb[+1][w] := NIL; END END; (* Discard the last vertex *) DEC(G.nV) END DeleteVertexMethod; PROCEDURE SwapVertices(G: T; u, v: Vertex) = (* Swaps the numbers of vertices "u" and "v". *) CONST BigNum = 256*128; PROCEDURE MarkSlots(READONLY nbx: Vertices; dir: SIGN) = BEGIN FOR kx := 0 TO LAST(nbx) DO WITH y = nbx[kx] DO IF y # NoVertex AND y < BigNum THEN WITH nby = G.nb[-dir][y]^ DO FOR ky := 0 TO LAST(nby) DO IF nby[ky] = u OR nby[ky] = v THEN INC(nby[ky]), BigNum) END END END END END END END MarkSlots; BEGIN IF u # v THEN (* Mark all slots that need to be updated: *) FOR dir := -1 TO +1 BY 2 DO WITH nbu = G.nb[dir][u], nbv = G.nb[dir][v] DO MarkSlots(nbu, dir); MarkSlots(nbv, dir) END END; (* Update all FOR dir := -1 TO +1 BY 2 DO WITH nbu = G.nb[dir][u], nbv = G.nb[dir][v] DO MarkSlots(nbu, dir); MarkSlots(nbv, dir) END END; (* Swap neighbor lists: *) VAR t := nbu; BEGIN nbu := nbv; nbv := t END; G.nb[dir][u] := G.nb[dir][v]; WITH ovu = G.ov[u]^ DO FOR oku := 0 TO LAST(ovu) DO WITH v = ovu[oku], ivv = G.iv[v]^, ikv = FindVertex(v,ivv) DO ivv[ikv] := u END END END END; END SwapVertices; deleteJoint(s: Node); (* Deletes the joint node "s" from the drawing. (The node should not be a vertex of "G"). In order to keep the tables compact, the node number "D.nV-1" (if it is distinct from "s") will be renumbered as "s". *) PROCEDURE GatherPackedRun(x: INT; READONLY u: Nodes; READONLY pos: Points): Interval; (* Given a list "u" of nodes on the same layer, sorted by abscissa, returns a range of indices (not abscissas!) "r" such that "u[r.lo..rhi]" is a maximal list of nodes that have consecutive abscissas including "x". Returns and empty range if there is no node in "u" with abscissa "x". *) PROCEDURE FindPointInLayer(x: INT; READONLY w: Nodes; READONLY pos: Points): NAT; (* Returns the index "k" such that node "w[k]" has abscissa "x". Returns LAST(NAT) if there is no such node in "w". *)