latest/lib/Bary.i3 INTERFACE Bary; (* This interface contain essentially procedures created by J. Stolfi and R. Marcone (see the copyright and authorship futher down), modified by L. P. Lozada for the case tridimensional. *) IMPORT Octf, Triangulation; TYPE Pair = Octf.Pair; FacetEdge <: PublicFacetEdge; PublicFacetEdge = Octf.FacetEdge OBJECT ca : ARRAY [0..7] OF Pair; order1, order2 : CARDINAL; METHODS init(order1,order2: CARDINAL): FacetEdge; (* Initializes "self" hangs on the edge component from it a new unglued topological tetrahedron of the given order: "order1xorder2". *) END; PROCEDURE MakeFacetEdge(order1,order2: CARDINAL): Pair; (* Returns Pair{NEW(FacetEdge).init(order1,order2), bits := 0} *) PROCEDURE Corner(a: Pair): Octf.Pair; (* The pair (of triangulation) "c" belong to topological tetrahedron associated to pair (of Bary) "a", which has Org(c) = Org(a) and lies onto boundary of tetrahedron such as in one topological tetrahedron to perform: co[0] = Corner(a) co[1] = Corner(aSpin) co[2] = Corner(aSrot) co[3] = Corner(aSrotSpin) co[4] = Corner(aClock) co[5] = Corner(aClockSpin) co[6] = Corner(aTors) co[7] = Corner(aTorsSpin) *) PROCEDURE CCorner(a: Pair): Octf.Pair; (* The pair (of triangulation) "c" belong to topological tetrahedron associated to pair (of Bary) "a", which has Org(c) = Org(a) and lies onto boundary of tetrahedron such as in one topological tetrahedron to perform: Spin(co[1]) = CCorner(a) Spin(co[0]) = CCorner(aSpin) Spin(co[3]) = CCorner(aSrot) Spin(co[2]) = CCorner(aSrotSpin) Spin(co[5]) = CCorner(aClock) Spin(co[4]) = CCorner(aClockSpin) Spin(co[7]) = CCorner(aTors) Spin(co[6]) = CCorner(aTorsSpin) *) PROCEDURE SetCorner(a: Pair; c: Triangulation.Pair); PROCEDURE SetCCorner(a: Pair; c: Triangulation.Pair); END Bary. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (* Last edited on 2001-05-21 01:39:35 by stolfi *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/CmpAreaEnergy.i3 INTERFACE CmpAreaEnergy; IMPORT Energy; TYPE T <: Public; Public = Energy.T OBJECT area : REAL; (* The referencial area of one triangular face *) METHODS init(): T; END; (* The "Compression Area" energy measures the discrepancy between the "current" area of one triangular face of triangulation and the their "referencial" area. *) END CmpAreaEnergy. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/CmpVolEnergy.i3 INTERFACE CmpVolEnergy; IMPORT Energy; TYPE T <: Public; Public = Energy.T OBJECT volume : REAL; (* The referencial volume of one tetrahedron *) METHODS init(): T; END; (* The "Compression" energy measures the discrepancy between the "current" volume of one tetrahedron of triangulation and the their "referencial" volume. This last may be associated to volume of one regular tetraedron of side lenght "length", or simply the "average" volume of triangulation. *) END CmpVolEnergy. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/CoherentEnergy.i3 INTERFACE CoherentEnergy; IMPORT Energy, LR4; TYPE T <: Public; Public = Energy.T OBJECT From4: LR4.T; To4: LR4.T; Up4: LR4.T; Over4: LR4.T; METHODS init(): T; END; (* The "Coherent" energy try that the tetrahedra {v0,v1,v2,v3} and {u0,u1,u2,u3} have coherent orientations, i.e. that and have the same parity.This requirement can be reaches forcing that their determinants have the same sign. *) END CoherentEnergy. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Color.i3 INTERFACE Color; (* This interface contain procedures reused without modifications, created by J. Stolfi and R. Marcone. See the copyright and authorship futher down. *) IMPORT R3; TYPE T = R3.T; CONST Black = T{0.0, 0.0, 0.0}; White = T{1.0, 1.0, 1.0}; END Color. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Curvature1D.i3 INTERFACE Curvature1D; IMPORT Energy; TYPE T <: Public; Public = Energy.T OBJECT METHODS init(): T; END; (* The "Curvature 1D" energy measures the outer dihedral angles between adjacent edges. This energy is computed only for edges that: - exist, - belong to the same original edge, and - are adjacent to one common vertex. The energy depends on the actual angle "A", as "1 + cos(A); which reaches its minimum when "A=Pi". Let the edges e1 = (u,v), e2 = (u,w) and A the dihedral angle between e1 and e2: v w \ / \ A / \ / \/ u *) END Curvature1D. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Curvature2D.i3 INTERFACE Curvature2D; IMPORT Energy; TYPE T <: Public; Public = Energy.T OBJECT METHODS init(): T; END; (* The "Curvature 2D" energy measures the outer dihedral angles between adjacent faces. This energy is computed only for faces that: - exist, - belong to the same original face, and - are adjacent to one common edge. The energy depends on the actual angle "A", as "1 + cos(A); which reaches its minimum when "A=Pi". *) END Curvature2D. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Curvature3D.i3 INTERFACE Curvature3D; IMPORT Energy; TYPE T <: Public; Public = Energy.T OBJECT METHODS init(): T; END; (* Ideally, the 3-manifold realized as $\phi(\CT)$ should be as smooth as possible. Each tetrahedron of $\phi({\CT})$ is contained in some 3-di\-men\-sio\ -nal affine subspace of $\Real^m$. In general, if $t_1,t_2$ are two ad- jacent tetrahedra, their images $\phi(t_1)$ and $\phi(t_2)$ will lie in two distinct 3D spaces $V_1,V_2$ of $\Real^{m}$, whose intersection is the plane containing the shared face $f$. In order to flatten out the mo- del $\phi(\CT)$ at that spot, we need to minimize the angle $\theta_f$ between $V_1$ and $V_2$. This requirement is captured by the {\em curvatu- re energy}, defined as \begin{equation} \Ecurv = \sum_{f \in \FACE{\CT}} \left(1+\cos\theta_{f}\right) \label{eq.curvature} \end{equation} \noindent Note that $1-\cos\theta_{f}$ is approximately $\frac{1}{2} \,\theta_{f}^{2}$ when $\theta_{f}$ is small. Therefore, minimizing $\Ecurv$ tends to make the angles $\theta_{f}$ as small as possible. The value of $\cos \hspace{0.10cm} \theta_{f}$ can be computed by the formula $\cos \theta_f = - r_1 \dotpr r_2/(\abs{r_1}\,\abs{r_2})$, where $r_i$ is a vector in $U_i$ perpendicular to the face $f$, and pointing into the tetrahe- dron $t_i$, for $i=1,2$. *) END Curvature3D. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/ElasticityEnergy.i3 INTERFACE ElasticityEnergy; IMPORT Energy; TYPE T <: Public; Public = Energy.T OBJECT alpha: LONGREAL; (* the two elastic moduli of the material, that*) beta: LONGREAL; (* express its resistance to changes in volume *) METHODS (* and in shape, respectively. *) init(): T; END; (* The "Elasticity" energy considers that every tetrahedral cell is done of any material like rubber (i.e. elastic) possesing property material uniformes inside of every tetrahedron, but with unequal propiertes between tetrahedra. This module compute the "elastic energy" of a tetrahedral element. See the section 4.2 "Calculo das forcas de elasticidade" in the Msc. Thesis "Animacao Dinamica de Corpos Elasticos" by R.L.W.L for more details. *) END ElasticityEnergy. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Energy.i3 INTERFACE Energy; IMPORT LR4, Triangulation; FROM Triangulation IMPORT Topology; (* A generic energy function *) TYPE Coords = Triangulation.Coords; (* A vector of vertex coordinates *) Gradient = ARRAY OF LR4.T; (* A vector of energy gradients per vertex *) T = OBJECT METHODS defTop(READONLY top: Topology); (* Attaches the energy evaluator "eval" (bellow) to some topological triangulation.Must be called at least once before "defVar" below. *) defVar(READONLY variable: ARRAY OF BOOLEAN); (* Tells "eval" (bellow) which vertices "v" should be considered variables ("variable[v]=TRUE") or fixed parameters ("variable[v]=FALSE"); see below. Must be called at least once before the first use of "eval". Since it may be an expensive operation, clients should avoid calling it if the variable vertex set hasn't changed. *) eval(READONLY c: Coords; VAR e: LONGREAL; grad: BOOLEAN; VAR eDc: Gradient;); (* Returns in "e" the energy of triangulation "t" when the vertices have the coordinates "c". Also, if "grad" is TRUE, "eval" will return in "eDc" the gradient of "e", that is, the partial derivatives of "e" relative to each element of "c". An "Energy.T" object is typically used inside optimization loops where only some vertices are being adjusted, while the others are kept fixed in place. In that context the absolute value of the energy is not important; only energy differences are important. Accordingly, the "eval" method is free to omit any terms of the energy formula that depend only on fixed vertices. (However, the decision to omit a term must not depend on "c".) The client should be aware that if vertex "v" is fixed, the corresponding component of the gradient "eDc[v]" may not be set by "evalGrad", and therefore should not be used. *) name(): TEXT; (* Prints a description of the energy function. *) END; END Energy. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/EquaAngleEnergy.i3 INTERFACE EquaAngleEnergy; IMPORT Energy; TYPE T <: Public; Public = Energy.T OBJECT METHODS init(): T; END; (* The "Equalization Angle" energy measures the non-uniformity of diedral angles among consecutive faces incident to an internal edge "e". We say that an edge "e" is internal if every face incident to "e" is an inter- nal face. Analosgously, we say that a face "f" is internal if there exists exactely two tetrahedra incident to it. This energy is computed only for edges that exist, are internal, have face ring degree (DRF) three or more, and have only existing faces and vertices incident to it. The diedral angles not need projected. For two faces consecutives incidents to same edge, the ideal angle "I" is "2*Pi/n" where "n" is the face ring degree correspondly to edge "e". Minimizing this energy tends to equalize the angles between consecutive faces incident to edge "e". f2 \ /f1 \ / \/ e /\ / \ / \ f3 f4 *) END EquaAngleEnergy. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/ExcenEnergy.i3 INTERFACE ExcenEnergy; IMPORT Energy; TYPE T <: Public; Public = Energy.T OBJECT METHODS init(): T; END; (* The "Excen" energy measures the excentricity (discrepancy) of each vertex relative to its immediat neighbors. It is the sum over every existing vertex "v" of the distance squared between "v" and the bary- center of the effective neighbors of "v". An 'effective neighbor' of "v" is a vertex that exists and is connected to "v" by an edge that exists. Minimizing this energy tends to equalize the edges lengths. *) END ExcenEnergy. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Heuristic.i3 INTERFACE Heuristic; (* One complex-3D heuristic. *) IMPORT Triangulation, Random; FROM Triangulation IMPORT Pair, Coords, Topology; TYPE BOOLS = ARRAY OF BOOLEAN; PROCEDURE DisplaceVertex( a: Pair; VAR c: Coords; READONLY variable: BOOLS; READONLY top: Topology; <*UNUSED*> coins: Random.T; ); (* Displace the vertex "u=Org(a)", to neighbor's baricenter so as to minimize the Excentricity energy. Only moves vertices that are marked "variable". *) END Heuristic. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Heuristics.i3 INTERFACE Heuristics; (* A couple of complexes-3D-regularization heuristics. *) IMPORT Random; FROM Triangulation IMPORT Pair, Coords, Topology; TYPE BOOLS = ARRAY OF BOOLEAN; PROCEDURE EquaAngle( a: Pair; VAR c: Coords; READONLY variable: BOOLS; READONLY top: Topology; ); (* Move the neighbors of "u=Org(a)", so as to equalize the diedral angles between faces incidents to edge "u v" with "v=Org(Clock(a)). Only moves vertices that are marked "variable". *) (* PROCEDURE FlattenVertex( a: Pair; VAR c: Coords; READONLY variable: BOOLS; coins: Random.T; ); (* Places "v=Org(a)" at the barycenter of its neighbors, displaced along the normal by an amount that hopefully minimizes the bending energy between the faces incident to "v" and the faces adjacent to them. A no-op if "v" is not marked variable. *) *) END Heuristics. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/HingeEnergy.i3 INTERFACE HingeEnergy; (* NOT USED *) IMPORT Energy; TYPE T <: Public; Public = Energy.T OBJECT METHODS init(): T; END; (* The "Hinge" energy measures the difference among the "ideal" diedral angle and the "average" diedral angle of adjacent faces incident to one edge. This energy is computed only for edges that exists, have DegreeRingFacets three or more, and have only existing faces and vertices incident to them, and have the "hinge" bit set. Minimizing this energy tends to equalize the diedral angles between adja- cent faces incidents to same edge, thus tends to regular configurations. This energy is minimum (zero) when the "ideal" diedral angle is equal to "average" diedral angle between adjacent faces. *) END HingeEnergy. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/JSTriangulation.i3 INTERFACE Triangulation; (* Triangulated tridimensional meshes for automatic topology visualization. This interface contain essentially procedures created by J. Stolfi and R. Marcone (see the copyright and authorship futher down), modified extensively by L. Lozada for the tridimensional case. *) IMPORT Octf, Random, R3, LR4, Wr; (* === ELEMENTS === *) TYPE VisitProc = Octf.VisitProc; SRBits = Octf.SRBits; Pair = Octf.Pair; Face = Octf.Face; Edge = Octf.Edge; Node = Octf.Node; (* A "Triangulation.Pair" is an "Octf.Pair" whose "facetedge" field is a "Triangulation.FacetEdge". *) TYPE FacetEdge <: PublicFacetEdge; PublicFacetEdge = Octf.FacetEdge OBJECT mark: BOOLEAN := FALSE; (* Mark the facetedge, used by RefineT.*) vh: Vertex; (* Vertex medial associated to facetedge. This two last atributes will be used for the refinement process. *) METHODS init(): FacetEdge; (* initializes "self" as an isolated facetedge of triangulation *) END; TYPE Vertex <: PublicVertex; PublicVertex = Node OBJECT exists: BOOLEAN := TRUE; (* FALSE for ghost vertices *) fixed: BOOLEAN := FALSE; (* TRUE if position is fixed *) xmark: BOOLEAN := FALSE; (* Used by MakePolyhedronTopology *) color: R3.T := R3.T{0.0,0.0,0.0};(* Color for painting *) transp: R3.T := R3.T{0.0,..}; (* Transp. coefficient for painting *) radius: REAL := 0.020; (* Vertex radius for drawing *) label: TEXT := "VV"; (* label vertex, useful in bar.sub *) END; Polyhedron <: PublicPolyhedron; PublicPolyhedron = Node OBJECT exists: BOOLEAN := TRUE; (* FALSE for ghost tetrahedrons *) vertex: REF ARRAY OF Node; (* Vertices defining the polyhedron *) color: R3.T := R3.T{1.0,..}; (* Color for painting *) transp: R3.T := R3.T{1.0,..}; (* Transp. coefficient for painting *) degenerate: BOOLEAN := FALSE; (* to mark as an element degenerate *) root: INTEGER := -1; (* save the "root" tetrahedron *) END; (* === ELEMENT CREATION === *) PROCEDURE MakeFacetEdge(): Pair; (* Creates a new unattached facetedge with distinct endpoints. *) PROCEDURE MakeVertex(): Vertex; (* Creates an unattached vertex record. *) PROCEDURE MakePolyhedron(): Polyhedron; (* Creates an unattached polyhedron record. *) (* === PAIR PROPERTIES === *) PROCEDURE Org(a: Pair): Node; (* The origin of pair "a". *) PROCEDURE SetOrg(a: Pair; n: Node); (* Set the origin of pair "a" to be "n". *) PROCEDURE SetAllOrgs(a: Pair; n: Node); (* Does "SetOrg(t,n)" for some pairs "t" with the same origin as "a". *) PROCEDURE Set(a: Pair; n: Node); (* Does "SetOrg(t,n)" for all adjacents pairs "t" reaches by chains Fnext Enexts and Clocks. *) PROCEDURE Pneg(a: Pair): Node; (* The polyhedron negative of "a". *) PROCEDURE SetPneg(a: Pair; n: Node); (* Set the polyhedron negative of "a" to "n". Same as: "SetOrg(Sdual(a),n)". *) PROCEDURE SetNextPneg(a: Pair; n: Node); (* Does "SetPneg(t,n)" for all pairs "t" with the same face component. *) PROCEDURE SetAllPneg(a: Pair; n: Node); (* Set the pairs facetdeges (12) belonging to the same negative polyhedron "Pneg" equal to "n". *) PROCEDURE Ppos(a: Pair): Node; (* The polyhedron positive of "a". *) PROCEDURE SetPpos(a: Pair; n: Node); (* Sets the polyhedron positive of "a" to "n". Same as: "SetOrg(Clock(Sdual(a),n) = SetOrg(Tors(a),n)". *) PROCEDURE SetAllPpos(a: Pair; n: Node); (* Does "SetPpos(t,n)" for all pairs "t" with same Ppos as "a". *) PROCEDURE SetNextPpos(a : Pair; n: Node); (* Set the pairs facetdeges (12) belong to same polyhedron positive "Ppos" equal to "n". *) PROCEDURE OrgV(a: Pair): Vertex; (* The origin of pair "a", narrowed to type "Vertex". Corresponding to one vertex of primal subdivision: "C". *) PROCEDURE DesV(a: Pair): Vertex; (* The destination of pair "a", narrowed to type "Vertex". Corresponding to one vertex of primal subdivision: "C". *) PROCEDURE PnegP(a : Pair): Polyhedron; (* The polyhedron negative of pair "a", narrowed to type "Polyhedron". Corresponding to one vertex of dual subdivision: "C'". *) PROCEDURE PposP(a : Pair): Polyhedron; (* The polyhedron positive of pair "a", narrowed to type "Polyhedron". Corresponding to one vertex of dual subdivision: "C'". *) PROCEDURE TetraNegVertices(a: Pair): ARRAY [0..3] OF Vertex; (* The vertices of the tetrahedron "PnegP(a)". *) PROCEDURE TetraPosVertices(a: Pair): ARRAY [0..3] OF Vertex; (* The vertices of the tetrahedron "PposP(a)". *) PROCEDURE TetraNegPosVertices(a: Pair): ARRAY [0..4] OF Node; (* The vertices of the tetrahedra "PnegP(a)" and "PposP(a)". *) PROCEDURE TetraFaces(a: Pair): ARRAY [0..3] OF Face; (* The four faces of the tetrahedron "PnegP(a)". *) PROCEDURE TetraEdges(a: Pair): ARRAY [0..5] OF Edge; (* The six edges of the tetrahedron "PnegP(a)". *) PROCEDURE FaceEdges(a: Pair): ARRAY [0..2] OF Edge; (* The three edges of the component face of the pair "a". *) (* === CONSTRUCTION TOOLS === *) PROCEDURE MakeTetraTopo(nx, ny: CARDINAL): ARRAY [0..7] OF Pair; (* Builds a topological tetrahedron subdivided radialy. The number of tetrahedra cells is "nx" by "ny". Returns the corners facetedges pairs (8). *) PROCEDURE EmphasizeTetrahedron(a, b: Pair; n: CARDINAL); (* Emphasizes the original elements of a tetrahedron produced by the MakeTetraTopo(order,order) procedure. *) PROCEDURE Glue( a,b : Pair; n: CARDINAL; setorg: BOOLEAN := TRUE; ) : Pair; (* Glue two topological tetrahedra, by identification the "n" triangular facets on the topological boundary of tetrahedra. The traversal of the topological boundary will be realized by Quad- Edge's functions reducided to functions FacetEdge.The identification of triangular facets will be done by the "meld" procedure, removing the pairs facetedges on the chain "b" and updating the relations between vertices and polyhedra. If SetOrg = TRUE then the SetAllOrgs is executed. *) (* === GLOBAL PROCEDURES === *) PROCEDURE NumberVertices(a: Pair): CARDINAL; (* Enumerates all (primal) vertices reachable from "a" by chains of "Onext", "Onext_1" and "Clock", and assigns them distinct serial numbers from 0 up. Returns the number of vertices found.Use the procedure travesal "EnumVertices" of library "libm3triang". *) (* PROCEDURE ReforceSettings(a: Pair); *) TYPE Topology = RECORD NV: INTEGER; (* Number of vertex *) NE: CARDINAL; (* Number of edges *) NF: CARDINAL; (* Number of faces *) NP: INTEGER; (* Number of polyhedra *) NFE: INTEGER; (* Number of facetedges *) der: CARDINAL; (* Edge Ring Degree *) bdr: CARDINAL; (* Where (0) indicates without boundary *) (* (1) indicates with boundary *) (* and (2) indicates that cells are octahedra *) vertex: REF ARRAY OF Vertex; edge: REF ARRAY OF Edge; face: REF ARRAY OF Face; polyhedron: REF ARRAY OF Polyhedron; facetedge: REF ARRAY OF Pair; (* one pair for each facetedge *) out: REF ARRAY OF Pair; (* one pair for each vertex where: Org(out[v]) = vertex[v] *) region: REF ARRAY OF Pair; (* one pair for each polyhedron where: Org(region[r]) = polyhedron[r] *) END; PROCEDURE MakeTopology(a: Pair; bdr: CARDINAL) : Topology; (* This procedure compute the structure topological of complexes tridimen- sional without/with boundary. To assume that the procedures "Number- Vertices", "Octf.NumberEdges","Octf.NumberFacets","Octf.Numberfacetedges" of library "libm3triang" was called. *) TYPE PolyhedronTopology = RECORD NV: CARDINAL; (* Number of vertices *) NE: CARDINAL; (* NUmber of edges *) NF: CARDINAL; (* Number of faces *) (* The following Pairs have Pneg = the polyhedron in question. *) vRef: REF ARRAY OF Pair; (* One Pair out of each vertex *) eRef: REF ARRAY OF Pair; (* One Pair along each edge *) fRef: REF ARRAY OF Pair; (* One Pair on the boundary of each face *) END; PROCEDURE MakePolyhedronTopology(a: Pair): PolyhedronTopology; (* Returns the elements of the boundary of the polyhedron Pneg(Dual(a)) = Org(a). Note that `a' is an edge of the dual map. *) PROCEDURE WriteTable( name: TEXT; READONLY top: Topology; comments: TEXT := " "; debug: BOOLEAN := FALSE; ); (* This procedure create tables of vertex/edges/faces/polyhedra for one triangulation. *) (* PROCEDURE DegreeOfFacetEdges(a: Pair) : CARDINAL ; (* Return the number of pairs facetedges with the same origin that pair "a". *) PROCEDURE Edgeswso(READONLY a: Pair) : REF ARRAY OF Pair ; (* Return one pair facetedge for each edge incident to the origin of p. "a". *) *) PROCEDURE DegreeOfVertex(a: Pair) : CARDINAL ; (* Compute the degree of vertex that is Org(a) (i.e. the number of component edges incident to vertex). *) TYPE AdjacencyMatrix = ARRAY OF ARRAY OF BOOLEAN; PROCEDURE MakeAdjacencyMatrix(READONLY top: Topology): REF AdjacencyMatrix; (* Builds the adjacency matrix for the topology "top". *) PROCEDURE TriviallyIsomorphic(READONLY ta, tb: Topology): BOOLEAN; (* True iff "ta" and "tb" are topologically isomorphic, with the trivial isomorphism (that is, if elements with same index have the same topological relationship in both). *) PROCEDURE GetVariableVertices( READONLY top: Topology; VAR vr: ARRAY OF BOOLEAN; ); (* Sets "vr[v] := TRUE" for every vertex "v" that is not fixed. *) (* === GEOMETRIC TOOLS === *) TYPE Coords = ARRAY OF LR4.T; PROCEDURE InitCoords(coins: Random.T; VAR c: Coords; radius: REAL := 1.0); (* Fills c with random coordinates in the range [-radius __ +radius]. *) PROCEDURE GenCoords(READONLY t: Topology) : REF Coords; (* Fills the vertex coordinates with random coordinates in the range [-1.0 __ +1.0]. *) PROCEDURE Barycenter(READONLY top: Topology; READONLY c: Coords): LR4.T; (* Returns the barycenter of all existing vertices. *) PROCEDURE Displace(READONLY top: Topology; d: LR4.T; VAR c: Coords); (* Displaces all existing vertices by "d". *) PROCEDURE Scale(READONLY top: Topology; s: LONGREAL; VAR c: Coords); (* Scales the coordinates of all existing vertices by "s". *) PROCEDURE MeanVertexDistance(READONLY top: Topology; READONLY c: Coords): LONGREAL; (* The average distance of existing vertices from the origin, in the root-mean-square sense; that is, "sqrt(sum(norm(c[v])^2, v IN VExist)) /|VExist|)". *) PROCEDURE MeanEdgeLength(READONLY top: Topology; READONLY c: Coords): LONGREAL; (* The average length OF existing edges, in the root-mean-square sense; that is "sqrt(sum(dist(c[org(e)], c[dst(e)])^2, e IN EExist))/|EExist|)". *) PROCEDURE NormalizeVertexDistance(READONLY top: Topology; VAR c: Coords); (* Shifts and scales all existing vertices so that they have barycenter (0,0,0,0) and unit mean square distance from the origin. *) PROCEDURE NormalizeEdgeLengths(READONLY top: Topology; VAR c: Coords); (* Shifts and scales all existing vertices so that they have barycenter (0,0,0,0), and the mean square length of existing edges is 1.0. *) PROCEDURE FaceCross(a: Pair; READONLY c: Coords): LR4.T; (* A vector approximately perpendicular to component face of pair "a", this vector is computing by the mean of two perpendicular vectors (with orientation topological consistent) for two tetrahedrons inci- dents in this face. Returns the unit vector if the face has atributte "exists=FALSE". *) PROCEDURE FaceNormal(a: Pair; READONLY c: Coords): LR4.T; (* Normal of component face of "a"; same as "LR4.Dir(FaceCross(a, c))". Returns an arbitrary unit vector if the face has zero area. *) PROCEDURE PolyCross(a: Pair; READONLY c: Coords): LR4.T; (* A vector approximately perpendicular to Pneg of pair "a". Returns the unit vector if the polyhedron has atributte "exists=FALSE". *) PROCEDURE PolyNormal(a: Pair; READONLY c: Coords): LR4.T; (* Normal of "Pneg(a)"; same as "LR4.Dir(PolyCross(a, c))". Returns an arbitrary unit vector if the face has zero area *) PROCEDURE EdgeCross(a: Pair; READONLY c: Coords): LR4.T; (* A vector approximately perpendicular to component edge of pair "a", this vector is computing by the mean of perpendicular vectors (with orientation topological consistent) to all tetrahedrons incidents in this edge. Returns the unit vector if the edge has atributte "exists=FALSE". *) PROCEDURE EdgeNormal(a: Pair; READONLY c: Coords): LR4.T; (* Normal of component edge of "a"; same as "LR4.Dir(EdgeCross(a, c))". Returns an arbitrary unit vector if the edge has zero lenght. *) PROCEDURE FaceBarycenter(a: Pair; READONLY c: Coords): LR4.T; (* The barycenter of face component of pair "a". *) PROCEDURE TetraBarycenter(a: Pair; READONLY c: Coords): LR4.T; (* The barycenter of the negative tetrahedron of pair "a". *) PROCEDURE VertexCross(a: Pair; READONLY c: Coords; READONLY top: Topology): LR4.T; (* A vector approximately orthogonal to the Org(a), whose length is proportional the volume of the polyhedron defined by the "existing" neighbors of "Org(a)". *) PROCEDURE VertexNormal(a: Pair; READONLY c: Coords; READONLY top: Topology): LR4.T; (* Estimated normal at Org(a), considering only neighbors that exist; same as "LR4.Dir(VertexCross(a, c))". Returns an arbitrary unit vector if "VertexCross(a, c)" is zero. *) TYPE Quadp = ARRAY [0..3] OF Pair; Quadv = ARRAY [0..3] OF Vertex; Triv = ARRAY [0..2] OF Vertex; Trip = ARRAY [0..2] OF Pair; <* OBSOLETE *> PROCEDURE NeighborVertex( a: Pair; READONLY top: Topology; ): REF ARRAY OF Vertex; (* Neighbor vertices of "OrgV(a)" in a triangulation. *) PROCEDURE Neighbors( a: Pair; READONLY top: Topology; ): REF ARRAY OF Vertex; (* Neighbor vertices of "OrgV(a)", for any topology. *) PROCEDURE NeighborBarycenter( n: REF ARRAY OF Vertex; READONLY c: Coords; ): LR4.T; (* Barycenter of the "existing" neighbors vertices of "OrgV(a)". *) PROCEDURE NumberNeighborVertex(neigh: REF ARRAY OF Vertex): CARDINAL; (* Return the number neighbor vertex of OrgV(a). *) PROCEDURE StarOfVertex(a: Pair; READONLY top: Topology): REF ARRAY OF Quadv; (* Return the vertex set that conform every tetrahedron belonging to star of OrgV(a). The vertex set is sorted such as, the first element is OrgV(a), the second is OrgV(Enext(a)), the third OrgV(Enext_1(a)) and the las element is OrgV(Enext_1(Fnext_1(a))). *) PROCEDURE NumberPolyOfStar(quadv: REF ARRAY OF Quadv): CARDINAL; (* Return the number of polyhedrons that belong to star of OrgV(a). *) PROCEDURE ComputeAllVertexNormals(READONLY top: Topology; READONLY c: Coords ): REF ARRAY OF LR4.T; (* Returns a vector with the result of VertexNormal applied to each vertex of "top". *) PROCEDURE ComputeAllEdgeNormals(READONLY top: Topology; READONLY c: Coords ): REF ARRAY OF LR4.T; (* Returns a vector with the result of EdgeNormal applied to each edge of "top". *) PROCEDURE ComputeAllFaceNormals(READONLY top: Topology; READONLY c: Coords ): REF ARRAY OF LR4.T; (* Returns a vector with the result of Face Normal applied to each face of "top". *) PROCEDURE ComputeAllPolyhedronNormals(READONLY top: Topology; READONLY c: Coords ): REF ARRAY OF LR4.T; (* Returns a vector with the result of PolyNormal applied to each polyhe- dron of "top". *) (* === INPUT/OUTPUT === *) TYPE TopCom = RECORD top: Topology; comments: TEXT; END; PROCEDURE WriteTopology( name: TEXT; READONLY top: Topology; comments: TEXT := " "; ); (* Writes "top", and "comments" to file disk in a format that can be read back. The file will have the given "name" with ".tp" appended. *) PROCEDURE WriteDualTopology( name: TEXT; READONLY top: Topology; comments: TEXT := " "; ); (* Writes the dual of "top", and "comments" to file disk in a format that can be read back. The file will have the given "name" with ".tp" appended. *) PROCEDURE WriteState( name: TEXT; READONLY top: Topology; READONLY c: Coords; comments: TEXT := " "; ); (* Writes the coordinates geometrics to file disk in a format that can be read back. The file will have the given "name" with ".st" appended. *) PROCEDURE WriteMaterials( name: TEXT; READONLY top: Topology; comments: TEXT := " "; ro_te: BOOLEAN := FALSE; ); (* Writes the materials properties to file disk in a format that can be read back. The file will have the given "name" with ".ma" appended. *) PROCEDURE FindDegeneracies(READONLY top: Topology); (* Finds geometric degeneracies. Update the attribute "degenerate" of the elements: edge, face and polyhedron. *) PROCEDURE WriteStDe( wr: Wr.T; READONLY c: Coords; (* Vertex coordinates *) READONLY Dc: Coords; (* Vertex coordinates derivates *) prec: CARDINAL := 4; (* Significant figures to use for "c" and "Dc" *) comments: TEXT := ""; ); (* Writes the coordinates "c" and derivatives "Dc" to file "wr" in the ".sd" format. *) PROCEDURE ReadToTaMa(name: TEXT; ro_te: BOOLEAN := FALSE): TopCom; (* Reads three disk files created by "WriteTopology", "MakeTopologyTable" and "WriteMaterials". The files must have the given "name" with ".tp", ".tb" and ".ma". *) PROCEDURE ReadState(name: TEXT): REF Coords; (* Reads a disk file created by "WriteState". The file must have the given "name" with ".st" appended. *) END Triangulation. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Mapi.i3 INTERFACE Mapi; (* This interface contain essentially procedures created by J. Stolfi and R. Marcone (see the copyright and authorship futher down), modified by L. P. Lozada for the case tridimensional. *) IMPORT Octf, Triangulation; TYPE Pair = Octf.Pair; FacetEdge <: PublicFacetEdge; PublicFacetEdge = Octf.FacetEdge OBJECT ca : ARRAY [0..7] OF Pair; order1, order2 : CARDINAL; METHODS init(order1,order2: CARDINAL): FacetEdge; (* Initializes "self" hangs on the edge component from it a new unglued topological tetrahedron of the given order: "order1xorder2". *) END; PROCEDURE MakeFacetEdge(order1,order2: CARDINAL): Pair; (* Returns Pair{NEW(FacetEdge).init(order1,order2), bits := 0} *) PROCEDURE Corner(a: Pair): Octf.Pair; (* The pair (of triangulation) "c" belong to topological tetrahedron associated to pair (of mapi) "a", which has Org(c) = Org(a) and lies onto boundary of tetrahedron such as in one topological tetrahedron to perform: co[0] = Corner(a) co[1] = Corner(aSpin) co[2] = Corner(aSrot) co[3] = Corner(aSrotSpin) co[4] = Corner(aClock) co[5] = Corner(aClockSpin) co[6] = Corner(aTors) co[7] = Corner(aTorsSpin) *) PROCEDURE CCorner(a: Pair): Octf.Pair; (* The pair (of triangulation) "c" belong to topological tetrahedron associated to pair (of mapi) "a", which has Org(c) = Org(a) and lies onto boundary of tetrahedron such as in one topological tetrahedron to perform: Spin(co[1]) = CCorner(a) Spin(co[0]) = CCorner(aSpin) Spin(co[3]) = CCorner(aSrot) Spin(co[2]) = CCorner(aSrotSpin) Spin(co[5]) = CCorner(aClock) Spin(co[4]) = CCorner(aClockSpin) Spin(co[7]) = CCorner(aTors) Spin(co[6]) = CCorner(aTorsSpin) *) PROCEDURE SetCorner(a: Pair; c: Triangulation.Pair); PROCEDURE SetCCorner(a: Pair; c: Triangulation.Pair); END Mapi. (* ***************** START OF COPYRIGHT AND AUTHORSHIP NOTICE ********** All files in this directory tree are Copyright 1996 by Jorge Stolfi, Rober Marcone Rosi, and Universidade Estadual de Campinas, Brazil--- unless stated otherwise in the files themselves. THESE FILES ARE DISTRIBUTED WITH NO GUARANTEE OF ANY KIND. Neither the authors nor their employers may be held responsible for any losses or damages attributed to their use. These files may be freely copied, distributed, modified, and used for any purpose; provided that any subtantial excerpt of these files that is redistributed or incorporated in other software packages is accompanied by this copyright and authorship notice, and is made freely available under these same terms. ***************** END OF COPYRIGHT AND AUTHORSHIP NOTICE ************ *) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Mis.i3 INTERFACE Mis; (* This interface contain "miscelaneus" procedures reused without extensive modifications, created by J. Stolfi and R. Marcone. See the copyright and authorship futher down. *) IMPORT Wr, Rd, LR4, R3, LR3, LR2, Random, Lex; TYPE Point = LR4.T; CONST Boole = ARRAY BOOLEAN OF CHAR {'F', 'T'}; AlphaChars = SET OF CHAR{'\t', '\n', '\r', '\f', ' ', 'A'..'Z', 'a'..'z'}; PROCEDURE InitLongReal(coins: Random.T; radius: REAL): LONGREAL; (* Return one real value between [-radius, +radius]. *) PROCEDURE WriteLong(wr: Wr.T; x: LONGREAL); (* Write one longreal value with "fixed" format. *) PROCEDURE WriteInt(wr: Wr.T; x: INTEGER); (* Write one integer value . *) PROCEDURE WriteCoord(wr: Wr.T; x: LONGREAL); (* Write one longreal value with "scientific" format. *) PROCEDURE WritePoint4D(wr: Wr.T; READONLY c: LR4.T); (* Write 4D point with "scientific" format. *) PROCEDURE WritePoint3D(wr: Wr.T; READONLY c: LR3.T); (* Write 3D point with "scientific" format. *) PROCEDURE WritePoint2D(wr: Wr.T; READONLY c: LR2.T); (* Write 2D point with "scientific" format. *) PROCEDURE WriteIntensity(wr: Wr.T; r: REAL); (* Write one component color (real value) between 0-1. *) PROCEDURE WriteColor(wr: Wr.T; READONLY c: R3.T); (* Write colors in RGB mode. *) PROCEDURE WriteRadius(wr: Wr.T; r: REAL); (* Write one value Real. *) PROCEDURE WriteCommentsJS(wr: Wr.T; comments: TEXT; prefix: CHAR); (* Writes the given "comments" text to "wr", with a "prefix" character and a blank in front of every line. Supplies a final '\n' if the text is non-empty but does not end with newline. *) PROCEDURE ReadBool(rd: Rd.T): BOOLEAN RAISES {Lex.Error}; (* Read one boolean value. *) PROCEDURE ReadCommentsJS(rd: Rd.T; prefix: CHAR): TEXT; (* Read the comments writes by the WriteCommentsJS procedure. *) PROCEDURE NumDigits(n: CARDINAL): CARDINAL; (* Compute the number of digits of one cardinal value. *) PROCEDURE InsertionSort(n: CARDINAL; VAR a: REF ARRAY OF INTEGER ); (* sort n+1 integer values by InsertionSort *) PROCEDURE Sort(n: CARDINAL; VAR a: REF ARRAY OF CARDINAL); (* sort n+1 integer values by InsertionSort *) PROCEDURE Today(): TEXT; (* Print the date and time *) END Mis. (* ***************** START OF COPYRIGHT AND AUTHORSHIP NOTICE ********** All files in this directory tree are Copyright 1996 by Jorge Stolfi, Rober Marcone Rosi, and Universidade Estadual de Campinas, Brazil--- unless stated otherwise in the files themselves. THESE FILES ARE DISTRIBUTED WITH NO GUARANTEE OF ANY KIND. Neither the authors nor their employers may be held responsible for any losses or damages attributed to their use. These files may be freely copied, distributed, modified, and used for any purpose; provided that any subtantial excerpt of these files that is redistributed or incorporated in other software packages is accompanied by this copyright and authorship notice, and is made freely available under these same terms. ***************** END OF COPYRIGHT AND AUTHORSHIP NOTICE ************ *)~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/MixedEnergy.i3 INTERFACE MixedEnergy; IMPORT Energy; TYPE T <: Public; Public = Energy.T OBJECT term: REF ARRAY OF Energy.T; (* Energy ingredients *) weight: REF ARRAY OF REAL; (* Weight of each ingredient *) termValue: REF ARRAY OF LONGREAL := NIL; (* Value of each term as of last "eval" *) METHODS init(READONLY term: ARRAY OF Energy.T; READONLY weight: ARRAY OF REAL): T; (* Allocates new arrays for "term", "weight", and "termValue", and copies the given arrays into them. Assumes the "term[k]" has been initialized. *) END; (* A "MixedEnergy.T" is a linear combinations of the energy functions "term[k]", with weights "weight[k]". The "eval" method will leave the (unweighted) energy terms in "termValue". *) END MixedEnergy. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/ModKamSpring.i3 INTERFACE ModKamSpring; IMPORT Energy; TYPE T <: Public; Public = Energy.T OBJECT length : REAL; (* desirable length of a single edge in the display plane *) strength : REAL; (* a constant *) METHODS init(): T; END; (* Kamada's version has a spring between every pair of vertices u,v adjacents or not; whose length is equal to the graph-theoretical distance between u and v in T. *) END ModKamSpring.~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Octf.i3 INTERFACE Octf; (* Facet-Edge data structure. Created on 1998 by Luis Arturo Perez Lozada, (see notice of copyright at the end of this file), inspired in the im- plementation of Quad-Edge data structure (by J. Stolfi and R. Marcone). See : "Primitives for the Manipulation of Three-Dimensional Subdivisions" by D. Dobkin and J. Laszlo, Algorithmica 1989. Last Modification: 03-08-00 by stolfi: - The attribute "pa" for edges and faces is now a pair and not a pointer. *) (* A 'FacetEdge data structure' is a pair of dual subdvisions of a connec- ted 3-Cellular Complexes. An 'facetedge' (n) is an facetedge of the primal or dual subdivision. A 'pair' (a) is an oriented and spined facetedge. A 'quad' is a group of four pairs, consisting of two mutually dual facetedges. An 'octet' is a group of eight pairs, consisting of two mutually dual facetedges in all their spins and orientations. *) IMPORT Wr, Rd, R3; TYPE T = Pair; (* A subdivision is usually handled by one of its pairs. *) Pair = RECORD facetedge: FacetEdge; bits: SRBits END; (*ori+spin facetedge *) SRBits = [0..7]; (* Spin and Rotations bits of base pair *) OBit = [0..1]; (* Orientation bit *) SBit = [0..1]; (* Spin bit *) RBits = [0..3]; (* Rotation bits *) DBit = [0..1]; (* Dual/Primal bit *) PairNum = [0..MaxPairNum]; FacetEdgeNum = [0..MaxFacetEdgeNum]; TYPE Node <: PublicNode; PublicNode = OBJECT num: CARDINAL; END; Edge <: PublicEdge; PublicEdge = OBJECT pa : Pair; (* pair associated *) num : CARDINAL; (* Number of edge component *) dg : CARDINAL; (* For computing degree of vertex *) exists: BOOLEAN := TRUE; (* FALSE for immaterial edges *) degenerate: BOOLEAN := FALSE; (* to mark as an element degenerate *) xmark: BOOLEAN; (* Mark used by MakePolyhedronTopology *) color: R3.T := R3.T{0.0,0.0,0.0}; (* Color for drawing *) transp: R3.T := R3.T{0.0,..}; (* Transp. coeffs for painting *) radius: REAL := 0.004; (* radius for drawing *) vertex: ARRAY [0..1] OF Node; (* endpoints vertices *) root: INTEGER := -1; (* save the "root" edge *) METHODS init(): Edge; END; Face <: PublicFace; PublicFace = OBJECT pa : Pair; (* pair associated *) num : CARDINAL; (* Number of face component *) exists: BOOLEAN := TRUE; (* FALSE for ghost faces *) xmark: BOOLEAN; (* Mark used by MakePolyhedronTopology *) color: R3.T := R3.T{1.0,1.0,0.20}; (* Color for painting *) transp: R3.T := R3.T{0.7,0.7,0.7}; (* Transp. coeffs for painting *) vertex: REF ARRAY OF Node; (* endpoints vertices *) degenerate:BOOLEAN := FALSE; (* to mark an element as degenerate*) root: INTEGER := -1; (* save the root "face" *) METHODS init(): Face; END; FacetEdge <: PublicFacetEdge; PublicFacetEdge = OBJECT num: FacetEdgeNum := 0; (* Number of facetedge *) edge: Edge; (* Component edge *) face: Face; (* Component face *) order: CARDINAL; (* used for barycenter subdivision *) ca : ARRAY [0..7] OF Pair; marks: BOOLEAN := FALSE; METHODS init(): FacetEdge; (* Initializes the pointers of "self" so that it describes an isolated facetedge with distinct endpoints. The endpoints of facetedge to corrrespond exactly to endpoints of edge component. *) END; (* ====== Pairs ====== *) (* A "SRBits" value identifies a particular pair within any facetedge, according to the following table (where 'a' is the reference pair of the facetedge): | SRBits pair SBit OBit DBit RBits | -------------------------------------------------- | 000 0 a 0 0 0 0 | 001 1 a.spin 1 0 0 0 | 010 2 a.srot 0 0 1 1 | 011 3 a.srot.spin 1 0 1 1 | 100 4 a.clock 0 1 0 2 | 101 5 a.clock.spin 1 1 0 2 | 110 6 a.tors 0 1 1 3 | 111 7 a.tors.spin 1 1 1 3 In general, the pair "Spin^s(Srot^r(a))", for "r" in [0..3] and "s" in [0..1], has "SRBits" equal to "2r + s". *) (* ====== Facet-Edge dual function ====== *) PROCEDURE Sdual(a: Pair): Pair; (* dual pair facetedge *) (* ====== Facet-Edge senses of rotations functions ====== *) PROCEDURE Spin(a: Pair): Pair; (* reverses spin *) PROCEDURE Srot(a: Pair): Pair; (* rotated vers. of a, "aSrot=aSdualSpin" *) PROCEDURE Clock(a: Pair): Pair; (* "aClock = aSrotSrot" *) PROCEDURE Tors(a: Pair): Pair; (* Inverse of "Srot, "aTors=aSrotSrotSrot" *) (* ====== Facet-Edge traversal functions ====== *) PROCEDURE Fnext(a: Pair): Pair; (* next pair in spin sense with same edge *) PROCEDURE Enext(a: Pair): Pair; (* next pair in orientation sense with same face *) PROCEDURE Fnext_1(a: Pair): Pair; (* n. pair in c. spin sense w. same edge *) PROCEDURE Enext_1(a: Pair): Pair; (* n. pair in c. ori. sense w. same face *) (* ====== Computing Bits ====== *) PROCEDURE OrientationBit(a: Pair): OBit; (* Orientation bit = "SRBits DIV 4". Reversed by "Clock", unchanged by "Spin", may be changed by "Srot". *) PROCEDURE SpinBit(a: Pair): SBit; (* Spin bit = "SRBits MOD 2". Reversed by "Spin". *) PROCEDURE DualBit(a: Pair): DBit; (* Dual bit = "SRBits DIV 2 MOD 2". Unchanged by "Spin" and "Clock", reversed by "Srot". *) PROCEDURE SrotBits(a: Pair): RBits; (* Rot bits = "SRBits DIV 2". Unchanged by "Spin", incremented twice by "Clo- ck", either incremented or decremented by "Srot". *) (* ====== Counting ====== *) PROCEDURE DegreeFaceRing(a: Pair): CARDINAL; (* Number of "Pairs" facetedge with same edege component as "a". *) PROCEDURE DegreeEdgeRing(a: Pair): CARDINAL; (* Number of "Pairs" facetedge with same face component as "a". *) (* ====== Creation ====== *) PROCEDURE MakeFacetEdge(): Pair; (* Creates a new pair facetedge. Equivalent to | Pair{facetedge := NEW(FacetEdge).init(), bits := 0} *) PROCEDURE MakeEdge(): Edge; (* Creates a new component edge. *) PROCEDURE MakeFace(): Face; (* Creates a new component face. *) (* ======= updating ====== *) PROCEDURE SetFace(a: Pair; n: Face); (* Set the component face of pair facetedge "a.facetedge" equal to "n". *) PROCEDURE SetEdge(a: Pair; n: Edge); (* Set the component edge of pair facetedge "a.facetedge" equal to "n". *) PROCEDURE SetFaceAll(a: Pair; n: Face); (* Set the component face of all pairs adjacents to same component face that "a.facetedge" equal to "n". *) PROCEDURE SetEdgeAll(a: Pair; n: Edge); (* Set the component edge of all pairs adjacents to same component edge that "a.facetedge" equal to "n". *) (* ====== Destruction ====== *) PROCEDURE DeleteFacetEdge(a: Pair); (* Delete a pair facetedge "a" with the 7 another pairs associated. *) (* ====== Splicing ====== *) PROCEDURE SpliceFacets(a,b: Pair); (* Merges or splits the facet-rings F_{a} e F_{b} of pairs a and b. *) PROCEDURE SpliceEdges(a,b: Pair); (* Merges or splits the edge-rings E_{a} e E_{b} of pairs a and b. *) PROCEDURE SetFnext(a,b: Pair); (* If "Fnext(a) # b", performs "SpliceFacets(a, Fnext_1(b))". After this call "Fnext(a)" will be equal to "b". Valid whenever "SpliceFacets(a,b)" is va- lid. *) PROCEDURE SetEnext(a,b: Pair); (* If "Enext(a) # b", performs "SpliceEdges(a, Enext_1(b))". After this call, "Enext(a)" will be equal to "b". Valid whenever "SpliceEdges(a,b)" is valid. *) (* ================= Functions of QuadEdge ========= *) PROCEDURE Onext(s: Pair): Pair; (* If DualBit(s) = 0, then return Clock(Fnext(Enext_1(s))) else return Enext_1(s) *) PROCEDURE Onext_1(s: Pair): Pair; (* If DualBit(s) = 0, then return Clock(Fnext_1(Enext_1(s))) else return Enext_1(s) *) (* ====== Meld ========== *) PROCEDURE Meld(a,b : Pair); (* Meld F_{a} com F_{b} *) (* ====== Traversal ====== *) TYPE VisitProc = PROCEDURE(a: Pair); (* A client-provided pair visitation procedure. *) PROCEDURE EnumFacetEdges(a: Pair; visit: VisitProc; facetedges: BOOLEAN := FALSE); (* Enumerates all pairs that can be reached from a by some combination of Enext_1's and Fnext's. If "facetedges" is "FALSE" (default), the pairs "a" and "Srot(a)" is passed to the VisitProc exactly once. If "facetedges" is "TRUE", only the pair "a" is passed to the VisitProc exactly once. If the algebra is well-formed, only pairs of same primduality as "a" will ever be enumerated; that is, the procedure will never visit "Srot(a)" "Spin(Srot(a))", "Tors(a)" or "Spin(Tors(a))" if it visits the pair "a". *) PROCEDURE NumberEdges(READONLY a: ARRAY OF Pair): REF ARRAY OF Edge; (* Enumerates all (primal) edges reachable from "a" by chains of "Enext_1's" and "Fnext's". *) PROCEDURE NumberEdgesForDegree(READONLY a: ARRAY OF Pair): REF ARRAY OF Pair; (* Enumerates all (primal) edges with the same origin that of Pair "a" by chains of "Onext's" and "Fnext's". *) PROCEDURE NumberFacets(READONLY a: ARRAY OF Pair): REF ARRAY OF Face; (* Enumerates all (primal) facets reachable from "a" by chains of "Enext_1's" and "Fnext's". *) (* ====== Numbering ====== *) CONST MaxPairNum = LAST(CARDINAL); (* Maximum pair number *) MaxFacetEdgeNum = MaxPairNum DIV 8; (* Maximum facetedge number *) PROCEDURE NumberFacetEdges(READONLY a: ARRAY OF Pair): REF ARRAY OF Pair; (* Assigns distinct numbers serial to all facetedges reachable from "a" by Enext_1/Fnext chains. Returns a vector with one reachable pair from each facetedge. *) PROCEDURE GetPairNum (a: Pair): PairNum; (* = "a.facetedge.num * 8 + a.bits" *) (* ====== Printout ====== *) PROCEDURE PrintPair( wr: Wr.T; a: Pair; feWidth: CARDINAL := 1; nl : BOOLEAN := FALSE; ); (* Prints pair "a" as "m:r:s", where "m" is the serial facetedge number, and "r,s" are such that "a = Spin^s(Srot^r(a0))", where "a0" is the base pair of the facetedge. The facetedge number will be left-padded with spaces to "feWidth" bytes. IF nl = TRUE the procedure adds the newline character in the end, else it not add the character. *) PROCEDURE ReadPair(rd: Rd.T; READONLY map: ARRAY OF FacetEdge): Pair; (* Reads from "rd" an pair in the "m:r:s" format used by "PrintPair". The "map" table is used to convert the facetedge number "m" into an "Facet- Edge" pointer. *) PROCEDURE PrintFacetEdge(wr: Wr.T; n: FacetEdge; feWidth: CARDINAL := 1); (* Prints on "wr" the four pairs Fnext(Srot^i(s)), where "s = Pair{n, 0}" and "i = 0..3". Pairs are separated by one space. Each pair is printed using "PrintPair", with facetedge numbers left-padded to "feWidth" bytes. *) PROCEDURE ReadFacetEdge(rd: Rd.T; n: FacetEdge; READONLY map: ARRAY OF FacetEdge); (* Reads from "rd" four pairs "a[0..3]", using "ReadPair(rd, map)". Then performs "SetFnext(Srot^i(s), a[i])", where "s = Pair{n,0}" and "i = 0..3". *) END Octf. (**************************************************************************) (* *) (* Copyright (C) 1998 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/OldCurvature2D.i3 INTERFACE OldCurvature2D; IMPORT Energy; TYPE T <: Public; Public = Energy.T OBJECT METHODS init(): T; END; (* The "Curvature 2D" energy measures the outer dihedral angles between adjacent faces. This energy is computed only for faces that: - exist, - belong to the same original face, and - are adjacent to one common edge. The energy depends on the actual angle "A", as "1 + cos(A); which reaches its minimum when "A=Pi". *) END OldCurvature2D. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/OriKamSpring.i3 INTERFACE OriKamSpring; IMPORT Energy; TYPE T <: Public; Public = Energy.T OBJECT length : REAL; (* desirable length of a single edge in the display plane *) strength : REAL; (* a constant *) detail : BOOLEAN;(* for printing detail information *) METHODS init(): T; END; (* Kamada's version has a spring between every pair of vertices u,v adjacents or not; whose length is equal to the graph-theoretical distance between u and v in T. *) END OriKamSpring.~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/OrientationEnergy.i3 INTERFACE OrientationEnergy; IMPORT Energy; TYPE T <: Public; Public = Energy.T OBJECT minVol: LONGREAL; (* Minimum tetrahedron volume *) METHODS init(): T; END; (* The "Orientation" energy penalize tetrahedra with negative orientation in R^{3}. This is, for each tetrahedron with extremus vertices numbers u,v,w,x compute us theirs projections in R^{3} by dropping the last coordinate. This energy is zero when the tetrahedra have positive volumes greater than minVol *) END OrientationEnergy. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/PZGeo3.i3 INTERFACE PZGeo3; (* Miscellaneous geometry tools *) (* Last edited on 1999-08-06 22:03:36 by hcgl *) IMPORT LR3; TYPE Point = LR3.T; LONG = LONGREAL; PROCEDURE LinearInterpolate( t: LONG; a: LONG; READONLY pa: Point; b: LONG; READONLY pb: Point; ): Point; (* Interpolates linearly the position at time "t" between points "pa" and "b", assuming they have times "a" and "b". *) PROCEDURE HermiteInterpolate( t: LONG; a: LONG; READONLY pa: Point; READONLY va: Point; b: LONG; READONLY pb: Point; READONLY vb: Point; VAR p: Point; VAR v: Point; ); (* Performs cubic Hermite interpolation for argument "t" given positions "pa" and "pb" and velocities "va" and "vb" at times "a" and "b". Best used for "t" between "a" and "b". *) PROCEDURE EstimateVelocityQ( a: LONG; READONLY pa: Point; b: LONG; READONLY pb: Point; c: LONG; READONLY pc: Point; ): Point; PROCEDURE EstimateVelocityL( a: LONG; READONLY pa: Point; b: LONG; READONLY pb: Point; c: LONG; READONLY pc: Point; ): Point; PROCEDURE EstimateVelocityC( a: LONG; READONLY pa: Point; b: LONG; READONLY pb: Point; c: LONG; READONLY pc: Point; ): Point; (* These procedures return estimates of a curve's velocity at time "b", given its positions "pa", "pb", "pc" at three successive times "a", "b", "c". EstimateVelocityQ uses quadratic interpolation. It is precise for quadratic functions but is unstable when "b" is near "a" or "c". EstimateVelocityL uses linear interpolation between "(a,pa)" and "(c,pc)". It ignores "b" and "pb". It is therefore robust for uneven intervals, but is not precise for quadratics. EstimateVelocityC uses a formula that degenerates to linear interpolation between "(a,pa)" and "(b,pb)" when "b" is close to "c", and to linear interpolation between "(b,pb)" and "(c,pc)" when "b" is close to "a". It thus gives an "unconstrained derivative" effect at double nodes, which is useful for modeling. It is more robust than EstimateVelocityQ, but is not precise for quadratics. *) PROCEDURE HermiteCurveLength( a: LONG; READONLY pa: Point; READONLY va: Point; b: LONG; READONLY pb: Point; READONLY vb: Point; ): LONG; (* Computes the approximate length between "pa" and "pb" of the cubic curve that interpolates "(a,pa)" and "(b,pb)", with velocities "va", "vb" at those points. *) PROCEDURE BSplineApproximation( t: LONG; a: LONG; b: LONG; READONLY Pabc: Point; c: LONG; READONLY Pbcd: Point; d: LONG; READONLY Pcde: Point; e: LONG; READONLY Pdef: Point; f: LONG; ): Point; (* Computes the position at time "t" of a cubic B-Spline curve with control points "Pabc", "Pbcd", "Pcde", "Pdef", and knot sequence "a",... "f". Assumes "t" lies between "c" and "d". *) END PZGeo3. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/PZGeo4.i3 INTERFACE PZGeo4; (* Miscellaneous geometry tools *) (* Modified by lozada *) IMPORT LR4; TYPE Point = LR4.T; LONG = LONGREAL; PROCEDURE LinearInterpolate( t: LONG; a: LONG; READONLY pa: Point; b: LONG; READONLY pb: Point; ): Point; (* Interpolates linearly the position at time "t" between points "pa" and "b", assuming they have times "a" and "b". *) PROCEDURE HermiteInterpolate( t: LONG; a: LONG; READONLY pa: Point; READONLY va: Point; b: LONG; READONLY pb: Point; READONLY vb: Point; VAR p: Point; VAR v: Point; ); (* Performs cubic Hermite interpolation for argument "t" given positions "pa" and "pb" and velocities "va" and "vb" at times "a" and "b". Best used for "t" between "a" and "b". *) PROCEDURE EstimateVelocityQ( a: LONG; READONLY pa: Point; b: LONG; READONLY pb: Point; c: LONG; READONLY pc: Point; ): Point; PROCEDURE EstimateVelocityL( a: LONG; READONLY pa: Point; b: LONG; READONLY pb: Point; c: LONG; READONLY pc: Point; ): Point; PROCEDURE EstimateVelocityC( a: LONG; READONLY pa: Point; b: LONG; READONLY pb: Point; c: LONG; READONLY pc: Point; ): Point; (* These procedures return estimates of a curve's velocity at time "b", given its positions "pa", "pb", "pc" at three successive times "a", "b", "c". EstimateVelocityQ uses quadratic interpolation. It is precise for quadratic functions but is unstable when "b" is near "a" or "c". EstimateVelocityL uses linear interpolation between "(a,pa)" and "(c,pc)". It ignores "b" and "pb". It is therefore robust for uneven intervals, but is not precise for quadratics. EstimateVelocityC uses a formula that degenerates to linear interpolation between "(a,pa)" and "(b,pb)" when "b" is close to "c", and to linear interpolation between "(b,pb)" and "(c,pc)" when "b" is close to "a". It thus gives an "unconstrained derivative" effect at double nodes, which is useful for modeling. It is more robust than EstimateVelocityQ, but is not precise for quadratics. *) PROCEDURE BSplineApproximation( t: LONG; a: LONG; b: LONG; READONLY Pabc: Point; c: LONG; READONLY Pbcd: Point; d: LONG; READONLY Pcde: Point; e: LONG; READONLY Pdef: Point; f: LONG; ): Point; (* Computes the position at time "t" of a cubic B-Spline curve with control points "Pabc", "Pbcd", "Pcde", "Pdef", and knot sequence "a",... "f". Assumes "t" lies between "c" and "d". *) PROCEDURE CubicBezier( t: LONG; READONLY Pabc: Point; READONLY Pbcd: Point; READONLY Pcde: Point; READONLY Pdef: Point; ): Point; (* Computes the position at time "t" of a cubic Bezier curve with control points "Pabc", "Pbcd", "Pcde", "Pdef". *) END PZGeo4. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/ParseEnergyParams.i3 INTERFACE ParseEnergyParams; IMPORT ParseParams; IMPORT MixedEnergy; CONST Help = " [ -energy Excen ] \\\n" & " [ -energy Spring \\\n" & " [ OriKamada [ length | strength | detail ] |\\\n"& " [ ModKamada [ length | strength ] | \\\n" & " [ VarKamada [ length | strength ] | \\\n" & " [ Simple [ length ] ] \\\n" & " ] \\\n" & " [ -energy Curv1D ] \\\n" & " [ -energy Curv2D ] \\\n" & " [ -energy OldCurv2D ] \\\n" & " [ -energy Curv3D ] \\\n" & " [ -energy Orient [ minVol ] ] \\\n" & " [ -energy Winding ]"; (* " [ -energy Spread ] \\\n" & " [ -energy ComprVol ] \\\n" & " [ -energy Elasticity] \\\n" & Params; *) CONST Params = " [ -From4 ] \\\n" & " [ -To4 ] \\\n" & " [ -Up4 ] \\\n" & " [ -Over4 ] \\\n" & " [ -density ] \\\n" & " [ -alpha ] \\\n" & " [ -beta ] \n"; CONST Orient = " [ -From4 ] \\\n" & " [ -To4 ] \\\n" & " [ -Up4 ] \\\n" & " [ -Over4 ]\n"; PROCEDURE Parse(pp: ParseParams.T): MixedEnergy.T RAISES {ParseParams.Error}; (* Parses an energy combination from the command line parameters. The syntax is as shown in the "Help" string above. Must be called between "pp.beginParsing" and "pp.endParsing". If no terms are specified returns NIL. *) END ParseEnergyParams. (* Last edited on 2001-05-10 19:52:03 by stolfi *) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/ParseMinimizerParams.i3 INTERFACE ParseMinimizerParams; IMPORT ParseParams; IMPORT Minimizer; CONST Help = " -minimizer [ \\\n" & " Grad [ RKF4 | Euler ] | \\\n" & " Coord [ Brent | JS ] [ budget ] \\\n" & " ]"; PROCEDURE Parse(pp: ParseParams.T): Minimizer.T RAISES {ParseParams.Error}; (* Parses an optimization method from the command line parameters. Returns it still uninitialized. This procedure must be called between "pp.beginParsing" and "pp.endParsing". The syntax is described by the "Help" string above. Returns NIL if no "-optimizer" keyword was specified. *) END ParseMinimizerParams. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/PartialSpring.i3 INTERFACE PartialSpring; IMPORT Energy; TYPE T <: Public; Public = Energy.T OBJECT length : REAL; (* desirable length of a single edge in the display plane *) strength : REAL; (* a constant *) METHODS init(): T; END; (* Kamada's version has a spring between every pair of vertices u,v adjacents or not; whose length is equal to the graph-theoretical distance between u and v in T. *) END PartialSpring.~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Pov.i3 INTERFACE Pov; (* This module contains common procedures used with the POVray tracer. Last Modification: 17-05-00 by lozada. *) IMPORT R3, LR3, Wr; PROCEDURE WritePOVPoint(wr: Wr.T; READONLY p: LR3.T); (* Writes a 3D point in POVray format. *) PROCEDURE WritePOVColor(wr: Wr.T; READONLY cr: R3.T); (* Writes a rgb color in POVray format. *) PROCEDURE WritePOVCylinder( wr: Wr.T; READONLY o,d: LR3.T; radius: REAL; READONLY cr: R3.T; tr: REAL; filter: BOOLEAN; tag1, tag2: TEXT := ""; ); (* Defines a finity length cylinder without parallel end caps.*) PROCEDURE WritePOVSphere( wr: Wr.T; READONLY p: LR3.T; radius: REAL; READONLY cr: R3.T; tr: REAL; filter: BOOLEAN; tag1, tag2: TEXT := ""; ); (* Defines a sphere with center in "p" and radius "radius". POVray has a highly optimized sphere primitive which renders much more quickly that the corresponding polynomial quadric shape. *) PROCEDURE WritePOVTriangle( wr: Wr.T; READONLY a,b,c: LR3.T; READONLY cr: R3.T; tr: REAL; filter: BOOLEAN; tag1, tag2: TEXT := ""; ); (* Defines a triangle. Because triangle are perfectly flat surfaces it would requiere extremely large numbers of very smal triangles to appro- ximate a smooth, curved surface. *) PROCEDURE WritePOVTriangleTex( wr: Wr.T; READONLY a,b,c: LR3.T; texture: TEXT; ); (* Defines a triangle as above but with a some predefined texture face. *) PROCEDURE WritePOVSquare( wr: Wr.T; READONLY a,b,c,d: LR3.T; READONLY cr: R3.T; tr: REAL; filter: BOOLEAN; ); (* ************************************************************************* // builds a square by the union of two triangular faces, adjacent // to one common edge. // // /\ d // / \ // a /____\ c // \ / // \ / // b \/ //********************************************************************** *) PROCEDURE WritePOVTetrahedron( wr: Wr.T; READONLY u,v,w,x: LR3.T; READONLY du,dv,dw,dx: LONGREAL; cr: R3.T; tr: REAL; filter: BOOLEAN; ); (* ************************************************************************* // builds a tetrahedron sby the union of four triangular faces. // to one common edge. // v // /|\ // / | \ // x /__|__\ w // \ | / // \ | / // \|/ // u //********************************************************************** *) PROCEDURE WritePOVSmoothTriangle( wr: Wr.T; READONLY a, an: LR3.T; READONLY b, bn: LR3.T; READONLY c, cn: LR3.T; READONLY cr: R3.T; tr: REAL; filter: BOOLEAN; ); (* Much of our perception of smooth surfaces is dependent upon the way ligth and shading is done. By artificially modifying the surface normals we can simulate a triangle to be a smooth curved surface. The Smooth- Triangle primitive used the phong shading or interpolation of normals to calculate the surface normal for any point on the triangle based on nor- mal vectors which you define for the three corners. These normal vectors are prohibitivily difficult to computed by hand. Therefore smoothtrian- gles are almost always generated by utility programs. *) (* /**************************************************************************** // Define a pentagon build by the union of three triangular faces, adjacent // to pairs to one common edge. // // .b // / \ // c /___\a // | /| // | / | // |/__| // d e //****************************************************************************/ *) PROCEDURE WritePOVPenta( wr: Wr.T; READONLY a,b,c,d,e: LR3.T; READONLY cr: R3.T; tr: REAL; filter: BOOLEAN; ); END Pov. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/ProxTetraEnergy.i3 INTERFACE ProxTetraEnergy; IMPORT Energy; TYPE T <: Public; Public = Energy.T OBJECT fuzz: REAL := 0.50; (* Relative charge radius, set by user *) METHODS init(): T; END; (* This energy can be understood as the eletrostatic potential of a set of fuzzy electric charges, located at the tetrahedron centroids. Minimizing this energy tends to spread out the tetrahedrons in the R^{4} space, thus avoiding intersections between tetrahedra. The radius of the charge cloud is "fuzz" times the tetrahedron's approximate radius. *) END ProxTetraEnergy. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/QuadEdge.i3 INTERFACE QuadEdge; IMPORT Octf; TYPE Pair = Octf.Pair; Arc = RECORD pair : Pair; d: Octf.DBit END; (* Definition the scheme of representation the Edges in function the FacetEdge structure *) (* ================= Function's QuadEdge ========= *) PROCEDURE Flip(s : Arc) : Arc; PROCEDURE Sym(s : Arc): Arc; PROCEDURE Sym_(s : Arc): Arc; PROCEDURE Onext(s : Arc): Arc; PROCEDURE Oprev(s : Arc): Arc; PROCEDURE Dual(s : Arc): Arc; PROCEDURE Rot(s : Arc): Arc; PROCEDURE Lnext(s : Arc): Arc; PROCEDURE Rprev(s : Arc): Arc; (* =================== Operator's QuadEdge ========== *) PROCEDURE MakeEdge() : Arc; PROCEDURE MakeLoop() : Arc; PROCEDURE Splice(a,b : Arc); PROCEDURE Splice_(a,b : Arc); END QuadEdge. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Refine.i3 INTERFACE Refine; (* This interface contain essentially procedures for support the programs of refinement of tetrahedra. *) IMPORT Triangulation; FROM Triangulation IMPORT Pair; TYPE PAIR = ARRAY OF Pair; TRI = ARRAY [0..2] OF Pair; Free = RECORD tetra : REF ARRAY OF PAIR; octah : REF ARRAY OF PAIR; END; Side = RECORD upper : REF PAIR; lower : REF PAIR; END; Corner = RECORD right : REF PAIR; left : REF PAIR; front : REF PAIR; back : REF PAIR; END; Pack = RECORD side : Side; corner: Corner; END; PROCEDURE MakeTetra(order: CARDINAL; net: BOOLEAN := FALSE): Corner; (* This procedure implements the order-refinement of a topological tetrahedra. See: Relatorio FAPESP numero 5, secao 4.1. The number of new tetrahedra can be compute by the following formula: T(order) = 5/3 order**{3} - 2/3 order, order>= 1. *) PROCEDURE MakeTriang(order: CARDINAL): REF ARRAY OF TRI; PROCEDURE MakeLevTe(order: CARDINAL) : Pack; PROCEDURE MakeRowTe(order: CARDINAL) : Free; PROCEDURE MakeRowTriang(order: CARDINAL) : REF ARRAY OF TRI; PROCEDURE MakeGluea(order: CARDINAL) : Pair; (* Realizes the gluing ca.right <----> cb.left *) PROCEDURE MakeGlueb(order: CARDINAL) : Pair; (* Realizes the gluing ca.left <----> cb.right *) PROCEDURE MakeGluec(order: CARDINAL) : Pair; (* Realizes the gluing ca.front <----> cb.back *) PROCEDURE MakeGlued(order: CARDINAL) : Pair; (* Realizes the gluing ca.back <----> cb.front *) PROCEDURE MakeMaximalGlue(order: CARDINAL) : Pair; (* Realizes the maximal glue of a refined tetrahedron *) PROCEDURE PairsOnFrontier( READONLY co: Corner; cnum, order : CARDINAL; ) : REF PAIR; END Refine. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (* Last edited on 2001-05-21 01:39:06 by stolfi *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/SimpleSpring.i3 INTERFACE SimpleSpring; IMPORT Energy; TYPE T <: Public; Public = Energy.T OBJECT length : REAL; (* The referencial length of edge *) METHODS init(): T; END; (* The "spring" energy is computing assuming that every edge is a one elasticity wire that to pull or to push the extremal vertices with tension that depend of discrepancy between the "current" length of edge and their "referencial" or "nominal" length. *) END SimpleSpring.~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/SpreadEnergy.i3 INTERFACE SpreadEnergy; IMPORT Energy; TYPE T <: Public; Public = Energy.T OBJECT METHODS init(): T; END; (* The "Spread" energy measures the overall spread of the vertices. It is the sum over every "existing" and "variable" vertex "v" of the distance squared between "v" and the origin. Minimizing this energy tends to keep all vertices close to the origin of R^{4}. *) END SpreadEnergy. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Squared.i3 INTERFACE Squared; (* This interface contain procedures to build several faces such as: n-gons, triangles and squares, and complexes : cube, ball, bigcube (3D array of cube) with procedures for the glueing of two such complexes. Created by L. Lozada (see the copyright and authorship futher down). Revisions: 30-08-2000 : Nice version of the "MakeOctahedron" procedure. 19-09-2000 : Added the procedure "MakeDodecahedronTriang". 27-10-2000 : Modified "SetCubePropiertes" procedure. 04-11-2000 : Added the "CubeNegVertices" and "CubeBarycenter" procedures. *) IMPORT Triangulation, LR4; FROM Triangulation IMPORT Pair, Topology, Vertex, Coords; TYPE TriPair = ARRAY OF ARRAY OF ARRAY [0..1] OF Pair; PROCEDURE MakeTriangle(): Pair; (* Make one triangular face and set the three pairs facetedges with the same face component. *) PROCEDURE MakeSquare(): Pair; (* Builds one squared face. The four "pairs" have the same face component. *) PROCEDURE MakeOctahedron(): ARRAY [0..7] OF Pair; (* Builds a Octahedron. *) PROCEDURE MakeOctahedronTriang(Original: BOOLEAN): ARRAY [0..7] OF Pair; (* Builds a triangulated Octahedron. If Original=TRUE the procedure empha- size the original elements. *) PROCEDURE MakeIcosahedronTriang(Original: BOOLEAN): ARRAY [0..19] OF Pair; (* Builds a triangulated Icosahedron. If Original=TRUE the procedure empha- size the original elements. *) PROCEDURE MakeDodecahedronTriang( Original: BOOLEAN; ) : ARRAY[0..11] OF ARRAY [0..4] OF Pair; (* Builds a triangulated Dodecahedron, trough the automatic gluing of tetrahedra. If Original=TRUE the procedure emphasize the original elements. *) PROCEDURE MakeGon(n: CARDINAL): Pair; (* Builds one "n-gon" face. The "n-pairs" have the same face component. *) PROCEDURE MakeGonFull(n: CARDINAL): REF ARRAY OF Pair; (* Builds one "n-gon" face. The "n-pairs" have the same face component and this procedure return one pair facet-edge by side. *) PROCEDURE MakeCube(): ARRAY [0..5] OF Pair; (* Builds a cube from six squared faces. Returns one pair from each face. Face 0 is the bottom, faces 1..4 are the sides, face 5 is the top, as shown below. | +------+ | | | | | | | |5 | | +------+------+------+------+ | | | | | | | | | | | | | |1 |2 |3 |4 | | +------+------+------+------+ | | | | | | | |0 | | +------+ *) PROCEDURE MakeBall() : ARRAY [0..3] OF Pair; (* Buils one polyhedron with American football shape. This polyhedron is the gluing scheme for obtain the "pseudomanifold" complex. *) PROCEDURE MakeTetrahedron() : ARRAY [0..3] OF Pair; (* Builds one tetrahedron such that the facetedges pairs have "Ppos=NIL". Use in Baricentric Subdivision. *) PROCEDURE MakePyramid(n: CARDINAL) : REF ARRAY OF Pair; (* Builds a pyramid with base as a n-gon face. *) PROCEDURE MakeColumnCube(order: CARDINAL) : REF TriPair; (* Build one bidimensional array of cubes of order: "order x order". *) PROCEDURE MakeBigCube(order: CARDINAL) : REF TriPair; (* Build one tridimensional array of cubic cellulas. Return two arrays of pairs of order: "order x order", not eliminated by gluing procedure of columns of cubes. *) PROCEDURE CubeNegVertices(a: Pair): ARRAY [0..7] OF Vertex; (* The vertices of the negative cube of "a" ("PnegP(a)"). *) PROCEDURE CubeBarycenter(a: Pair; READONLY c: Coords): LR4.T; (* The barycenter of the negative cube of pair "a". *) PROCEDURE SetCubeProperties(a: REF TriPair; o: CARDINAL; READONLY tp:Topology); (* Set the propiertes of a tridimensional array of cubic cells, such that it emphasis the elements of the external big cube. *) PROCEDURE GlueCube(a,b : Pair) : Pair; (* Make the glueing of two simples cubes around of one squared face common. The pair "a" and their adjacentes on the same face component is killed. *) PROCEDURE GlueBall(a,b: Pair) : Pair; (* Make the glueing of two simples 2-gon faces around of one common face. The pair "a" and their adjacentes on the same face component is killed. *) PROCEDURE GlueBigCube(a,b : Pair; n: CARDINAL) : Pair; (* Make the glueing of two simples "bigcubes" around of one squared grid common face. The pair "a" and their adjacentes on the same squared grid face component is killed. *) END Squared. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Tools.i3 INTERFACE Tools; (* This interface contain "tools" procedures for tests and others util procedures. Created by L. P. Lozada (see the copyright and authorship futher down). *) IMPORT Octf, Triangulation; FROM Octf IMPORT Pair; TYPE Coords = Triangulation.Coords; PROCEDURE PrtDFR(a: Pair); (* Print the Degree Face Ring of pair "a". *) PROCEDURE PrtDER(a: Pair); (* Print the Degree Edge Ring of pair "a". *) PROCEDURE PrtDOV(a: Pair); (* Print the Degree of the vertex that is origin of pair "a". *) (* PROCEDURE PrtDFE(a: Pair); (* Print the Degree Face Edge Ring of "a". *) *) PROCEDURE PrtEnext(a: Pair); PROCEDURE PrtFnext(a: Pair); PROCEDURE PrtOrg(a: Pair); PROCEDURE PrtFaceNum(a: Pair); PROCEDURE PrtEdgeNum(a: Pair); PROCEDURE PrtPnegNum(a: Pair); PROCEDURE PrtPposNum(a: Pair); PROCEDURE PrtNextPneg(a: Pair); (* Print the pairs facetedges (12) with the same Negative Polyhedron, i.e the pairs belong to the same tetrahedral cell iff exits. *) PROCEDURE PrtNextPpos(a: Pair); (* Print the pairs facetedges (12) with the same Positive Polyhedron, i.e the pairs belong to the same tetrahedral cell iff exits. *) END Tools. (**************************************************************************) (* *) (* Copyright (C) 1999 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Triangulation.i3 INTERFACE Triangulation; (* Triangulated tridimensional meshes for automatic topology visualization. This interface contain essentially procedures created by J. Stolfi and R. Marcone (see the copyright and authorship futher down), modified extensively by L. Lozada for the tridimensional case. *) IMPORT Octf, Random, R3, LR4, Wr; (* === ELEMENTS === *) TYPE CARD = CARDINAL; BOOL = BOOLEAN; VisitProc = Octf.VisitProc; SRBits = Octf.SRBits; Pair = Octf.Pair; Face = Octf.Face; Edge = Octf.Edge; Node = Octf.Node; (* A "Triangulation.Pair" is an "Octf.Pair" whose "facetedge" field is a "Triangulation.FacetEdge". *) TYPE FacetEdge <: PublicFacetEdge; PublicFacetEdge = Octf.FacetEdge OBJECT mark: BOOL := FALSE; (* Mark the facetedge, used by RefineT.*) vh: Vertex; (* Vertex medial associated to facetedge.*) old: CARD; METHODS init(): FacetEdge; (* initializes "self" as an isolated facetedge of triangulation *) END; TYPE Vertex <: PublicVertex; PublicVertex = Node OBJECT exists: BOOL := TRUE; (* FALSE for ghost vertices *) fixed: BOOL := FALSE; (* TRUE if position is fixed *) xmark: BOOL := FALSE; (* Used by MakePolyhedronTopology *) color: R3.T := R3.T{0.0,0.0,0.0};(* Color for painting *) transp: R3.T := R3.T{0.0,..}; (* Transp. coefficient for painting *) radius: REAL := 0.020; (* Vertex radius for drawing *) label: TEXT := "VV"; (* label vertex, useful in bar.sub *) END; Vertices = ARRAY OF Vertex; Polyhedron <: PublicPolyhedron; PublicPolyhedron = Node OBJECT exists: BOOL := TRUE; (* FALSE for ghost polyhedra *) ymark: BOOL := FALSE; (* Used by ????? *) vertex: REF ARRAY OF Node; (* Vertices defining the polyhedron *) color : R3.T := R3.T{1.0,..}; (* Color for painting *) transp: R3.T := R3.T{1.0,..}; (* Transp. coefficient for painting *) root: INTEGER := -1; (* save the "root" polyhedron *) END; (* === ELEMENT CREATION === *) PROCEDURE MakeFacetEdge(): Pair; (* Creates a new unattached facetedge with distinct endpoints. *) PROCEDURE MakeVertex(): Vertex; (* Creates an unattached vertex record. *) PROCEDURE MakePolyhedron(): Polyhedron; (* Creates an unattached polyhedron record. *) (* === PAIR PROPERTIES === *) PROCEDURE Org(a: Pair): Node; (* The origin of pair "a". *) PROCEDURE SetOrg(a: Pair; n: Node); (* Set the origin of pair "a" to be "n". *) PROCEDURE SetAllOrgs(a: Pair; n: Node); (* Does "SetOrg(t,n)" for some pairs "t" with the same origin as "a". *) PROCEDURE Set(a: Pair; n: Node); (* Does "SetOrg(t,n)" for all adjacents pairs "t" reaches by chains Fnext Enexts and Clocks. *) PROCEDURE Pneg(a: Pair): Node; (* The polyhedron negative of "a". *) PROCEDURE SetPneg(a: Pair; n: Node); (* Set the polyhedron negative of "a" to "n". Same as: "SetOrg(Sdual(a),n)". *) PROCEDURE SetNextPneg(a: Pair; n: Node); (* Does "SetPneg(t,n)" for all pairs "t" with the same face component. *) PROCEDURE SetAllPneg(a: Pair; n: Node); (* Set the pairs facetedges (12) belonging to the same negative polyhedron "Pneg" equal to "n". *) PROCEDURE Ppos(a: Pair): Node; (* The polyhedron positive of "a". *) PROCEDURE SetPpos(a: Pair; n: Node); (* Sets the polyhedron positive of "a" to "n". Same as: "SetOrg(Clock(Sdual(a),n) = SetOrg(Tors(a),n)". *) PROCEDURE SetAllPpos(a: Pair; n: Node); (* Does "SetPpos(t,n)" for all pairs "t" with same Ppos as "a". *) PROCEDURE SetNextPpos(a : Pair; n: Node); (* Set the pairs facetedges (12) belong to same polyhedron positive "Ppos" equal to "n". *) PROCEDURE OrgV(a: Pair): Vertex; (* The origin of pair "a", narrowed to type "Vertex". Corresponding to one vertex of primal subdivision: "C". *) PROCEDURE DesV(a: Pair): Vertex; (* The destination of pair "a", narrowed to type "Vertex". Corresponding to one vertex of primal subdivision: "C". *) PROCEDURE PnegP(a : Pair): Polyhedron; (* The polyhedron negative of pair "a", narrowed to type "Polyhedron". Corresponding to one vertex of dual subdivision: "C'". *) PROCEDURE PposP(a : Pair): Polyhedron; (* The polyhedron positive of pair "a", narrowed to type "Polyhedron". Corresponding to one vertex of dual subdivision: "C'". *) PROCEDURE TetraNegVertices(a: Pair): ARRAY [0..3] OF Vertex; (* The vertices of the tetrahedron "PnegP(a)". *) PROCEDURE TetraPosVertices(a: Pair): ARRAY [0..3] OF Vertex; (* The vertices of the tetrahedron "PposP(a)". *) PROCEDURE TetraNegPosVertices(a: Pair): ARRAY [0..4] OF Node; (* The vertices of the tetrahedra "PnegP(a)" and "PposP(a)". *) PROCEDURE TetraFaces(a: Pair): ARRAY [0..3] OF Face; (* The four faces of the tetrahedron "PnegP(a)". *) PROCEDURE TetraEdges(a: Pair): ARRAY [0..5] OF Edge; (* The six edges of the tetrahedron "PnegP(a)". *) PROCEDURE FaceEdges(a: Pair): ARRAY [0..2] OF Edge; (* The three edges of the component face of the pair "a". *) PROCEDURE EdgeIsBorder(a: Pair): BOOL; (* TRUE if the edge of "a" belongs to the manifold's border (i.e. is on the boundary of a NIL polyhedron). *) PROCEDURE FaceIsBorder(a: Pair): BOOL; (* TRUE iff the face of "a" belongs to the manifold's border. Same as "Ppos(a) = NIL OR Pneg(a) = NIL". *) (* === CONSTRUCTION TOOLS === *) PROCEDURE MakeTetraTopo(nx, ny: CARD): ARRAY [0..7] OF Pair; (* Builds a topological tetrahedron subdivided radialy. The number of tetrahedra cells is "nx" by "ny". Returns the corners facetedges pairs (8). *) PROCEDURE EmphasizeTetrahedron(a, b: Pair; n: CARD); (* Emphasizes the original elements of a tetrahedron produced by the MakeTetraTopo(order,order) procedure. *) PROCEDURE Glue( a,b : Pair; n: CARD; setorg: BOOL := TRUE; ) : Pair; (* Glue two topological tetrahedra, by identification the "n" triangular facets on the topological boundary of tetrahedra. The traversal of the topological boundary will be realized by Quad- Edge's functions reducided to functions FacetEdge.The identification of triangular facets will be done by the "meld" procedure, removing the pairs facetedges on the chain "b" and updating the relations between vertices and polyhedra. If SetOrg = TRUE then the SetAllOrgs is executed. *) (* === GLOBAL PROCEDURES === *) PROCEDURE NumberVertices(a: Pair): CARD; (* Enumerates all (primal) vertices reachable from "a" by chains of "Onext", "Onext_1" and "Clock", and assigns them distinct serial numbers from 0 up. Returns the number of vertices found.Use the procedure travesal "EnumVertices" of library "libm3triang". *) TYPE Topology = RECORD NV: INTEGER; (* Number of vertex *) NE: CARD; (* Number of edges *) NF: CARD; (* Number of faces *) NP: INTEGER; (* Number of polyhedra *) NFE: INTEGER; (* Number of facetedges *) (* Elements: *) vertex: REF Vertices; edge: REF ARRAY OF Edge; face: REF ARRAY OF Face; polyhedron: REF ARRAY OF Polyhedron; facetedge: REF ARRAY OF Pair; (* one pair for each facetedge *) out: REF ARRAY OF Pair; (* one pair for each vertex where: Org(out[v]) = vertex[v] *) region: REF ARRAY OF Pair; (* one pair for each polyhedron where: Org(region[r]) = polyhedron[r] *) END; TopoDict = RECORD OldVertNum : REF ARRAY OF CARD; OldEdgeNum : REF ARRAY OF CARD; OldFaceNum : REF ARRAY OF CARD; OldPolyNum : REF ARRAY OF CARD; END; PROCEDURE MakeTopology(a: Pair) : Topology; (* This procedure compute the structure topological of complexes tridimen- sional without/with boundary. To assume that the procedures "Number- Vertices", "Octf.NumberEdges","Octf.NumberFacets","Octf.Numberfacetedges" of library "libm3triang" was called. *) TYPE PolyhedronTopology = RECORD NV: CARD; (* Number of vertices *) NE: CARD; (* Number of edges *) NF: CARD; (* Number of faces *) (* The following Pairs have Pneg = the polyhedron in question *) vRef: REF ARRAY OF Pair; (* One Pair out of each vertex *) eRef: REF ARRAY OF Pair; (* One Pair along each edge *) fRef: REF ARRAY OF Pair; (* One Pair on the boundary of each face *) END; PROCEDURE MakePolyhedronTopology(a: Pair): PolyhedronTopology; (* Returns the elements of the boundary of the polyhedron Pneg(Dual(a))=Org(a). Note that `a.facetedge.edge' is an edge of the dual map. *) TYPE TetraCorners = ARRAY[0..11] OF Pair; PROCEDURE GetTetraCorners(a : Pair) : TetraCorners; (* This procedure builds an array of 12 facetedge pairs, such all elements on the array have the same handness and the same negative poly. "Pneg". The pair "a" in the argument must be a pair that represent one tetrahe- dron of $T$ (in the primal space). *) PROCEDURE CollectTetrahedra(READONLY tp: Topology) : REF ARRAY OF Pair; (* Returns a list "t" with one facetedge on each tetrahedron from tp in numerical order, with consistent orientations whenever possible. The facetedges will be such that Pneg(t[i]).num = i. *) (* === LOW-LEVEL ENUMERATION PROCEDURES === *) PROCEDURE CollectFaceEdges(a: Pair; VAR re: REF ARRAY OF Pair; VAR ne: CARDINAL); (* Enumerates the edges of face "a.face" (with successive "Enext"s) and stores them in "re[0..ne-1]". Also sets "ne" and (re)allocates "re^" as needed. *) PROCEDURE CollectPolyhedronFaces(a: Pair; VAR rf: REF ARRAY OF Pair; VAR nf: CARDINAL); (* Enumerates the faces of polyhedron "Pneg(a)" and stores them in "rf[0..nf-1]". Also sets "nf" and (re)allocates "rf^" as needed. Assumes that the "xmark" bits of all face records are FALSE. *) PROCEDURE CollectPolyhedronEdges( a: Pair; VAR re: REF ARRAY OF Pair; VAR ne: CARDINAL; VAR rf: REF ARRAY OF Pair; (* Working area *) ); (* Collects all edges of the polyhedron "Pneg(a)", returns their representative pairs in "re[0..ne-1]". Also sets "ne" and (re)allocates "re^" as needed. Assumes all "xmark" bits are FALSE. The "rf" vector is a working area, expanded as needed; may be NIL initially. *) PROCEDURE CollectPolyhedronVertices( a: Pair; VAR rv: REF ARRAY OF Pair; VAR nv: CARDINAL; VAR rf: REF ARRAY OF Pair; (* Working area *) ); (* Collects all vertices of the polyhedron "Pneg(a)", returns their "OrgV"-representatives in "re[0..ne-1]". Also sets "ne" and (re)allocates "re^" as needed. Assumes all "xmark" bits are FALSE. The "rf" vector is a working area, expanded as needed; may be NIL initially. *) (* === INPUT/OUTPUT === *) PROCEDURE DegreeOfVertex(a: Pair) : CARD ; (* Compute the degree of vertex that is Org(a) (i.e. the number of component edges incident to vertex). *) TYPE AdjacencyMatrix = ARRAY OF ARRAY OF BOOL; PROCEDURE MakeAdjacencyMatrix(READONLY top: Topology): REF AdjacencyMatrix; (* Builds the adjacency matrix for the topology "top". *) PROCEDURE TriviallyIsomorphic(READONLY ta, tb: Topology): BOOL; (* True iff "ta" and "tb" are topologically isomorphic, with the trivial isomorphism (that is, if elements with same index have the same topological relationship in both). *) PROCEDURE GetVariableVertices( READONLY top: Topology; VAR vr: ARRAY OF BOOL; ); (* Sets "vr[v] := TRUE" for every vertex "v" that is not fixed. *) (* === GEOMETRIC TOOLS === *) TYPE Coords = ARRAY OF LR4.T; PROCEDURE InitCoords(coins: Random.T; VAR c: Coords; radius: REAL := 1.0); (* Fills c with random coordinates in the range [-radius __ +radius]. *) PROCEDURE GenCoords(READONLY t: Topology) : REF Coords; (* Allocates a coordinate vector "c", and initializes it using "InitCoords" with random numbers in "[-1.0 __ +1.0]". *) PROCEDURE Displace(READONLY top: Topology; d: LR4.T; VAR c: Coords); (* Displaces all existing vertices by "d". *) PROCEDURE Scale(READONLY top: Topology; s: LONGREAL; VAR c: Coords); (* Scales the coordinates of all existing vertices by "s". *) PROCEDURE FaceCross(a: Pair; READONLY c: Coords): LR4.T; (* A vector approximately perpendicular to component face of pair "a", this vector is computing by the mean of two perpendicular vectors (with orientation topological consistent) for two tetrahedrons inci- dents in this face. Returns the unit vector if the face has atributte "exists=FALSE". *) PROCEDURE FaceNormal(a: Pair; READONLY c: Coords): LR4.T; (* Normal of component face of "a"; same as "LR4.Dir(FaceCross(a, c))". Returns an arbitrary unit vector if the face has zero area. *) PROCEDURE PolyCross(a: Pair; READONLY c: Coords): LR4.T; (* A vector approximately perpendicular to Pneg of pair "a". Returns the unit vector if the polyhedron has atributte "exists=FALSE". *) PROCEDURE PolyNormal(a: Pair; READONLY c: Coords): LR4.T; (* Normal of "Pneg(a)"; same as "LR4.Dir(PolyCross(a, c))". Returns an arbitrary unit vector if the face has zero area *) PROCEDURE EdgeCross(a: Pair; READONLY c: Coords): LR4.T; (* A vector approximately perpendicular to component edge of pair "a", this vector is computing by the mean of perpendicular vectors (with orientation topological consistent) to all tetrahedrons incidents in this edge. Returns the unit vector if the edge has atributte "exists=FALSE". *) PROCEDURE EdgeNormal(a: Pair; READONLY c: Coords): LR4.T; (* Normal of component edge of "a"; same as "LR4.Dir(EdgeCross(a, c))". Returns an arbitrary unit vector if the edge has zero lenght. *) PROCEDURE FaceBarycenter(a: Pair; READONLY c: Coords): LR4.T; (* The barycenter of face component of pair "a". *) PROCEDURE TetraBarycenter(a: Pair; READONLY c: Coords): LR4.T; (* The barycenter of the negative tetrahedron of pair "a". *) PROCEDURE VertexCross(a: Pair; READONLY c: Coords; READONLY top: Topology): LR4.T; (* A vector approximately orthogonal to the Org(a), whose length is proportional the volume of the polyhedron defined by the "existing" neighbors of "Org(a)". *) PROCEDURE VertexNormal(a: Pair; READONLY c: Coords; READONLY top: Topology): LR4.T; (* Estimated normal at Org(a), considering only neighbors that exist; same as "LR4.Dir(VertexCross(a, c))". Returns an arbitrary unit vector if "VertexCross(a, c)" is zero. *) TYPE Quadp = ARRAY [0..3] OF Pair; Quadv = ARRAY [0..3] OF Vertex; Triv = ARRAY [0..2] OF Vertex; Trip = ARRAY [0..2] OF Pair; PROCEDURE Neighbors( v: Vertex; READONLY top: Topology; ): REF Vertices; (* Neighbor vertices of "v", for any topology. *) PROCEDURE StarOfVertex(a: Pair; READONLY top: Topology): REF ARRAY OF Quadv; (* Return the vertex set that conform every tetrahedron belonging to star of OrgV(a). The vertex set is sorted such as, the first element is OrgV(a), the second is OrgV(Enext(a)), the third OrgV(Enext_1(a)) and the las element is OrgV(Enext_1(Fnext_1(a))). *) PROCEDURE NumberPolyOfStar(quadv: REF ARRAY OF Quadv): CARD; (* Return the number of polyhedrons that belong to star of OrgV(a). *) PROCEDURE ComputeAllVertexNormals(READONLY top: Topology; READONLY c: Coords ): REF ARRAY OF LR4.T; (* Returns a vector with the result of VertexNormal applied to each vertex of "top". *) PROCEDURE ComputeAllEdgeNormals(READONLY top: Topology; READONLY c: Coords ): REF ARRAY OF LR4.T; (* Returns a vector with the result of EdgeNormal applied to each edge of "top". *) PROCEDURE ComputeAllFaceNormals(READONLY top: Topology; READONLY c: Coords ): REF ARRAY OF LR4.T; (* Returns a vector with the result of Face Normal applied to each face of "top". *) PROCEDURE ComputeAllPolyhedronNormals(READONLY top: Topology; READONLY c: Coords ): REF ARRAY OF LR4.T; (* Returns a vector with the result of PolyNormal applied to each polyhe- dron of "top". *) (* === GEOMETRIC AVERAGES === *) (* In the following procedures, when "all = TRUE" the quantities are computed over all elements of the appropriate dimension; otherwise they are computed only over those elements with "existing = TRUE". *) PROCEDURE Barycenter(READONLY top: Topology; READONLY c: Coords; all: BOOL): LR4.T; (* Returns the barycenter of all vertices. *) PROCEDURE PartialBarycenter(READONLY v: Vertices; READONLY c: Coords; all: BOOL): LR4.T; (* Barycenter of the vertices "v[i]". Previously called "NeighborBarycenter". *) PROCEDURE MeanVertexDistance( READONLY top: Topology; READONLY c: Coords; READONLY ctr: LR4.T; all: BOOL ): LONGREAL; (* The average distance of vertices from "ctr", in the root-mean-square sense; that is, "sqrt(sum(norm(c[v]-ctr)^2)/N)". *) PROCEDURE MaxVertexDistance( READONLY top: Topology; READONLY c: Coords; READONLY ctr: LR4.T; all: BOOL; ): LONGREAL; (* The maximum distance of a vertex from "ctr". *) PROCEDURE MeanEdgeLength(READONLY top: Topology; READONLY c: Coords; all: BOOL): LONGREAL; (* The average length of edges, in the root-mean-square sense; that is "sqrt(sum(dist(c[org(e)], c[dst(e)])^2)/N)". *) PROCEDURE MeanPolyhedronNormal(READONLY top: Topology; READONLY c: Coords; all: BOOL): LR4.T; (* The average of all tetrahedra normals, normalized to unit length. *) PROCEDURE MeanThickness( READONLY top: Topology; READONLY c: Coords; READONLY ctr: LR4.T; READONLY norm: LR4.T; all: BOOL; ): LONGREAL; (* Average vertex deviation from the hyperplane that passes through "ctr" and is orthogonal to "norm", in the root mean square sense. *) PROCEDURE NormalizeVertexDistances( READONLY top: Topology; VAR c: Coords; all: BOOL; ); (* Shifts and scales all vertices so that they have barycenter (0,0,0,0) and unit mean square distance from the origin. The "all" parameter is used to compute the barycenter and the mean square distance. *) PROCEDURE NormalizeEdgeLengths( READONLY top: Topology; VAR c: Coords; all: BOOL ); (* Shifts and scales all existing vertices so that they have barycenter (0,0,0,0), and the mean square length of existing edges is 1.0. The "all" parameter is used to compute the barycenter and the mean edge length. *) (* === INPUT/OUTPUT === *) TYPE TopCom = RECORD top: Topology; comments: TEXT; END; PROCEDURE WriteTopology( name: TEXT; READONLY top: Topology; comments: TEXT := " "; ); (* Writes "top", and "comments" to file disk in a format that can be read back. The file will have the given "name" with ".tp" appended. *) PROCEDURE WriteState( name: TEXT; READONLY top: Topology; READONLY c: Coords; comments: TEXT := " "; ); (* Writes the coordinates geometrics to file disk in a format that can be read back. The file will have the given "name" with ".st" appended. *) PROCEDURE WriteMaterials( name: TEXT; READONLY top: Topology; comments: TEXT := " "; ro_te: BOOL := FALSE; ); (* Writes the materials properties to file disk in a format that can be read back. The file will have the given "name" with ".ma" appended. *) PROCEDURE WriteDualTopology( name: TEXT; READONLY top: Topology; comments: TEXT := " "; ); (* Writes the dual of "top", and "comments" to file disk in a format that can be read back. The file will have the given "name" with ".tp" appended. *) PROCEDURE WriteStDe( wr: Wr.T; READONLY c: Coords; (* Vertex coordinates *) READONLY Dc: Coords; (* Vertex coordinates derivates *) prec: CARD := 4; (* Significant figures to use for "c" and "Dc" *) comments: TEXT := ""; ); (* Writes the coordinates "c" and derivatives "Dc" to file "wr" in the ".sd" format. *) PROCEDURE ReadToMa(name: TEXT; ro_te: BOOL := FALSE): TopCom; (* A more general procedure to read two disk files created by "WriteTopology" and "WriteMaterials". The files must have the given "name" with ".tp" and ".ma". *) PROCEDURE ReadState(name: TEXT): REF Coords; (* Reads a disk file created by "WriteState". The file must have the given "name" with ".st" appended. *) END Triangulation. (**************************************************************************) (* *) (* Copyright (C) 2001 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Tridimensional.i3 INTERFACE Tridimensional; (* This interface contain procedures that Write/Read one tridimensional state (.st3) and compute some 3D geometric operations. Also we include some procedures defined by R. L. W. S. and slightly modified in her tools "Animacao Dinamica de Corpos Elasticos". See the copyright and authorship futher down. Last modification : 19-02-2000 *) IMPORT LR3, LR4, Triangulation, LR3x3, Rd, Wr; FROM Triangulation IMPORT Topology; FROM Octf IMPORT Pair; (* types for use with the R.L.W.L. procedures *) TYPE Tetrahedron = RECORD p0, p1, p2, p3: CARDINAL; A: LR3x3.T; density, alpha, beta: LONGREAL; END; Vertex = LR3.T; Vectors3D = REF ARRAY OF LR3.T; TYPE Coords3D = ARRAY OF LR3.T; PROCEDURE Barycenter3D( READONLY top: Topology; READONLY c3: Coords3D; ): LR3.T; (* Returns the barycenter of all existing vertices. *) PROCEDURE Displace3D( READONLY top: Topology; d: LR3.T; VAR c3: Coords3D; ); (* Displaces all existing vertices by "d". *) PROCEDURE Scale3D( READONLY top: Topology; s: LONGREAL; VAR c3: Coords3D; ); (* Scales the coordinates of all existing vertices by "s". *) PROCEDURE MeanVertexDistance3D( READONLY top: Topology; READONLY c3: Coords3D; ): LONGREAL; (* The average distance of existing vertices from the origin, in the root-mean-square sense; that is, "sqrt(sum(norm(c3[v])^2, v IN VExist)) /|VExist|)". *) PROCEDURE NormalizeVertexDistance3D( READONLY top: Topology; VAR c3: Coords3D; ); (* Shifts and scales all existing vertices so that they have barycenter (0,0,0) and unit mean square distance from the origin. *) PROCEDURE TetraDet3D(u,v,w,x: CARDINAL; READONLY c3: Coords3D): LONGREAL; (* Signed determinant of the points "c3[u],c3[v],c3[w],c3[x]", padded at the right with a column of "1"s. The absolute value of "TetraDet3D" is is six times the volume of the tetrahedron "u,v,w,x", and the sign gives the handedness of the screw "u->v->w->x".*) PROCEDURE FaceIsSilhouette(a: Pair; READONLY c3: Coords3D): BOOLEAN; (* Return TRUE iff the projected face associated to the pair "a" is a silhouette face. *) PROCEDURE EdgeWindingNumber(a: Pair; READONLY c3: Coords3D): INTEGER; (* Returns the winding number of the tetrahedra incident to the edge. In a proper embedding, the number should be +1 or -1. *) PROCEDURE ChoosePlaneThroughPoints(u, v: LR3.T): LR4.T; (* Chooses a plane through the points "u" and "v". Returns the plane coefficients, the last one being the independent term. *) PROCEDURE WriteState3D( name: TEXT; READONLY top: Topology; READONLY c: Coords3D; comments: TEXT := " "; ); (* Writes the coordinates geometrics to file disk in a format that can be read back. The file will have the given "name" with ".st3" appended. *) PROCEDURE ReadState3D(name: TEXT): REF Coords3D; (* Reads a disk file created by "WriteState3D". The file must have the given "name" with ".st3" appended. *) (* procedures associated to the R.L.W.L.'s tools *) PROCEDURE ReadHeader(rd: Rd.T; type, param: TEXT := NIL): CARDINAL RAISES {Rd.EndOfFile}; (* Similar procedure to "FileFmt.ReadHeader". *) PROCEDURE ReadFooter(rd: Rd.T; type: TEXT); (* Similar procedure to "FileFmt.ReadFooter". *) PROCEDURE ReadVectors(rd: Rd.T; n: CARDINAL; pos: Vectors3D); (* Allow to read one array of LR3.T. *) PROCEDURE WriteStates( wr: Wr.T; time: LONGREAL; READONLY vertex: ARRAY OF Vertex; (* Vertex coordinates *) prec: CARDINAL := 4; comments: TEXT := " "; ); (* Writes the 3D states (".sts") *) PROCEDURE WriteTetrahedra( name: TEXT; READONLY top: Topology; READONLY cell: ARRAY OF Tetrahedron; comments: TEXT := " "; ); (* Write the tetrahedra format (".te") *) PROCEDURE ReadTetrahedron(rd: Rd.T; VAR t: Tetrahedron); (* Read a disk file created by "WriteTetrahedra". *) PROCEDURE WriteHeader(wr: Wr.T; type, param: TEXT := NIL; n: CARDINAL := 0); (* Similar procedure to "FileFmt.WriteHeader". *) END Tridimensional. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/UneqVolEnergy.i3 INTERFACE UneqVolEnergy; (* NOT USED *) IMPORT Energy; TYPE T <: Public; Public = Energy.T OBJECT METHODS init(): T; END; (* The "Unequal" energy measures the discrepancy between the volume of two tetrahedrons incident to every face relevant of Triangulation. *) END UneqVolEnergy. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/VStar.i3 INTERFACE VStar; (* This interface contain procedures to build several faces such as: n-gons, triangles and squares, and complexes : cube, ball, bigcube (3D array of cube) with procedures for the glueing of two such complexes. Created by L. Lozada (see the copyright and authorship futher down). Revisions: 30-08-2000 : Nice version of the "MakeOctahedron" procedure. 19-09-2000 : Added the procedure "MakeDodecahedronTriang". 27-10-2000 : Modified "SetCubePropiertes" procedure. 04-11-2000 : Added the "CubeNegVertices" and "CubeBarycenter" procedures. *) IMPORT Triangulation; FROM Triangulation IMPORT Pair; PROCEDURE MakeTetrahedronTriang(): ARRAY [0..3] OF Pair; (* Builds a Tetrahedral vertex star. *) PROCEDURE MakeOctahedronTriang(): ARRAY [0..7] OF Pair; (* Builds a triangulated Octahedron. If Original=TRUE the procedure empha- size the original elements. *) PROCEDURE MakeIcosahedronTriang(): ARRAY [0..19] OF Pair; (* Builds a triangulated Icosahedron. If Original=TRUE the procedure empha- size the original elements. *) PROCEDURE MakeDodecahedronTriang() : ARRAY[0..11] OF ARRAY [0..4] OF Pair; (* Builds a triangulated Dodecahedron, trough the automatic gluing of tetrahedra. If Original=TRUE the procedure emphasize the original elements. *) END VStar. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/VarKamSpring.i3 INTERFACE VarKamSpring; IMPORT Energy; TYPE T <: Public; Public = Energy.T OBJECT length: REAL; (* Ideal edge length for. *) strength: REAL; (* Edge strength factor. *) METHODS init(): T; END; (* In Kamada's energy, a spring is placed between every pair of triangulation vertices u, v, adjacent or not, whose length is equal to the graph-theoretical distance between u and v in T. In this version, the distances are computed by setting each edge's length to "length * sqrt (Na/Nb + Nb/Na)" where "Na" and "Nb" are the endpoint degrees. *) END VarKamSpring. (* Last edited on 2001-05-21 02:35:52 by stolfi *) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/VarWindingEnergy.i3 INTERFACE VarWindingEnergy; IMPORT Energy; TYPE T <: Public; Public = Energy.T OBJECT kind: Kind; METHODS init(): T; END; (* The "VarWinding" energy penalizes edges whose star, when projected to "R^3", is too irregular, or does not make a single complete turn around the edge's line. The projection to R^3 is performed by dropping the last coordinate. *) TYPE Kind = { Perimeter, Area }; (* Which energy formula to use. *) (* Let "e" be an edge with endpoints "u,v", and let "w[i]" (for "i" in "0..N-1") be the third corner of the "i"th triangle incident to "e", in topological order. Let "L" be the line supporting "e", and "P" be a plane orthogonal to "L". Define "h = v - u", "r[i] = h × (w[i] - u)". Note that "|r[i]|" is the distance from "w[i]" to the line "L" (projected onto the plane "P"), times "|h|". Define also "R = sum{ |r[i]|^2 }/RNorm", where "RNorm" is a normalization factor that depends only on the local topology (see below). For the "Perimeter" formula, we define also "s[i] = h × (w[i] - w[i-1])", and "S = sum{ |s[i]|^2 }/SNorm", where "SNorm" is a normalization factor. Note that "|s[i]|" is the length of the edge "w[i] - w[i-1]", projected onto "P" and scaled by "|h|". For the "Area" formula, we define instead "s[i] = ((r[i] × r[i-1])", and "S = sum{ s[i] }/SNorm", where "SNorm" is a (different) normalization factor. Note that "s[i]" here is the signed area of the triangle "u,w[i-1],w[i]", projected onto "P", scaled by "|h|^2", and multiplied by the direction of "h"; so that "S" is the area of the polygon "w[0],.. w[N-1]", also projected onto "P" and scaled by "|h|^2". In either case, the energy contributed by edge "e" is "(S/R + R/S)^2 - 4". This formula has minimum value (zero) when "|R| = |S|", and tends to infinity when "|R/S| -> 0" or "|S/R| -> 0". The normalization factors "RNorm" and "SNorm" are chosen so that "R,S,T" have the same value when the "w[i]", projected onto "P", have an ideal configuration around the line "L". If "e" is an interior edge, the ideal configuration is a regular "N"-gon of arbitrary radius centered on the edge. If "e" lies on the manifold's boundary, and there are "G" gaps (missing cells) in the ring of elements surrounding "e", then the ideal configuration is a regular "2(N-G)"-gon, consisting of "N-G" `filled' sectors (corresponding to the non-missing cells) and "N-G" `empty' ones (corresponding to missing cells, or fractions thereof). The normalization factors are, therefore | RNorm = In either case, the quantities "R" and "S" will have the same value "b^2|h|^2" In the "Perimeter" formula, . In the "Area" formula, the energy contributed to "e" is "T/R + R/T - 2". Note that both formulas are not affected by changes of scale in the "r[i]" or "h". The above defintions assume that "e" is an interior edge. If "e" lies on the manifold's border, the "S" and "T" sums ignore the `gaps' (pairs "w[i], w[i-1]" that are separated by a null polyhedron). In that case, the factors "SNorm,TNorm" are chosen to give "S = T = b^2|h|^2" when the "w[i]" are "N" corners of a regular "2(N-G)"-gon, where "G" is the number of gaps. *) END VarWindingEnergy. (* Last edited on 2001-05-20 19:46:56 by stolfi *) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/WindingEnergy.i3 INTERFACE WindingEnergy; IMPORT Energy; TYPE T <: Public; Public = Energy.T OBJECT METHODS init(): T; END; (* The "Winding" energy penalizes edges whose star, when projected to "R^3", is too irregular, or does not make a single complete turn around the edge's line. The projection to R^3 is performed by dropping the last coordinate. Let "e" be an edge with endpoints "u,v", and let "w[i]" (for "i" in "0..N-1") be the third corner of the "i"th triangle incident to "e", in topological order. Let "L" be the line supporting "e", and "P" be a plane orthogonal to "L". Define "h = v - u", "r[i] = h × (w[i] - u)". Note that "|r[i]|" is the distance from "w[i]" to the line "L" (projected onto the plane "P"), times "|h|". Define also "R = sum{ |r[i]|^2 }/RNorm", where "RNorm" is a normalization factor that depends only on the local topology (see below). Note that, for a fixed topology, "R" is proportional to the mean squared distance of the points "w[i]" to the line "L", times "|h|^2" Define furthermore "s[i] = h × (w[i] - w[i-1])", and "S = sum{ |s[i]|^2 }/SNorm", where "SNorm" is a normalization factor. Note that "|s[i]|" is the length of the edge "w[i] - w[i-1]", projected onto "P" and scaled by "|h|". Thus, for a fixed topology, "S" is proportional to the mean squared length of the sides of the polygon "w[0..N-1]", projected onto "P", times "|h|^2". The energy contributed by edge "e" is then defined as "S/R + R/S - 2". This formula has minimum value (zero) when "R = S", and tends to infinity when "R/S -> 0" or "S/R -> 0". Note, furthermore, that this energy is invariant with respect to the length of the edge "e", to arbitrary displacement of the "w[i]" parallel to "L", and to uniform scaling of the configuration. The normalization factors "RNorm" and "SNorm" are chosen so that "R" and "S" have the same value when the "w[i]", projected onto "P", have an ideal configuration around the line "L". If "e" is an interior edge, the ideal configuration is a regular "N"-gon of arbitrary radius centered on the edge. The normalization factors are then | RNorm = N | SNorm = 4·N·(sin(Pi/N))^2 If "e" lies on the manifold's boundary, and there are "G" gaps (missing cells) in the ring of elements surrounding "e", then the ideal configuration is a regular "2(N-G)"-gon, consisting of "N-G" `filled' sectors (corresponding to the non-missing cells) and "N-G" `empty' ones (corresponding to missing cells, or fractions thereof). The normalization factors are then | RNorm = N | SNorm = 4·(N-G)·(sin(Pi/2/(N-G)))^2 *) END WindingEnergy. (* Last edited on 2001-05-20 19:53:42 by stolfi *) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Bary.m3 MODULE Bary; (* This module contain essentially procedures created by J. Stolfi and R. Marcone (see the copyright and authorship futher down), modified L. P. Lozada for the case tridimensional. *) IMPORT Octf, Triangulation, Word; FROM Octf IMPORT Spin; REVEAL FacetEdge = PublicFacetEdge BRANDED OBJECT OVERRIDES init := Barynit; END; PROCEDURE Barynit(s: FacetEdge; order1,order2: CARDINAL): FacetEdge = BEGIN EVAL NARROW(s, Octf.FacetEdge).init(); s.ca := Triangulation.MakeTetraTopo(order1,order2); s.order1 := order1; s.order2 := order2; RETURN s END Barynit; PROCEDURE MakeFacetEdge(order1,order2: CARDINAL): Pair = BEGIN WITH e = NEW(FacetEdge).init(order1,order2) DO RETURN Pair{facetedge := e, bits := 0}; END; END MakeFacetEdge; PROCEDURE Corner(a: Pair): Triangulation.Pair = BEGIN WITH r = a.bits DO RETURN a.facetedge.ca[r]; END; END Corner; PROCEDURE SetCorner(a: Pair; c: Triangulation.Pair) = BEGIN WITH r = a.bits DO a.facetedge.ca[r] := c; END; END SetCorner; PROCEDURE CCorner(a: Pair): Triangulation.Pair = BEGIN WITH r = Word.Xor(a.bits, 1) DO RETURN Spin(a.facetedge.ca[r]); END; END CCorner; PROCEDURE SetCCorner(a: Pair; c: Triangulation.Pair) = BEGIN WITH r = Word.Xor(a.bits, 1) DO a.facetedge.ca[r] := Spin(c); END; END SetCCorner; BEGIN END Bary. (**************************************************************************) (* *) (* Copyright (C) 2001 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (* Last edited on 2001-05-21 01:39:42 by stolfi *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/CmpAreaEnergy.m3 MODULE CmpAreaEnergy; IMPORT LR4, Fmt, Triangulation, Math; FROM Octf IMPORT Enext_1, Enext; FROM Triangulation IMPORT OrgV, Topology; FROM Energy IMPORT Coords, Gradient; TYPE BOOLS = ARRAY OF BOOLEAN; LONGS = ARRAY OF LONGREAL; REVEAL T = Public BRANDED OBJECT K: LONGREAL; (* The energy normalization factor *) top: Topology; (* The topology *) vVar: REF BOOLS; (* TRUE if vertex is variable *) faceRelevant: REF BOOLS; (* TRUE if face is relevant *) af: REF LONGS; (* Area of each face relevant *) eDaf: REF LONGS (* (Work) Derivative of Energy rel. to face area *) OVERRIDES init := Init; defTop := DefTop; defVar := DefVar; eval := Eval; name := Name; END; PROCEDURE Init(erg: T): T = BEGIN RETURN erg END Init; PROCEDURE DefTop(erg: T; READONLY top: Topology) = BEGIN erg.K := 1.0d0/FLOAT(top.NF, LONGREAL); erg.top := top; erg.vVar := NEW(REF BOOLS, top.NV); erg.faceRelevant := NEW(REF BOOLS, top.NF); (* Allocate area tables: *) erg.af := NEW(REF ARRAY OF LONGREAL, top.NF); erg.eDaf := NEW(REF LONGS, top.NF); (* Just in case the client forgets to call "defVar": *) FOR i := 0 TO top.NV-1 DO erg.vVar[i] := FALSE END; FOR i := 0 TO top.NF-1 DO erg.faceRelevant[i] := FALSE END; END DefTop; PROCEDURE DefVar(erg: T; READONLY variable: BOOLS) = BEGIN (* Decide which face are relevant to Area Compression energy. A face is relevant iff it exists, and the face have at least one variable corner. *) WITH NV = erg.top.NV, NF = erg.top.NF, vVar = erg.vVar^, face = erg.top.face^, faceRelevant = erg.faceRelevant^ DO <* ASSERT NUMBER(variable) = NV *> vVar := variable; (* Find the relevant faces: *) FOR i := 0 TO NF-1 DO faceRelevant[i] := FALSE; END; FOR i := 0 TO NF-1 DO WITH f = face[i], a = f.pa^, u = OrgV(a), v = OrgV(Enext(a)), w = OrgV(Enext_1(a)), vvar = vVar[u.num] OR vVar[v.num] OR vVar[w.num] DO IF f.exists AND vvar THEN <* ASSERT u.exists AND v.exists AND w.exists *> faceRelevant[i] := TRUE; ELSE faceRelevant[i] := FALSE; END END END; END END DefVar; PROCEDURE Eval( erg: T; READONLY c: Coords; VAR e: LONGREAL; grad: BOOLEAN; VAR eDc: Gradient; ) = BEGIN WITH NV = erg.top.NV, NF = erg.top.NF, face = erg.top.face^, faceRelevant = erg.faceRelevant^, af = erg.af^, eDaf = erg.eDaf^, vVar = erg.vVar^, K = erg.K, A = FLOAT(erg.area, LONGREAL) DO PROCEDURE Accum_a(READONLY u,v,w: CARDINAL; VAR area: LONGREAL) = (* Compute the area of triangle with endpoints vertices (number) u,v,w. *) BEGIN WITH aa = LR4.Sub(c[u],c[v]), a = LR4.Norm(aa), bb = LR4.Sub(c[u],c[w]), b = LR4.Norm(bb), cc = LR4.Sub(c[v],c[w]), c = LR4.Norm(cc), p = (a+b+c), p2a = p - 2.0d0 * a, p2b = p - 2.0d0 * b, p2c = p - 2.0d0 * c, num = Math.sqrt(p * p2a * p2b * p2c) DO <* ASSERT p # 0.0d0 *> area := num/4.0d0; END; END Accum_a; PROCEDURE Accum_e_from_a(a: LONGREAL; VAR e: LONGREAL; VAR etDa : LONGREAL ) = (* Adds to "e" the energy term corresponting to area face "a" . *) BEGIN WITH r = a/A, s = Math.log(r)*Math.log(r) DO <* ASSERT a # 0.0d0 *> <* ASSERT r # 0.0d0 *> <* ASSERT 0.0d0 <= s *> e := e + K * s; IF grad THEN etDa := 2.0d0 * K * Math.log(r)/a; ELSE etDa := 0.0d0; END END END Accum_e_from_a; PROCEDURE Distribute_eDa(iu, iv, iw: CARDINAL; eDa: LONGREAL ) = (* Accumulates in "eDc" the gradient of "e" relative to the corners of the triangle "iu iv iw", given the derivative "eDa" of "e" relative to the triangle's area "a". *) BEGIN WITH u = c[iu], v = c[iv], w = c[iw], aa = LR4.Sub(u,v), a = LR4.Norm(aa), bb = LR4.Sub(u,w), b = LR4.Norm(bb), cc = LR4.Sub(v,w), c = LR4.Norm(cc), abc = a * b * c, bc = abc/a, ac = abc/b, ab = abc/c, p = (a+b+c), p2a = p - 2.0d0 * a, p2b = p - 2.0d0 * b, p2c = p - 2.0d0 * c, num = Math.sqrt(p * p2a * p2b * p2c), eDv = eDc[iv], eDu = eDc[iu], eDw = eDc[iw] DO IF p # 0.0d0 THEN WITH p3 = p * p * p, p2 = p * p, num1 = 4.0d0*p3-6.0d0*p2*(p)+8.0d0*p*(bc+ac+ab)-8.0d0*abc, aDp = (1.0d0/8.0d0) * num1 * (1.0d0/num), eDp = eDa * aDp, pDcu = LR4.Mix(1.0d0/a,aa,1.0d0/b,bb), pDcv = LR4.Mix(-1.0d0/a,aa,1.0d0/c,cc), pDcw = LR4.Mix(-1.0d0/b,bb,-1.0d0/c,cc), eDcu = LR4.Scale(eDp, pDcu), eDcv = LR4.Scale(eDp, pDcv), eDcw = LR4.Scale(eDp, pDcw) DO IF vVar[iv] THEN eDv := LR4.Add(eDv,eDcv); END; IF vVar[iu] THEN eDu := LR4.Add(eDu, eDcu); END; IF vVar[iw] THEN eDw := LR4.Add(eDw, eDcw); END; END END END END Distribute_eDa; BEGIN (* Clear area accumulators: *) FOR i := 0 TO NF-1 DO af[i] := 0.0d0; END; (* Enumerate faces and accumulate face areas: *) FOR j := 0 TO NF-1 DO IF faceRelevant[j] THEN WITH f = face[j], a = f.pa^, un = OrgV(a).num, vn = OrgV(Enext(a)).num, wn = OrgV(Enext_1(a)).num DO Accum_a(un,vn,wn,af[j]); END END END; (* Compute energy "e" from faces areas, and the gradient "eDaf" *) e := 0.0d0; FOR j := 0 TO NF-1 DO IF faceRelevant[j] THEN Accum_e_from_a(af[j],e, eDaf[j]); ELSE eDaf[j] := 0.0d0; END; END; (* Now distribute "eDaf" over "eDc": *) FOR i := 0 TO NV-1 DO eDc[i] := LR4.T{0.0d0,0.0d0,0.0d0,0.0d0}; END; IF grad THEN FOR j := 0 TO NF-1 DO IF faceRelevant[j] THEN WITH f = face[j], a = f.pa^, un = OrgV(a).num, vn = OrgV(Enext(a)).num, wn = OrgV(Enext_1(a)).num DO Distribute_eDa(un, vn, wn, eDaf[j]); END END END END END END END Eval; PROCEDURE Name(erg: T): TEXT = BEGIN RETURN "Area(rarea:= " & Fmt.Real(erg.area, Fmt.Style.Fix, prec := 3) & ")" END Name; BEGIN END CmpAreaEnergy. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/CmpVolEnergy.m3 MODULE CmpVolEnergy; IMPORT LR4, LR4Extras, Fmt, Triangulation, Math; FROM Octf IMPORT Tors, Clock, Enext_1, Fnext_1, Enext; FROM Triangulation IMPORT OrgV, Topology; FROM Energy IMPORT Coords, Gradient; CONST Zero = 0.0d0; TYPE BOOLS = ARRAY OF BOOLEAN; LONGS = ARRAY OF LONGREAL; REVEAL T = Public BRANDED OBJECT K: LONGREAL; (* The energy normalization factor *) top: Topology; (* The topology *) vVar: REF BOOLS; (* TRUE if vertex is variable *) polyRelevant: REF BOOLS; (* TRUE if polyhedron is relevant *) vp: REF LONGS; (* (Work) Volume of each polyhedron *) eDvp: REF LONGS; (* (Work) Derivate of energy rel. to volume polyhedrons *) OVERRIDES init := Init; defTop := DefTop; defVar := DefVar; eval := Eval; name := Name; END; PROCEDURE Init(erg: T): T = BEGIN RETURN erg END Init; PROCEDURE DefTop(erg: T; READONLY top: Topology) = BEGIN erg.K := 1.0d0/FLOAT(top.NP, LONGREAL); erg.top := top; erg.vVar := NEW(REF BOOLS, top.NV); erg.polyRelevant := NEW(REF BOOLS, top.NP); (* Allocate volume tables: *) erg.vp := NEW(REF LONGS, top.NP); erg.eDvp := NEW(REF LONGS, top.NP); (* Just in case the client forgets to call "defVar": *) FOR i := 0 TO top.NV-1 DO erg.vVar[i] := FALSE END; FOR i := 0 TO top.NP-1 DO erg.polyRelevant[i] := FALSE END; END DefTop; PROCEDURE DefVar(erg: T; READONLY variable: BOOLS) = BEGIN (* Decide which polyhedrons are relevant to volume compression energy. A polyhedron is relevant iff it exists, has exactly four faces being least one existing triangular face having at least one variable corner. *) WITH NV = erg.top.NV, NP = erg.top.NP, vVar = erg.vVar^, polyhedron = erg.top.polyhedron^, region = erg.top.region^, polyRelevant = erg.polyRelevant^ DO <* ASSERT NUMBER(variable) = NV *> vVar := variable; (* Find the relevant polyhedrons: *) FOR i := 0 TO NP-1 DO polyRelevant[i] := FALSE; END; FOR i := 0 TO NP-1 DO WITH p = polyhedron[i], r = region[i], a = Tors(r), r1 = Clock(Enext_1(r)), a1 = Tors(r1), u = OrgV(a), v = OrgV(Enext(a)), w = OrgV(Enext_1(a)), x = OrgV(Enext_1(a1)), vvar = vVar[u.num] OR vVar[v.num] OR vVar[w.num] OR vVar[x.num], f1 = a.facetedge.face, f2 = Fnext_1(a).facetedge.face, f3 = Fnext_1(Enext(a)).facetedge.face, f4 = Fnext_1(Enext_1(a)).facetedge.face, fvar = f1.exists OR f2.exists OR f3.exists OR f4.exists DO <* ASSERT (f1 # f2) AND (f2 # f3) AND (f3 # f4) *> IF p.exists AND fvar AND vvar THEN (*<* ASSERT u.exists AND v.exists AND w.exists AND x.exists *>*) polyRelevant[i] := TRUE; END END END END END DefVar; PROCEDURE Eval( erg: T; READONLY c: Coords; VAR e: LONGREAL; grad: BOOLEAN; VAR eDc: Gradient; ) = BEGIN WITH NV = erg.top.NV, NP = erg.top.NP, region = erg.top.region^, vVar = erg.vVar^, polyRelevant = erg.polyRelevant^, vp = erg.vp^, eDvp = erg.eDvp^, K = erg.K, V = FLOAT(erg.volume, LONGREAL) DO PROCEDURE Accum_v(READONLY u, v, w, x: LR4.T; VAR vo: LONGREAL) = (* Compute the volume of the tetrahedron "u v w x". Also stores in "n" the cross product "(v - u) X (w - u) X (x - u)". *) BEGIN WITH uv = LR4.Sub(v, u), uw = LR4.Sub(w, u), ux = LR4.Sub(x, u), n = LR4Extras.Cross(uv, uw, ux) DO vo := vo + 1.0d0/6.0d0 * LR4.Norm(n); END END Accum_v; PROCEDURE Accum_e_from_v(v: LONGREAL; VAR e: LONGREAL; VAR etDv: LONGREAL) = (* Adds to "e" the energy term corresponding to a polyhedron with volume "v". Also, if "grad" is true, stores in "etDv" the derivative of that term. *) BEGIN <* ASSERT v # 0.0d0 *> IF v <= 0.0d0 THEN etDv := 0.0d0 ELSE WITH r = v/V, s = 1.0d0/r, r2 = r*r, s2 = s*s, h = r2 + s2 - 2.0d0, v2 = v*v, v3 = v2*v, V2 = V*V DO e := e + K * h; IF grad THEN etDv := 2.0d0 * K * ( (v/V2) - (V2/v3) ); ELSE etDv := 0.0d0; END END END END Accum_e_from_v; PROCEDURE Distribute_eDv(iu, iv, iw, ix: CARDINAL; eDvo: LONGREAL) = (* Accumulates in "eDc" the gradient of "e" relative to the corners of the tetrahedron "iu iv iw ix", given the derivative "eDv" of "e" relative to the tetrahedron's volume "v". *) BEGIN WITH u = c[iu], v = c[iv], w = c[iw], x = c[ix], u1 = u[0], u2 = u[1], u3 = u[2], u4 = u[3], v1 = v[0], v2 = v[1], v3 = v[2], v4 = v[3], w1 = w[0], w2 = w[1], w3 = w[2], w4 = w[3], x1 = x[0], x2 = x[1], x3 = x[2], x4 = x[3], d1 = u1 * (v2 * (w3-x3) - v3 * (w2-x2) + w2*x3-w3*x2) -u2 * (v1 * (w3-x3) - v3 * (w1-x1) + w1*x3-w3*x1) +u3 * (v1 * (w2-x2) - v2 * (w1-x1) + w1*x2-x1*w2) -(v1*(w2*x3-x2*w3)-v2*(w1*x3-x1*w3)+v3*(w1*x2-x1*w2)), d2 = u1 * (v2 * (w4-x4) - v4 * (w2-x2) + w2*x4-x2*w4) -u2 * (v1 * (w4-x4) - v4 * (w1-x1) + w1*x4-x1*w4 ) +u4 * (v1 * (w2-x2) - v2 * (w1-x1) + w1*x2-x1*w2) -(v1*(w2*x4-x2*w4)-v2*(w1*x4-x1*w4)+v4*(w1*x2-x1*w2)), d3 = u2 * (v3 * (w4-x4) - v4 * (w3-x3) + w3*x4-x3*w4) -u3 * (v2 * (w4-x4) - v4 * (w2-x2) + w2*x4-x2*w4) +u4 * (v2 * (w3-x3) - v3 * (w2-x2) + w2*x3-x2*w3) -(v2*(w3*x4-x3*w4)-v3*(w2*x4-x2*w4)+v4*(w2*x3-x2*w3)), d4 = u1 * (v3 * (w4-x4) - v4 * (w3-x3) + w3*x4-x3*w4) -u3 * (v1 * (w4-x4) - v4 * (w1-x1) + w1*x4-x1*w4) +u4 * (v1 * (w3-x3) - v3 * (w1-x1) + w1*x3-x1*w3) -(v1*(w3*x4-x3*w4)-v3*(w1*x4-x1*w4)+v4*(w1*x3-x1*w3)), d = LR4.T{d1,d2,d3,d4}, sum2 = d1*d1 + d2*d2 + d3*d3 + d4*d4, term = (1.0d0/6.0d0) * (1.0d0/Math.sqrt(sum2)), d1Du1 = v2 * (w3-x3) - v3 * (w2-x2) + w2*x3-w3*x2, d2Du1 = v2 * (w4-x4) - v4 * (w2-x2) + w2*x4-x2*w4, d3Du1 = Zero, d4Du1 = v3 * (w4-x4) - v4 * (w3-x3) + w3*x4-x3*w4, dDu1 = LR4.T{d1Du1, d2Du1, d3Du1, d4Du1}, vDu1 = term * LR4.Dot(d,dDu1), eDu1 = eDvo * vDu1, d1Du2 = - (v1 * (w3-x3) - v3 * (w1-x1) + w1*x3-w3*x1), d2Du2 = - (v1 * (w4-x4) - v4 * (w1-x1) + w1*x4-x1*w4 ), d3Du2 = v3 * (w4-x4) - v4 * (w3-x3) + w3*x4-x3*w4, d4Du2 = Zero, dDu2 = LR4.T{d1Du2, d2Du2, d3Du2, d4Du2}, vDu2 = term * LR4.Dot(d,dDu2), eDu2 = eDvo * vDu2, d1Du3 = v1 * (w2-x2) - v2 * (w1-x1) + w1*x2-x1*w2, d2Du3 = Zero, d3Du3 = - (v2 * (w4-x4) - v4 * (w2-x2) + w2*x4-x2*w4), d4Du3 = - (v1 * (w4-x4) - v4 * (w1-x1) + w1*x4-x1*w4), dDu3 = LR4.T{d1Du3, d2Du3, d3Du3, d4Du3}, vDu3 = term * LR4.Dot(d,dDu3), eDu3 = eDvo * vDu3, d1Du4 = Zero, d2Du4 = v1 * (w2-x2) - v2 * (w1-x1) + w1*x2-x1*w2, d3Du4 = v2 * (w3-x3) - v3 * (w2-x2) + w2*x3-x2*w3, d4Du4 = v1 * (w3-x3) - v3 * (w1-x1) + w1*x3-x1*w3, dDu4 = LR4.T{d1Du4, d2Du4, d3Du4, d4Du4}, vDu4 = term * LR4.Dot(d,dDu4), eDu4 = eDvo * vDu4, d1Dv1 = u2 * (x3-w3) + u3 * (w2-x2) - w2*x3+w3*x2, d2Dv1 = u2 * (x4-w4) + u4 * (w2-x2) - w2*x4+x2*w4, d3Dv1 = Zero, d4Dv1 = u3 * (x4-w4) + u4 * (w3-x3) - w3*x4+x3*w4, dDv1 = LR4.T{d1Dv1, d2Dv1, d3Dv1, d4Dv1}, vDv1 = term * LR4.Dot(d,dDv1), eDv1 = eDvo * vDv1, d1Dv2 = u1 * (w3-x3) + u3 * (x1-w1) + w1*x3-w3*x1 , d2Dv2 = u1 * (w4-x4) + u4 * (x1-w1) + w1*x4-x1*w4 , d3Dv2 = u3 * (x4-w4) + u4 * (w3-x3) - w3*x4+x3*w4, d4Dv2 = Zero, dDv2 = LR4.T{d1Dv2, d2Dv2, d3Dv2, d4Dv2}, vDv2 = term * LR4.Dot(d,dDv2), eDv2 = eDvo * vDv2, d1Dv3 = u1 * (x2-w2) + u2 * (w1-x1) - w1*x2+x1*w2, d2Dv3 = Zero, d3Dv3 = u2 * (w4-x4) + u4 * (x2-w2) + w2*x4-x2*w4 , d4Dv3 = u1 * (w4-x4) + u4 * (x1-w1) + w1*x4-x1*w4 , dDv3 = LR4.T{d1Dv3, d2Dv3, d3Dv3, d4Dv3}, vDv3 = term * LR4.Dot(d,dDv3), eDv3 = eDvo * vDv3, d1Dv4 = Zero, d2Dv4 = u1 * (x2-w2) + u2 * (w1-x1) - w1*x2+x1*w2, d3Dv4 = u2 * (x3-w3) + u3 * (w2-x2) - w2*x3+x2*w3, d4Dv4 = u1 * (x3-w3) + u3 * (w1-x1) - w1*x3+x1*w3, dDv4 = LR4.T{d1Dv4, d2Dv4, d3Dv4, d4Dv4}, vDv4 = term * LR4.Dot(d,dDv4), eDv4 = eDvo * vDv4, d1Dw1 = u2 * (v3-x3) + u3 * (x2-v2) + v2*x3-v3*x2, d2Dw1 = u2 * (v4-x4) + u4 * (x2-v2) + v2*x4-x2*v4, d3Dw1 = Zero, d4Dw1 = u3 * (v4-x4) + u4 * (x3-v3) + v3*x4-x3*v4, dDw1 = LR4.T{d1Dw1, d2Dw1, d3Dw1, d4Dw1}, vDw1 = term * LR4.Dot(d,dDw1), eDw1 = eDvo * vDw1, d1Dw2 = u1 * (x3-v3) + u3 * (v1-x1) - v1*x3+v3*x1 , d2Dw2 = u1 * (x4-v4) + u4 * (v1-x1) - v1*x4+x1*v4 , d3Dw2 = u3 * (v4-x4) + u4 * (x3-v3) + v3*x4-x3*v4, d4Dw2 = Zero, dDw2 = LR4.T{d1Dw2, d2Dw2, d3Dw2, d4Dw2}, vDw2 = term * LR4.Dot(d,dDw2), eDw2 = eDvo * vDw2, d1Dw3 = u1 * (v2-x2) + u2 * (x1-v1) + v1*x2-x1*v2, d2Dw3 = Zero, d3Dw3 = u2 * (x4-v4) + u4 * (v2-x2) - v2*x4+x2*v4 , d4Dw3 = u1 * (x4-v4) + u4 * (v1-x1) - v1*x4+x1*v4 , dDw3 = LR4.T{d1Dw3, d2Dw3, d3Dw3, d4Dw3}, vDw3 = term * LR4.Dot(d,dDw3), eDw3 = eDvo * vDw3, d1Dw4 = Zero, d2Dw4 = u1 * (v2-x2) + u2 * (x1-v1) + v1*x2-x1*v2, d3Dw4 = u2 * (v3-x3) + u3 * (x2-v2) + v2*x3-x2*v3, d4Dw4 = u1 * (v3-x3) + u3 * (x1-v1) + v1*x3-x1*v3, dDw4 = LR4.T{d1Dw4, d2Dw4, d3Dw4, d4Dw4}, vDw4 = term * LR4.Dot(d,dDw4), eDw4 = eDvo * vDw4, d1Dx1 = u2 * (w3-v3) + u3 * (v2-w2) - v2*w3+v3*w2, d2Dx1 = u2 * (w4-v4) + u4 * (v2-w2) - v2*w4+w2*v4, d3Dx1 = Zero, d4Dx1 = u3 * (w4-v4) + u4 * (v3-w3) - v3*w4+w3*v4, dDx1 = LR4.T{d1Dx1, d2Dx1, d3Dx1, d4Dx1}, vDx1 = term * LR4.Dot(d,dDx1), eDx1 = eDvo * vDx1, d1Dx2 = u1 * (v3-w3) + u3 * (w1-v1) + v1*w3-v3*w1 , d2Dx2 = u1 * (v4-w4) + u4 * (w1-v1) + v1*w4-w1*v4 , d3Dx2 = u3 * (w4-v4) + u4 * (v3-w3) + v4*w3-v3*w4, d4Dx2 = Zero, dDx2 = LR4.T{d1Dx2, d2Dx2, d3Dx2, d4Dx2}, vDx2 = term * LR4.Dot(d,dDx2), eDx2 = eDvo * vDx2, d1Dx3 = u1 * (w2-v2) + u2 * (v1-w1) - v1*w2+w1*v2, d2Dx3 = Zero, d3Dx3 = u2 * (v4-w4) + u4 * (w2-v2) + v2*w4-w2*v4 , d4Dx3 = u1 * (v4-w4) + u4 * (w1-v1) + v1*w4-w1*v4 , dDx3 = LR4.T{d1Dx3, d2Dx3, d3Dx3, d4Dx3}, vDx3 = term * LR4.Dot(d,dDx3), eDx3 = eDvo * vDx3, d1Dx4 = Zero, d2Dx4 = u1 * (w2-v2) + u2 * (v1-w1) - v1*w2+w1*v2, d3Dx4 = u2 * (w3-v3) + u3 * (v2-w2) - v2*w3+w2*v3, d4Dx4 = u1 * (w3-v3) + u3 * (v1-w1) - v1*w3+w1*v3, dDx4 = LR4.T{d1Dx4, d2Dx4, d3Dx4, d4Dx4}, vDx4 = term * LR4.Dot(d,dDx4), eDx4 = eDvo * vDx4 DO IF vVar[iu] THEN eDc[iu,0] := eDc[iu,0] + eDu1; eDc[iu,1] := eDc[iu,1] + eDu2; eDc[iu,2] := eDc[iu,2] + eDu3; eDc[iu,3] := eDc[iu,3] + eDu4; END; IF vVar[iv] THEN eDc[iv,0] := eDc[iv,0] + eDv1; eDc[iv,1] := eDc[iv,1] + eDv2; eDc[iv,2] := eDc[iv,2] + eDv3; eDc[iv,3] := eDc[iv,3] + eDv4; END; IF vVar[iw] THEN eDc[iw,0] := eDc[iw,0] + eDw1; eDc[iw,1] := eDc[iw,1] + eDw2; eDc[iw,2] := eDc[iw,2] + eDw3; eDc[iw,3] := eDc[iw,3] + eDw4; END; IF vVar[ix] THEN eDc[ix,0] := eDc[ix,0] + eDx1; eDc[ix,1] := eDc[ix,1] + eDx2; eDc[ix,2] := eDc[ix,2] + eDx3; eDc[ix,3] := eDc[ix,3] + eDx4; END; END END Distribute_eDv; BEGIN (* Clear volume accumulators: *) FOR j := 0 TO NP-1 DO vp[j] := 0.0d0 END; (* Enumerate polyhedrons and accumulate polyhedron volumes: *) FOR j := 0 TO NP-1 DO IF polyRelevant[j] THEN WITH t = region[j], a = Tors(t), t1 = Clock(Enext_1(t)), a1 = Tors(t1), un = OrgV(a).num, vn = OrgV(Enext(a)).num, wn = OrgV(Enext_1(a)).num, xn = OrgV(Enext_1(a1)).num DO Accum_v(c[un], c[vn], c[wn], c[xn], vp[j]) END END END; (* Compute energy "e" from polyhedrons volumes, and the gradient "eDvp": *) e := 0.0d0; FOR p := 0 TO NP-1 DO IF polyRelevant[p] THEN Accum_e_from_v(vp[p], e, eDvp[p]) ELSE eDvp[p] := 0.0d0 END END; (* Now distribute "eDvp" over "eDc": *) FOR i := 0 TO NV-1 DO eDc[i] := LR4.T{0.0d0, ..} END; IF grad THEN FOR j := 0 TO NP-1 DO IF polyRelevant[j] THEN WITH t = region[j], a = Tors(t), t1 = Clock(Enext_1(t)), a1 = Tors(t1), un = OrgV(a).num, vn = OrgV(Enext(a)).num, wn = OrgV(Enext_1(a)).num, xn = OrgV(Enext_1(a1)).num DO Distribute_eDv(un, vn, wn, xn, eDvp[j]) END END END END; END END END Eval; PROCEDURE Name(erg: T): TEXT = BEGIN RETURN "Compr(iVol := " & Fmt.Real(erg.volume, Fmt.Style.Fix, prec := 3) & ")" END Name; BEGIN END CmpVolEnergy. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/CoherentEnergy.m3 MODULE CoherentEnergy; IMPORT LR4Extras, Triangulation, Math, LR4, Wr, Thread, Process, LR3; FROM Octf IMPORT Tors, Clock, Enext_1, Fnext_1, Enext; FROM Triangulation IMPORT OrgV, Topology; FROM Energy IMPORT Coords, Gradient; FROM Stdio IMPORT stderr; CONST Zero = 0.0d0; Epsilon = 0.0000000001d0; TYPE BOOLS = ARRAY OF BOOLEAN; LONGS = ARRAY OF LONGREAL; REVEAL T = Public BRANDED OBJECT K: LONGREAL; (* The energy normalization factor *) top: Topology; (* The topology *) vVar: REF BOOLS; (* TRUE if vertex is variable *) faceRelevant: REF BOOLS; (* TRUE if face is relevant *) prodet: REF LONGS; (* The product of the determinants of the two tetrahedra incident in each internal face *) eDprodet: REF LONGS; (* (Work) Derivate of energy relative to the product of determinants. *) Wa,Wb,Wc,Wd : LR4.T; (* 4D viewing matrix *) Data4Radius: LONGREAL; (* Radius of vertices in R^{4} *) OVERRIDES init := Init; defTop := DefTop; defVar := DefVar; eval := Eval; name := Name; END; PROCEDURE Init(erg: T) : T = BEGIN RETURN erg END Init; PROCEDURE DefTop(erg: T; READONLY top: Topology) = BEGIN erg.K := 1.0d0/FLOAT(top.NF, LONGREAL); erg.top := top; erg.vVar := NEW(REF BOOLS, top.NV); erg.faceRelevant := NEW(REF BOOLS, top.NF); (* Allocate product determinant tables: *) erg.prodet := NEW(REF LONGS, top.NF); erg.eDprodet := NEW(REF LONGS, top.NF); (* Just in case the client forgets to call "defVar": *) FOR i := 0 TO top.NV-1 DO erg.vVar[i] := FALSE END; FOR i := 0 TO top.NF-1 DO erg.faceRelevant[i] := FALSE END; (* Compute the 4D matrix of viewing *) CalcV4Matrix(erg); erg.Data4Radius := 1.43215593075614510d0; END DefTop; PROCEDURE DefVar(erg: T; READONLY variable: BOOLS) = BEGIN (* Decide which triangular faces are relevant to "Coherent" energy. A face is relevant iff it exists, has at least one variable corner and is an internal face (i.e. has exactly two tetrahedra incident to it) and least one tetrahedra is an existing tetrahedron. *) WITH NV = erg.top.NV, NF = erg.top.NF, vVar = erg.vVar^, face = erg.top.face^, faceRelevant = erg.faceRelevant^ DO <* ASSERT NUMBER(variable) = NV *> vVar := variable; (* Find the relevant faces: *) FOR i := 0 TO NP-1 DO polyRelevant[i] := FALSE; END; FOR i := 0 TO NP-1 DO WITH p = polyhedron[i], r = region[i], a = Tors(r), r1 = Clock(Enext_1(r)), a1 = Tors(r1), u = OrgV(a), v = OrgV(Enext(a)), w = OrgV(Enext_1(a)),q x = OrgV(Enext_1(a1)), vvar = vVar[u.num] OR vVar[v.num] OR vVar[w.num] OR vVar[x.num], f1 = a.facetedge.face, f2 = Fnext_1(a).facetedge.face, f3 = Fnext_1(Enext(a)).facetedge.face, f4 = Fnext_1(Enext_1(a)).facetedge.face DO <* ASSERT (f1 # f2) AND (f2 # f3) AND (f3 # f4) *> IF p.exists AND vvar THEN <* ASSERT u.exists AND v.exists AND w.exists AND x.exists *> polyRelevant[i] := TRUE; END END END END END DefVar; PROCEDURE CalcV4Matrix(erg: T) = (* This procedure computes the four basis vectors for the 4D viewing matrix, Wa,Wb,Wc, and Wd. Note that the Up vector transforms to Wb, the Over vector transforms to Wc, and the line of sight transforms to Wd. The Wa vector is then computed from Wb,Wc and Wd. *) <* FATAL Wr.Failure, Thread.Alerted *> VAR norm : LONGREAL; BEGIN WITH From4 = erg.From4, To4 = erg.To4, Up4 = erg.Up4, Over4 = erg.Over4, Wa = erg.Wa, Wb = erg.Wb, Wc = erg.Wc, Wd = erg.Wd DO (* Calculate Wd, the 4th coordinate basis vector and line-of-sight. *) Wd := LR4.Sub(To4,From4); norm := LR4.Norm(Wd); IF norm < Epsilon THEN Wr.PutText(stderr,"4D To Point and From Point are the same\n"); Process.Exit(1); END; Wd := LR4.Scale(1.0d0/norm, Wd); (* Calculate Wa, the X-axis basis vector. *) Wa := LR4Extras.Cross(Up4,Over4,Wd); norm := LR4.Norm(Wa); IF norm < Epsilon THEN Wr.PutText(stderr, "4D up, over and view vectors are not perpendicular\n"); Process.Exit(1); END; Wa := LR4.Scale(1.0d0/norm, Wa); (* Calculate Wb, the perpendicularized Up vector. *) Wb := LR4Extras.Cross(Over4,Wd,Wa); norm := LR4.Norm(Wb); IF norm < Epsilon THEN Wr.PutText(stderr,"Invalid 4D over vector\n"); Process.Exit(1); END; Wb := LR4.Scale(1.0d0/norm, Wb); (* Calculate Wc, the perpendicularized Over vector. Note that the resulting vector is already normalized, since Wa, Wb and Wd are all unit vectors. *) Wc := LR4Extras.Cross(Wd,Wa,Wb); END END CalcV4Matrix; PROCEDURE Eval( erg: T; READONLY c: Coords; VAR e: LONGREAL; grad: BOOLEAN; VAR eDc: Gradient; ) = BEGIN WITH NV = erg.top.NV, NP = erg.top.NP, region = erg.top.region^, vVar = erg.vVar^, polyRelevant = erg.polyRelevant^, det = erg.det^, eDdet = erg.eDdet^, K = erg.K, Slope = Math.pow(10.0d0,2.0d0), Data4Radius = erg.Data4Radius, Wa = erg.Wa, Wb = erg.Wb, Wc = erg.Wc DO PROCEDURE ProjectTo3D(num: CARDINAL) : LR3.T = VAR c3 : LR3.T; BEGIN WITH TempV = LR4.Sub(c[num],erg.From4), rtemp = 1.0d0 / Data4Radius DO c3[0] := rtemp * LR4.Dot(TempV, erg.Wa); c3[1] := rtemp * LR4.Dot(TempV, erg.Wb); c3[2] := rtemp * LR4.Dot(TempV, erg.Wc); RETURN c3; END END ProjectTo3D; PROCEDURE Accum_det(READONLY U, V, W, X: CARDINAL; VAR dto: LONGREAL) = (* Compute the determinat of the tetrahedron "u v w x" in R^{3}. *) BEGIN WITH pu = ProjectTo3D(U), pv = ProjectTo3D(V), pw = ProjectTo3D(W), px = ProjectTo3D(X), a = LR4.T{pu[0], pu[1], pu[2], 1.0d0}, b = LR4.T{pv[0], pv[1], pv[2], 1.0d0}, c = LR4.T{pw[0], pw[1], pw[2], 1.0d0}, d = LR4.T{px[0], px[1], px[2], 1.0d0} DO dto := dto + LR4Extras.Det(a,b,c,d); END END Accum_det; PROCEDURE Accum_e_from_det(det: LONGREAL; VAR e: LONGREAL; VAR eDdet: LONGREAL) = (* Adds to "e" the energy term corresponding to a polyhedron with determinant "det". Also, if "grad" is true, stores in "eDdet" the derivative of that term. *) BEGIN WITH d2 = det * det, sq = Math.sqrt(1.0d0+d2), h = Slope * (sq-det) DO e := e + K * h; IF grad THEN eDdet := K * (Slope*(det/sq-1.0d0) + 2.0d0 * det ); ELSE eDdet := 0.0d0; END END END Accum_e_from_det; PROCEDURE Distribute_eDdet( READONLY iu,iv,iw,ix: CARDINAL; eDdet: LONGREAL) = (* Accumulates in "eDc" the gradient of "e" relative to the corners of the tetrahedron "iu iv iw ix", given the derivative "eDdet" of "e" relative to the tetrahedron's determinant "det". *) BEGIN WITH rtemp = 1.0d0 / Data4Radius, wa0 = Wa[0], wa1 = Wa[1], wa2 = Wa[2], wa3 = Wa[3], wb0 = Wb[0], wb1 = Wb[1], wb2 = Wb[2], wb3 = Wb[3], wc0 = Wc[0], wc1 = Wc[1], wc2 = Wc[2], wc3 = Wc[3], pu = ProjectTo3D(iu), pv = ProjectTo3D(iv), pw = ProjectTo3D(iw), px = ProjectTo3D(ix), pu0 = pu[0], pu1 = pu[1], pu2 = pu[2], pv0 = pv[0], pv1 = pv[1], pv2 = pv[2], pw0 = pw[0], pw1 = pw[1], pw2 = pw[2], px0 = px[0], px1 = px[1], px2 = px[2], A0 = pw2 - px2, A1 = pw1 - px1, A2 = pw1 * px2 - px1 * pw2, A = pv1 * A0 - pv2 * A1 + A2, B0 = pw2 - px2, B1 = pw0 - px0, B2 = pw0 * px2 - px0 * pw2, B = pv0 * B0 - pv2 * B1 + B2, C0 = pw1 - px1, C1 = pw0 - px0, C2 = pw0 * px1 - px0 * pw1, C = pv0 * C0 - pv1 * C1 + C2, D0 = pw1 * px2 - px1 * pw2, D1 = pw0 * px2 - px0 * pw2, D2 = pw0 * px1 - px0 * pw1, d1Du0 = A * rtemp * wa0, d1Du1 = A * rtemp * wa1, d1Du2 = A * rtemp * wa2, d1Du3 = A * rtemp * wa3, d2Du0 = B * rtemp * wb0, d2Du1 = B * rtemp * wb1, d2Du2 = B * rtemp * wb2, d2Du3 = B * rtemp * wb3, d3Du0 = C * rtemp * wc0, d3Du1 = C * rtemp * wc1, d3Du2 = C * rtemp * wc2, d3Du3 = C * rtemp * wc3, d4Du0 = Zero, d4Du1 = Zero, d4Du2 = Zero, d4Du3 = Zero, detDu0 = d1Du0 - d2Du0 + d3Du0 - d4Du0, detDu1 = d1Du1 - d2Du1 + d3Du1 - d4Du1, detDu2 = d1Du2 - d2Du2 + d3Du2 - d4Du2, detDu3 = d1Du3 - d2Du3 + d3Du3 - d4Du3, eDu0 = eDdet * detDu0, eDu1 = eDdet * detDu1, eDu2 = eDdet * detDu2, eDu3 = eDdet * detDu3, d1Dv0 = pu0 * rtemp * ( A0 * wb0 - A1 * wc0 ), d1Dv1 = pu0 * rtemp * ( A0 * wb1 - A1 * wc1 ), d1Dv2 = pu0 * rtemp * ( A0 * wb2 - A1 * wc2 ), d1Dv3 = pu0 * rtemp * ( A0 * wb3 - A1 * wc3 ), d2Dv0 = pu1 * rtemp * ( B0 * wa0 - B1 * wc0 ), d2Dv1 = pu1 * rtemp * ( B0 * wa1 - B1 * wc1 ), d2Dv2 = pu1 * rtemp * ( B0 * wa2 - B1 * wc2 ), d2Dv3 = pu1 * rtemp * ( B0 * wa3 - B1 * wc3 ), d3Dv0 = pu2 * rtemp * ( C0 * wa0 - C1 * wb0 ), d3Dv1 = pu2 * rtemp * ( C0 * wa1 - C1 * wb1 ), d3Dv2 = pu2 * rtemp * ( C0 * wa2 - C1 * wb2 ), d3Dv3 = pu2 * rtemp * ( C0 * wa3 - C1 * wb3 ), d4Dv0 = rtemp * ( D0 * wa0 - D1 * wb0 + D2 * wc0 ), d4Dv1 = rtemp * ( D0 * wa1 - D1 * wb1 + D2 * wc1 ), d4Dv2 = rtemp * ( D0 * wa2 - D1 * wb2 + D2 * wc2 ), d4Dv3 = rtemp * ( D0 * wa3 - D1 * wb3 + D2 * wc3 ), detDv0 = d1Dv0 - d2Dv0 + d3Dv0 - d4Dv0, detDv1 = d1Dv1 - d2Dv1 + d3Dv1 - d4Dv1, detDv2 = d1Dv2 - d2Dv2 + d3Dv2 - d4Dv2, detDv3 = d1Dv3 - d2Dv3 + d3Dv3 - d4Dv3, eDv0 = eDdet * detDv0, eDv1 = eDdet * detDv1, eDv2 = eDdet * detDv2, eDv3 = eDdet * detDv3, d1Dw0 = pu0 * rtemp * ( wc0 * (pv1-px1) + wb0 * (px2-pv2) ), d1Dw1 = pu0 * rtemp * ( wc1 * (pv1-px1) + wb1 * (px2-pv2) ), d1Dw2 = pu0 * rtemp * ( wc2 * (pv1-px1) + wb2 * (px2-pv2) ), d1Dw3 = pu0 * rtemp * ( wc3 * (pv1-px1) + wb3 * (px2-pv2) ), d2Dw0 = pu1 * rtemp * ( wc0 * (pv0-px0) + wa0 * (px2-pv2) ), d2Dw1 = pu1 * rtemp * ( wc1 * (pv0-px0) + wa1 * (px2-pv2) ), d2Dw2 = pu1 * rtemp * ( wc2 * (pv0-px0) + wa2 * (px2-pv2) ), d2Dw3 = pu1 * rtemp * ( wc3 * (pv0-px0) + wa3 * (px2-pv2) ), d3Dw0 = pu2 * rtemp * ( wb0 * (pv0-px0) + wa0 * (px1-pv1) ), d3Dw1 = pu2 * rtemp * ( wb1 * (pv0-px0) + wa1 * (px1-pv1) ), d3Dw2 = pu2 * rtemp * ( wb2 * (pv0-px0) + wa2 * (px1-pv1) ), d3Dw3 = pu2 * rtemp * ( wb3 * (pv0-px0) + wa3 * (px1-pv1) ), d4Dw0 = rtemp * ( pv0 * (px2*wb0-px1*wc0) + pv1 * (px0*wc0-px2*wa0) + pv2 * (px1*wa0-px0*wb0) ), d4Dw1 = rtemp * ( pv0 * (px2*wb1-px1*wc1) + pv1 * (px0*wc1-px2*wa1) + pv2 * (px1*wa1-px0*wb1) ), d4Dw2 = rtemp * ( pv0 * (px2*wb2-px1*wc2) + pv1 * (px0*wc2-px2*wa2) + pv2 * (px1*wa2-px0*wb2) ), d4Dw3 = rtemp * ( pv0 * (px2*wb3-px1*wc3) + pv1 * (px0*wc3-px2*wa3) + pv2 * (px1*wa3-px0*wb3) ), detDw0 = d1Dw0 - d2Dw0 + d3Dw0 - d4Dw0, detDw1 = d1Dw1 - d2Dw1 + d3Dw1 - d4Dw1, detDw2 = d1Dw2 - d2Dw2 + d3Dw2 - d4Dw2, detDw3 = d1Dw3 - d2Dw3 + d3Dw3 - d4Dw3, eDw0 = eDdet * detDw0, eDw1 = eDdet * detDw1, eDw2 = eDdet * detDw2, eDw3 = eDdet * detDw3, d1Dx0 = pu0 * rtemp * ( wc0 * (pw1-pv1) + wb0 * (pv2-pw2) ), d1Dx1 = pu0 * rtemp * ( wc1 * (pw1-pv1) + wb1 * (pv2-pw2) ), d1Dx2 = pu0 * rtemp * ( wc2 * (pw1-pv1) + wb2 * (pv2-pw2) ), d1Dx3 = pu0 * rtemp * ( wc3 * (pw1-pv1) + wb3 * (pv2-pw2) ), d2Dx0 = pu1 * rtemp * ( wc0 * (pw0-pv0) + wa0 * (pv2-pw2) ), d2Dx1 = pu1 * rtemp * ( wc1 * (pw0-pv0) + wa1 * (pv2-pw2) ), d2Dx2 = pu1 * rtemp * ( wc2 * (pw0-pv0) + wa2 * (pv2-pw2) ), d2Dx3 = pu1 * rtemp * ( wc3 * (pw0-pv0) + wa3 * (pv2-pw2) ), d3Dx0 = pu2 * rtemp * ( wb0 * (pw0-pv0) + wa0 * (pv1-pw1) ), d3Dx1 = pu2 * rtemp * ( wb1 * (pw0-pv0) + wa1 * (pv1-pw1) ), d3Dx2 = pu2 * rtemp * ( wb2 * (pw0-pv0) + wa2 * (pv1-pw1) ), d3Dx3 = pu2 * rtemp * ( wb3 * (pw0-pv0) + wa3 * (pv1-pw1) ), d4Dx0 = rtemp * ( pv0 * (pw1*wc0-pw2*wb0) + pv1 * (pw2*wa0-pw0*wc0) + pv2 * (pw0*wb0-pw1*wa0) ), d4Dx1 = rtemp * ( pv0 * (pw1*wc1-pw2*wb1) + pv1 * (pw2*wa1-pw0*wc1) + pv2 * (pw0*wb1-pw1*wa1) ), d4Dx2 = rtemp * ( pv0 * (pw1*wc2-pw2*wb2) + pv1 * (pw2*wa2-pw0*wc2) + pv2 * (pw0*wb2-pw1*wa2) ), d4Dx3 = rtemp * ( pv0 * (pw1*wc3-pw2*wb3) + pv1 * (pw2*wa3-pw0*wc3) + pv2 * (pw0*wb3-pw1*wa3) ), detDx0 = d1Dx0 - d2Dx0 + d3Dx0 - d4Dx0, detDx1 = d1Dx1 - d2Dx1 + d3Dx1 - d4Dx1, detDx2 = d1Dx2 - d2Dx2 + d3Dx2 - d4Dx2, detDx3 = d1Dx3 - d2Dx3 + d3Dx3 - d4Dx3, eDx0 = eDdet * detDx0, eDx1 = eDdet * detDx1, eDx2 = eDdet * detDx2, eDx3 = eDdet * detDx3 DO IF vVar[iu] THEN eDc[iu,0] := eDc[iu,0] + eDu0; eDc[iu,1] := eDc[iu,1] + eDu1; eDc[iu,2] := eDc[iu,2] + eDu2; eDc[iu,3] := eDc[iu,3] + eDu3; END; IF vVar[iv] THEN eDc[iv,0] := eDc[iv,0] + eDv0; eDc[iv,1] := eDc[iv,1] + eDv1; eDc[iv,2] := eDc[iv,2] + eDv2; eDc[iv,3] := eDc[iv,3] + eDv3; END; IF vVar[iw] THEN eDc[iw,0] := eDc[iw,0] + eDw0; eDc[iw,1] := eDc[iw,1] + eDw1; eDc[iw,2] := eDc[iw,2] + eDw2; eDc[iw,3] := eDc[iw,3] + eDw3; END; IF vVar[ix] THEN eDc[ix,0] := eDc[ix,0] + eDx0; eDc[ix,1] := eDc[ix,1] + eDx1; eDc[ix,2] := eDc[ix,2] + eDx2; eDc[ix,3] := eDc[ix,3] + eDx3; END END END Distribute_eDdet; BEGIN (* Clear determinant accumulators: *) FOR j := 0 TO NP-1 DO det[j] := 0.0d0 END; (* Enumerate polyhedrons and accumulate polyhedron determinants: *) FOR j := 0 TO NP-1 DO IF polyRelevant[j] THEN WITH t = region[j], a = Tors(t), t1 = Clock(Enext_1(t)), a1 = Tors(t1), un = OrgV(a).num, vn = OrgV(Enext(a)).num, wn = OrgV(Enext_1(a)).num, xn = OrgV(Enext_1(a1)).num DO Accum_det(un, vn, wn, xn, det[j]) END END END; (* Compute energy "e" from polyhedrons determinants, and the gradient "eDdet": *) e := 0.0d0; FOR p := 0 TO NP-1 DO IF polyRelevant[p] THEN Accum_e_from_det(det[p], e, eDdet[p]) ELSE eDdet[p] := 0.0d0 END END; (* Now distribute "eDdet" over "eDc": *) FOR i := 0 TO NV-1 DO eDc[i] := LR4.T{0.0d0, ..} END; IF grad THEN FOR j := 0 TO NP-1 DO IF polyRelevant[j] THEN WITH t = region[j], a = Tors(t), t1 = Clock(Enext_1(t)), a1 = Tors(t1), un = OrgV(a).num, vn = OrgV(Enext(a)).num, wn = OrgV(Enext_1(a)).num, xn = OrgV(Enext_1(a1)).num DO Distribute_eDdet(un, vn, wn, xn, eDdet[j]) END END END END END END END Eval; PROCEDURE Name(<* UNUSED *> erg: T): TEXT = BEGIN RETURN "Coherent()" END Name; BEGIN END CoherentEnergy. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Curvature1D.m3 MODULE Curvature1D; IMPORT Triangulation, LR4, Stat, Octf; FROM Triangulation IMPORT Topology, Edge, OrgV; FROM Energy IMPORT Coords, Gradient; FROM LR4 IMPORT Add, Neg; FROM Octf IMPORT Clock; CONST zero = LR4.T{0.0d0,0.0d0,0.0d0,0.0d0}; IniStackSize = 100000; Epsilon = 0.0000000001d0; VAR str,stc: Stat.T; (* statistical accumulators to the number of "root" elements and the number of "children" elements inside each "root" element. *) TYPE BOOLS = ARRAY OF BOOLEAN; StackE = REF ARRAY OF Edge; Number = RECORD nre : INTEGER; (* number of "root" edges. *) nce : CARDINAL; (* number of "children" edges inside each "root" edge.*) END; REVEAL T = Public BRANDED OBJECT K : LONGREAL; (* The energy normalization factor *) top : Topology; (* The topology *) vVar: REF BOOLS; (* TRUE if vertex is variable *) num : Number; (* Number of "root" and "children" edges*) ChilEdge: REF ARRAY OF StackE; (* The "children" edges *) OVERRIDES init := Init; defTop := DefTop; defVar := DefVar; eval := Eval; name := Name; END; PROCEDURE SaveE( VAR Stack : StackE; VAR top: CARDINAL; VAR edge: Edge; ) = (* Save the edge "edge" on the stack "Stack" *) BEGIN Stack[top] := edge; top := top +1 END SaveE; PROCEDURE Statistics(READONLY top: Topology) : Number = VAR num: Number; BEGIN FOR i:= 0 TO top.NE-1 DO WITH e = top.edge[i], er = FLOAT(e.root,REAL) DO Stat.Accum(str,er); IF er = 20.0 THEN Stat.Accum(stc,er) END; (* 0.0 *) END END; num.nre := FLOOR(str.maximum)+1; num.nce := FLOOR(stc.num); RETURN num; END Statistics; PROCEDURE CropChilEdges( READONLY top: Triangulation.Topology; READONLY num: Number; ): REF ARRAY OF StackE = (* Crop the "children" edges for each "root" edge. *) VAR topj : REF ARRAY OF CARDINAL; BEGIN (* initialize the "top" indexes for each of the "num.nre" stacks of edges. *) topj := NEW(REF ARRAY OF CARDINAL, num.nre); FOR k := 0 TO num.nre-1 DO topj[k] := 0 END; WITH t = NEW(REF ARRAY OF StackE, num.nre) DO FOR k := 0 TO num.nre-1 DO t[k] := NEW(REF ARRAY OF Edge, IniStackSize); END; FOR j := 0 TO top.NE-1 DO WITH e = top.edge[j], er = e.root DO IF er # -1 THEN SaveE(t[er],topj[er],e) END; END END; RETURN t; END; END CropChilEdges; PROCEDURE Init(erg: T) : T = BEGIN RETURN erg END Init; PROCEDURE DefTop(erg: T; READONLY top: Topology) = BEGIN erg.K := 1.0d0; erg.top := top; erg.vVar := NEW(REF BOOLS, top.NV); erg.num := Statistics(top); erg.ChilEdge := CropChilEdges(top,erg.num); (* Just in case the client forgets to call "defVar": *) FOR i := 0 TO top.NV-1 DO erg.vVar[i] := FALSE END; END DefTop; PROCEDURE DefVar(erg: T; READONLY variable: BOOLS) = BEGIN WITH NV = erg.top.NV, vVar = erg.vVar^ DO <* ASSERT NUMBER(variable) = NV *> vVar := variable; END END DefVar; PROCEDURE Eval( erg: T; READONLY c: Coords; VAR e: LONGREAL; grad: BOOLEAN; VAR eDc: Gradient; ) = BEGIN WITH NV = erg.top.NV, K = erg.K, vVar = erg.vVar^, ChilEdge = erg.ChilEdge, num = erg.num DO PROCEDURE AddTerm(READONLY iu,iv,iw: CARDINAL) = (* Adds one term of the curvature energy to "e" (and its derivative to "eDc, if "grad" is TRUE). The terms correspond to the edge "e1 = u v" and the edge "e2 = u w". v w \ / \ / e1 \ / e2 \/ u *) VAR eterm: LONGREAL; eDdu, eDdv, eDdw: LR4.T; BEGIN WITH u = c[iu], v = c[iv], w = c[iw] DO term(u,v,w, eterm, eDdu, eDdv, eDdw); e := e + eterm; IF grad THEN IF vVar[iu] THEN eDc[iu] := LR4.Add(eDc[iu],eDdu); END; IF vVar[iv] THEN eDc[iv] := LR4.Add(eDc[iv],eDdv); END; IF vVar[iw] THEN eDc[iw] := LR4.Add(eDc[iw],eDdw); END END END END AddTerm; PROCEDURE term( u,v,w: LR4.T; VAR eterm: LONGREAL; VAR dedu,dedv,dedw: LR4.T; ) = VAR dedDv,dedDw: LR4.T; BEGIN WITH Dv = LR4.Sub(v,u), (* V *) Dw = LR4.Sub(w,u) (* V *) DO Eangle(Dv,Dw, eterm, dedDv,dedDw); dedv := dedDv; (* V *) dedw := dedDw; (* V *) dedu := Neg(Add(dedDv,dedDw)); (* V *) END END term; PROCEDURE Eangle( READONLY R,S: LR4.T; VAR E: LONGREAL; VAR EDR,EDS: LR4.T; ) = (* Given two vectors "R" and "S" compute the "cos" of the angle between the vectors, the curvature term and the derivatives of energy respect to the two vectors: eeDR and eeDS. *) BEGIN WITH m = LR4.Norm(R) + Epsilon, n = LR4.Norm(S) + Epsilon, o = LR4.Dot(R,S), d = m*n, q = o/d DO IF d # 0.0d0 THEN E := K * (1.0d0 + q); IF grad THEN WITH eDq = 1.0d0 * K, eDo = eDq / d, eDd = - eDq * q / d, eDm = eDd * n, eDn = eDd * m DO EDR := LR4.Mix(eDo, S, eDm/m, R); EDS := LR4.Mix(eDo, R, eDn/n, S); END END END END END Eangle; BEGIN (* Initialize *) FOR i := 0 TO NV-1 DO eDc[i] := zero END; (* Compute energy "e", and the gradient "eDc": *) e := 0.0d0; FOR i := 0 TO num.nre-1 DO FOR j := 0 TO num.nce-1 DO FOR k := j+1 TO num.nce-1 DO IF ChilEdge[i,j].exists AND ChilEdge[i,k].exists THEN IF Adjacent(ChilEdge[i,j], ChilEdge[i,k]) THEN WITH u1 = OrgV(ChilEdge[i,j].pa).num, v1 = OrgV(Clock(ChilEdge[i,j].pa)).num, u2 = OrgV(ChilEdge[i,k].pa).num, v2 = OrgV(Clock(ChilEdge[i,k].pa)).num DO IF u1 = u2 THEN AddTerm(u1,v1,v2); ELSIF v1 = u2 THEN AddTerm(v1,u1,v2); ELSIF u1 = v2 THEN AddTerm(u1,v1,u2); ELSIF v1 = v2 THEN AddTerm(v1,u1,u2); END END END END END END END END END END Eval; PROCEDURE Adjacent(e1,e2: Edge) : BOOLEAN = BEGIN WITH u1 = OrgV(e1.pa).num, v1 = OrgV(Clock(e1.pa)).num, u2 = OrgV(e2.pa).num, v2 = OrgV(Clock(e2.pa)).num DO IF (u1 = u2) OR (u1 = v2) OR (v1 = v2) OR (v1 = u2) THEN RETURN TRUE ELSE RETURN FALSE END END END Adjacent; PROCEDURE Name(<* UNUSED *> erg: T): TEXT = BEGIN RETURN "Curv1D()" END Name; BEGIN END Curvature1D. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Curvature2D.m3 MODULE Curvature2D; IMPORT Triangulation, LR4, Octf; FROM Triangulation IMPORT Topology, OrgV, Pair; FROM Energy IMPORT Coords, Gradient; FROM LR4 IMPORT Add, Neg, Dot; FROM Octf IMPORT Fnext, Clock, Enext_1; CONST zero = LR4.T{0.0d0,0.0d0,0.0d0,0.0d0}; Epsilon = 1.0d-9; TYPE BOOLS = ARRAY OF BOOLEAN; REVEAL T = Public BRANDED OBJECT K : LONGREAL; (* The energy normalization factor *) top : Topology; (* The topology *) vVar: REF BOOLS; (* TRUE if vertex is variable *) OVERRIDES init := Init; defTop := DefTop; defVar := DefVar; eval := Eval; name := Name; END; PROCEDURE Init(erg: T) : T = BEGIN RETURN erg END Init; PROCEDURE DefTop(erg: T; READONLY top: Topology) = BEGIN erg.K := 1.0d0; erg.top := top; erg.vVar := NEW(REF BOOLS, top.NV); (* Just in case the client forgets to call "defVar": *) FOR i := 0 TO top.NV-1 DO erg.vVar[i] := FALSE END; END DefTop; PROCEDURE DefVar(erg: T; READONLY variable: BOOLS) = BEGIN WITH NV = erg.top.NV, vVar = erg.vVar^ DO <* ASSERT NUMBER(variable) = NV *> vVar := variable; END END DefVar; PROCEDURE EdgeBelongsToOriginalFace(a: Pair; READONLY top:Topology): BOOLEAN = (* TRUE if the edge component of "a" belongs to a face of the original map. *) VAR b: Pair := a; BEGIN IF top.edge[a.facetedge.edge.num].root # -1 THEN RETURN FALSE END; (* Check if any face incident to "a" belongs to a face of the original map. *) REPEAT IF top.face[b.facetedge.face.num].root # -1 THEN RETURN TRUE END; b := Fnext(b) UNTIL b = a; RETURN FALSE END EdgeBelongsToOriginalFace; PROCEDURE PiecesOfOriginalFace(a: Pair; READONLY top:Topology): ARRAY [0..1] OF Pair = (* Assumes that the edge component of "a" belongs to a face of the original map. Returns the two new faces incident to "a" that were part of that old face. *) VAR fg: ARRAY [0..1] OF Pair; BEGIN (* Look for the first face: *) WHILE top.face[a.facetedge.face.num].root = -1 DO a := Fnext(a) END; fg[0] := a; (* Look for second face. *) a := Fnext(a); WHILE top.face[a.facetedge.face.num].root = -1 DO a := Fnext(a) END; fg[1] := a; <* ASSERT fg[0] # fg[1] *> RETURN fg END PiecesOfOriginalFace; PROCEDURE Eval( erg: T; READONLY c: Coords; VAR e: LONGREAL; grad: BOOLEAN; VAR eDc: Gradient; ) = BEGIN WITH NV = erg.top.NV, K = erg.K, vVar = erg.vVar^, top = erg.top DO PROCEDURE AddTerm(READONLY iu,iv,iw,ix: CARDINAL) = (* Adds one term of the curvature energy to "e" (and its derivative to "eDc, if "grad" is TRUE). The terms correspond to the faces "f1 = u v w" and "f2 = u w x". See the follow picture: v /|\ / | \ / | \ / / | \ \ ------ w / | \ x ----- \ \ f1 | f2 / / \ | / \ | / \ | / \|/ u *) VAR eterm: LONGREAL; eDdu, eDdv, eDdw, eDdx: LR4.T; BEGIN WITH u = c[iu], v = c[iv], w = c[iw], x = c[ix] DO term(u,v,w,x, eterm, eDdu, eDdv, eDdw, eDdx); e := e + eterm; IF grad THEN IF vVar[iu] THEN eDc[iu] := LR4.Add(eDc[iu],eDdu); END; IF vVar[iv] THEN eDc[iv] := LR4.Add(eDc[iv],eDdv); END; IF vVar[iw] THEN eDc[iw] := LR4.Add(eDc[iw],eDdw); END; IF vVar[ix] THEN eDc[ix] := LR4.Add(eDc[ix],eDdx); END END END END AddTerm; PROCEDURE term(u,v,w,x: LR4.T; VAR eterm: LONGREAL; VAR dedu,dedv,dedw,dedx: LR4.T; ) = VAR dedDv,dedDw,dedDx: LR4.T; BEGIN WITH Dv = LR4.Sub(v,u), (* V *) Dw = LR4.Sub(w,u), (* V *) Dx = LR4.Sub(x,u) DO EangleAux(Dv,Dw, Dx, eterm, dedDv,dedDw,dedDx); dedv := dedDv; (* V *) dedw := dedDw; (* V *) dedx := dedDx; (* V *) dedu := Neg(Add(Add(dedDv,dedDw),dedDx)); END END term; PROCEDURE EangleAux(f,a,b: LR4.T; VAR eterm: LONGREAL; VAR dedf,deda,dedb: LR4.T; ) = (* compute the derivative of the orthogonal vectors "f" and "g" where "f= s - Proj(s,r)" and "g = r". *) VAR dedr,deds: LR4.T; BEGIN WITH m = LR4.Dot(f,f)+Epsilon, (* S *) u = LR4.Dot(f,a), (* S *) v = LR4.Dot(f,b), (* S *) U = u/m, (* S *) V = v/m, (* S *) Uf = LR4.Scale(U,f), (* V *) Vf = LR4.Scale(V,f), (* V *) R = LR4.Sub(a,Uf), (* V *) S = LR4.Sub(b,Vf) (* V *) DO Eangle(R,S,eterm,dedr,deds); WITH dedV = - Dot(deds, f), (* S *) dedU = - Dot(dedr, f), (* S *) dedu = dedU/m, (* S *) dedv = dedV/m, (* S *) dedm = (-1.0d0/m) * (dedU*U + dedV*V), (* S *) dedm2 = LR4.Scale(2.0d0,f), (* S *) dedm2f = LR4.Scale(dedm, dedm2), (* V *) dedua = LR4.Scale(dedu, a), (* V *) dedvb = LR4.Scale(dedv, b), (* V *) dedrU = LR4.Neg(LR4.Scale(U, dedr)), (* V *) dedsV = LR4.Neg(LR4.Scale(V, deds)), (* V *) t1 = LR4.Add(dedm2f,dedua), (* V *) t2 = LR4.Add(t1, dedvb), (* V *) t3 = LR4.Add(t2, dedrU), (* V *) t4 = LR4.Add(t3, dedsV), (* V *) deduf = LR4.Scale(dedu, f), (* V *) dedvf = LR4.Scale(dedv, f), (* V *) c1 = LR4.Add(deduf, dedr), (* V *) d1 = LR4.Add(dedvf, deds) (* V *) DO dedf := t4; deda := c1; dedb := d1; END END END EangleAux; PROCEDURE Eangle( READONLY R,S: LR4.T; VAR E: LONGREAL; VAR EDR,EDS: LR4.T; ) = (* Given two vectors "R" and "S" compute the "cos" of the angle between the vectors, the curvature term and the derivatives of energy respect to the two vectors: eeDR and eeDS. *) BEGIN WITH m = LR4.Norm(R) + Epsilon, n = LR4.Norm(S) + Epsilon, o = LR4.Dot(R,S), d = m*n, q = o/d DO IF d # 0.0d0 THEN E := K * (1.0d0 + q); IF grad THEN WITH eDq = 1.0d0 * K, eDo = eDq / d, eDd = - eDq * q / d, eDm = eDd * n, eDn = eDd * m DO EDR := LR4.Mix(eDo, S, eDm/m, R); EDS := LR4.Mix(eDo, R, eDn/n, S); END END END END END Eangle; BEGIN (* Initialize *) FOR i := 0 TO NV-1 DO eDc[i] := zero END; (* Compute energy "e", and the gradient "eDr": *) e := 0.0d0; FOR i := 0 TO top.NE-1 DO WITH a = top.edge[i].pa DO IF EdgeBelongsToOriginalFace(a,top) THEN WITH fg = PiecesOfOriginalFace(a,top), f = fg[0], g = fg[1], u = OrgV(f).num, v = OrgV(Clock(f)).num, w1 = OrgV(Enext_1(f)).num, w2 = OrgV(Enext_1(g)).num DO AddTerm(u, v, w1, w2) END END END END END END END Eval; PROCEDURE Name(<* UNUSED *> erg: T): TEXT = BEGIN RETURN "Curv2D()" END Name; BEGIN END Curvature2D. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Curvature3D.m3 MODULE Curvature3D; (* Last modification on 18-11-2000 by lozada. *) IMPORT Triangulation, LR4; FROM Triangulation IMPORT Topology, Ppos, Pneg, TetraNegPosVertices; FROM Energy IMPORT Coords, Gradient; FROM LR4 IMPORT Add, Scale, Neg, Dot, Sub; CONST zero = LR4.T{0.0d0,0.0d0,0.0d0,0.0d0}; Epsilon = 0.0000000001d0; TYPE BOOLS = ARRAY OF BOOLEAN; REVEAL T = Public BRANDED OBJECT K: LONGREAL; (* The energy normalization factor *) top: Topology; (* The topology *) vVar: REF BOOLS; (* TRUE if vertex is variable *) faceRelevant: REF BOOLS; (* TRUE if face is relevant *) OVERRIDES init := Init; defTop := DefTop; defVar := DefVar; eval := Eval; name := Name; END; PROCEDURE Init(erg: T) : T = BEGIN RETURN erg END Init; PROCEDURE DefTop(erg: T; READONLY top: Topology) = BEGIN erg.K := 1.0d0; erg.top := top; erg.vVar := NEW(REF BOOLS, top.NV); erg.faceRelevant := NEW(REF BOOLS, top.NF); (* Just in case the client forgets to call "defVar": *) FOR i := 0 TO top.NV-1 DO erg.vVar[i] := FALSE END; FOR i := 0 TO top.NF-1 DO erg.faceRelevant[i] := FALSE END; END DefTop; PROCEDURE DefVar(erg: T; READONLY variable: BOOLS) = BEGIN (* Decide which face are relevant to the curvature energy. A face is relevant iff has exactly two polyhedron incident to it. *) WITH NV = erg.top.NV, NF = erg.top.NF, vVar = erg.vVar^, face = erg.top.face^, faceRelevant = erg.faceRelevant^ DO <* ASSERT NUMBER(variable) = NV *> vVar := variable; (* Find the relevant faces: *) FOR i := 0 TO NF-1 DO faceRelevant[i] := FALSE END; FOR i := 0 TO NF-1 DO WITH f = face[i], a = f.pa, p1 = Pneg(a), p2 = Ppos(a) DO IF (p1 # NIL AND p2 # NIL) THEN faceRelevant[i] := TRUE; END END END END END DefVar; PROCEDURE Eval( erg: T; READONLY c: Coords; VAR e: LONGREAL; grad: BOOLEAN; VAR eDc: Gradient; ) = BEGIN WITH NV = erg.top.NV, NF = erg.top.NF, face = erg.top.face^, faceRelevant = erg.faceRelevant^, K = erg.K, vVar = erg.vVar^ DO PROCEDURE AddTerm(READONLY iu,iv,iw,ix,iy: CARDINAL) = (* Adds one term of the curvature energy to "e" (and its derivative to "eDc, if "grad" is TRUE). The terms correspond to the face "f = u v w" shared by the tetrahedra "u v w x" (Pneg) and "u v w y" (Ppos). _ _ |\ w w /| \ /|\ /|\ / \ / | \ / | \ / / | \ / | \ / | \ / | \ x /____|____\v v/____|____\ y \ | f / \ f | / \ | / \ | / \ | / \ | / \ | / \ | / \|/ \|/ u u Pneg Ppos *) VAR eterm: LONGREAL; eDdu, eDdv, eDdw, eDdx, eDdy: LR4.T; BEGIN WITH u = c[iu], v = c[iv], w = c[iw], x = c[ix], y = c[iy] DO term(u,v,w,x,y, eterm, eDdu, eDdv, eDdw, eDdx, eDdy); e := e + eterm; IF grad THEN IF vVar[iu] THEN eDc[iu] := LR4.Add(eDc[iu],eDdu); END; IF vVar[iv] THEN eDc[iv] := LR4.Add(eDc[iv],eDdv); END; IF vVar[iw] THEN eDc[iw] := LR4.Add(eDc[iw],eDdw); END; IF vVar[ix] THEN eDc[ix] := LR4.Add(eDc[ix],eDdx); END; IF vVar[iy] THEN eDc[iy] := LR4.Add(eDc[iy],eDdy); END END END END AddTerm; PROCEDURE term(u,v,w,x,y: LR4.T; VAR eterm: LONGREAL; VAR dedu,dedv,dedw,dedx,dedy: LR4.T; ) = VAR dedDv,dedDw,dedDx,dedDy: LR4.T; BEGIN WITH Dv = LR4.Sub(v,u), (* V *) Dw = LR4.Sub(w,u), (* V *) Dx = LR4.Sub(x,u), (* V *) Dy = LR4.Sub(y,u) (* V *) DO Eangle(Dv,Dw,Dx,Dy, eterm, dedDv,dedDw,dedDx,dedDy); dedv := dedDv; (* V *) dedw := dedDw; (* V *) dedx := dedDx; (* V *) dedy := dedDy; (* V *) dedu := Neg(Add(Add(Add(dedDv,dedDw),dedDx),dedDy)); END END term; PROCEDURE Eangle(r,s,a,b: LR4.T; VAR eterm: LONGREAL; VAR dedr,deds,deda,dedb: LR4.T; ) = (* compute the derivative of the orthogonal vectors "f" and "g" where "f= s - Proj(s,r)" and "g = r". *) VAR dedf,dedg: LR4.T; BEGIN WITH m = Dot(r,r)+Epsilon, (* S *) n = Dot(r,s), (* S *) m2 = m * m, (* S *) q = n/m, (* S *) qr = Scale(q,r), (* V *) f = Sub(s,qr), (* V *) g = r (* V *) (* Now, "f" and "g" are orthogonal *) DO EangleAux(f,g,a,b,eterm,dedf,dedg,deda,dedb); WITH dedq = -LR4.Dot(dedf,r), (* S *) dedn = dedq/m, (* S *) dedm = -dedq * (n/m2), (* S *) r2 = LR4.Scale(2.0d0,r), (* V *) v1 = LR4.Scale(dedm, r2), (* V *) v2 = LR4.Scale(dedn, s), (* V *) v3 = LR4.Scale(-q , dedf), (* V *) v4 = dedg, (* V *) v12 = LR4.Add(v1,v2), (* V *) v123 = LR4.Add(v12,v3), (* V *) v1234= LR4.Add(v123,v4), (* V *) dednr = LR4.Scale(dedn, r) (* V *) DO dedr := v1234; deds := Add(dednr, dedf); END END END Eangle; PROCEDURE EangleAux( f,g,a,b: LR4.T; VAR eterm: LONGREAL; VAR dedf,dedg,deda,dedb: LR4.T; ) = (* compute the derivative of the orthogonal vectors "f" and "g" where "f= s - Proj(s,r)" and "g = r". *) VAR dedr,deds: LR4.T; BEGIN WITH m = LR4.Dot(f,f) + Epsilon, (* S *) n = LR4.Dot(g,g) + Epsilon, (* S *) u = LR4.Dot(f,a), (* S *) v = LR4.Dot(f,b), (* S *) x = LR4.Dot(g,a), (* S *) y = LR4.Dot(g,b), (* S *) U = u/m, (* S *) V = v/m, (* S *) X = x/n, (* S *) Y = y/n, (* S *) Uf = LR4.Scale(U,f), (* V *) Xg = LR4.Scale(X,g), (* V *) Vf = LR4.Scale(V,f), (* V *) Yg = LR4.Scale(Y,g), (* V *) UfXg = LR4.Neg(LR4.Add(Uf,Xg)), (* V *) VfYg = LR4.Neg(LR4.Add(Vf,Yg)), (* V *) R = LR4.Add(a,UfXg), (* V *) S = LR4.Add(b,VfYg) (* V *) DO EangleVec(R,S,eterm,dedr,deds); WITH dedY = - Dot(deds, g), (* S *) dedX = - Dot(dedr, g), (* S *) dedV = - Dot(deds, f), (* S *) dedU = - Dot(dedr, f), (* S *) dedx = dedX/n, (* S *) dedy = dedY/n, (* S *) dedu = dedU/m, (* S *) dedv = dedV/m, (* S *) dedm = (-1.0d0/m) * (dedU*U + dedV*V), (* S *) dedn = (-1.0d0/n) * (dedX*X + dedY*Y), (* S *) dedm2 = LR4.Scale(2.0d0,f), (* S *) dedm2f = LR4.Scale(dedm, dedm2), (* V *) dedua = LR4.Scale(dedu, a), (* V *) dedvb = LR4.Scale(dedv, b), (* V *) dedrU = LR4.Neg(LR4.Scale(U, dedr)), (* V *) dedsV = LR4.Neg(LR4.Scale(V, deds)), (* V *) t1 = LR4.Add(dedm2f,dedua), (* V *) t2 = LR4.Add(t1, dedvb), (* V *) t3 = LR4.Add(t2, dedrU), (* V *) t4 = LR4.Add(t3, dedsV), (* V *) g2 = LR4.Scale(2.0d0,g), (* S *) dedn2g = LR4.Scale(dedn, g2), (* V *) dedxa = LR4.Scale(dedx, a), (* V *) dedyb = LR4.Scale(dedy, b), (* V *) dedrX = LR4.Neg(LR4.Scale(X, dedr)), (* V *) dedsY = LR4.Neg(LR4.Scale(Y, deds)), (* V *) f1 = LR4.Add(dedn2g,dedxa), (* V *) f2 = LR4.Add(f1, dedyb), (* V *) f3 = LR4.Add(f2, dedrX), (* V *) f4 = LR4.Add(f3, dedsY), (* V *) deduf = LR4.Scale(dedu, f), (* V *) dedxg = LR4.Scale(dedx, g), (* V *) dedvf = LR4.Scale(dedv, f), (* V *) dedyg = LR4.Scale(dedy, g), (* V *) c1 = LR4.Add(deduf, dedxg), (* V *) c2 = LR4.Add(c1, dedr), (* V *) d1 = LR4.Add(dedvf, dedyg), (* V *) d2 = LR4.Add(d1, deds) (* V *) DO dedf := t4; dedg := f4; deda := c2; dedb := d2; END END END EangleAux; PROCEDURE EangleVec( READONLY R,S: LR4.T; VAR E: LONGREAL; VAR EDR,EDS: LR4.T; ) = (* Given two vectors "R" and "S" compute the "cos" of the angle between the vectors, the curvature term and the derivatives of energy respect to the two vectors: eeDR and eeDS. *) BEGIN WITH m = LR4.Norm(R) + Epsilon, n = LR4.Norm(S) + Epsilon, o = LR4.Dot(R,S), d = m*n, q = o/d, c = (1.0d0 + Epsilon) - q, c2 = c * c DO IF d # 0.0d0 THEN E := K * (1.0d0/c - 0.5d0); IF grad THEN WITH eDq = 1.0d0/c2 * K, eDo = eDq / d, eDd = - eDq * q / d, eDm = eDd * n, eDn = eDd * m DO EDR := LR4.Mix(eDo, S, eDm/m, R); EDS := LR4.Mix(eDo, R, eDn/n, S); END END END END END EangleVec; BEGIN (* Initialize *) FOR i := 0 TO NV-1 DO eDc[i] := zero END; (* Compute energy "e", and the gradient "eDr": *) e := 0.0d0; FOR i := 0 TO NF-1 DO IF faceRelevant[i] THEN WITH f = face[i], a = f.pa, t = TetraNegPosVertices(a), un = t[0].num, vn = t[1].num, wn = t[2].num, xn = t[3].num, yn = t[4].num DO <* ASSERT xn # yn *> AddTerm(un,vn,wn,xn,yn) END END END END END END Eval; PROCEDURE Name(<* UNUSED *> erg: T): TEXT = BEGIN RETURN "Curv3D()" END Name; BEGIN END Curvature3D. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/ElasticityEnergy.m3 MODULE ElasticityEnergy; IMPORT Triangulation, LR4, LR3, LR3x3, Fmt, Math; FROM Octf IMPORT Tors, Clock, Enext_1, Fnext_1, Enext; FROM Triangulation IMPORT OrgV, Topology; FROM Energy IMPORT Coords, Gradient; CONST Pi = Math.Pi; A = LR3x3.T{ LR3.T{0.0d0, 1.0d0, 1.0d0}, LR3.T{1.0d0, 0.0d0, 1.0d0}, LR3.T{1.0d0, 1.0d0, 0.0d0} }; (* Matrix that maps the reference configuration to the repose (or relaxed) configuration (i.e. has zero elastic energy). The volume is 0.333333 . The reference configuration is a tetrahedron with vertices: r1=(0,0,0), r2=(1,0,0), r3=(0,1,0) and r4=(0,0,1). The repose configuration is a regular tetrahedron with vertices: q1=(0,0,0), q2=(0,1,1), q3=(1,1,0) and q4=(1,0,1). The Elasticity energy forces each tetrahedron has volume equal to 0.3333. *) TYPE BOOLS = ARRAY OF BOOLEAN; LONGS = ARRAY OF LONGREAL; LR4x3 = ARRAY [0..3] OF LR3.T; LR3x4 = ARRAY [0..2] OF LR4.T; REVEAL T = Public BRANDED OBJECT K: LONGREAL; (* The energy normalization factor *) top: Topology; (* The topology *) vVar: REF BOOLS; (* TRUE if vertex is variable *) polyRelevant: REF BOOLS; (* TRUE if polyhedron is relevant *) ep: REF LONGS; (* elasticity energy of each tetrahedron *) eDep: REF LONGS; (* (Work) derivative of energy rel. ep *) volume: LONGREAL; OVERRIDES init := Init; defTop := DefTop; defVar := DefVar; eval := Eval; name := Name; END; PROCEDURE Init(erg: T): T = BEGIN RETURN erg END Init; PROCEDURE DefTop(erg: T; READONLY top: Topology) = BEGIN erg.K := 1.0d0; erg.top := top; erg.volume := (4.0d0/3.0d0)* FLOAT(Pi,LONGREAL)/FLOAT(top.NP,LONGREAL); erg.vVar := NEW(REF BOOLS, top.NV); erg.polyRelevant := NEW(REF BOOLS, top.NP); erg.ep := NEW(REF LONGS, top.NP); erg.eDep := NEW(REF LONGS, top.NP); (* Allocate determinant tables: *) (* Just in case the client forgets to call "defVar": *) FOR i := 0 TO top.NV-1 DO erg.vVar[i] := FALSE END; FOR i := 0 TO top.NP-1 DO erg.polyRelevant[i] := FALSE END; END DefTop; PROCEDURE Transpose_3x4(READONLY m: LR3x4): LR4x3 = (* Return the transpose of a matrix 3x4. *) VAR t : LR4x3; BEGIN t[0] := LR3.T{m[0,0], m[1,0], m[2,0]}; t[1] := LR3.T{m[0,1], m[1,1], m[2,1]}; t[2] := LR3.T{m[0,2], m[1,2], m[2,2]}; t[3] := LR3.T{m[0,3], m[1,3], m[2,3]}; RETURN t; END Transpose_3x4; PROCEDURE Transpose_4x3(READONLY m: LR4x3): LR3x4 = (* return the transpose of a matrix 4x3. *) VAR t : LR3x4; BEGIN t[0] := LR4.T{m[0,0], m[1,0], m[2,0], m[3,0]}; t[1] := LR4.T{m[0,1], m[1,1], m[2,1], m[3,1]}; t[2] := LR4.T{m[0,2], m[1,2], m[2,2], m[3,2]}; RETURN t; END Transpose_4x3; PROCEDURE Mul_4x3_3x3(READONLY a: LR4x3; READONLY b: LR3x3.T) : LR4x3 = (* Return the product of the matrix "a" 4x3 and matrix "b" 3x3. *) VAR c : LR4x3; BEGIN WITH a00 = a[0,0], a01 = a[0,1], a02 = a[0,2], a10 = a[1,0], a11 = a[1,1], a12 = a[1,2], a20 = a[2,0], a21 = a[2,1], a22 = a[2,2], a30 = a[3,0], a31 = a[3,1], a32 = a[3,2], b00 = b[0,0], b01 = b[0,1], b02 = b[0,2], b10 = b[1,0], b11 = b[1,1], b12 = b[1,2], b20 = b[2,0], b21 = b[2,1], b22 = b[2,2], c00 = a00 * b00 + a01 * b10 + a02 * b20, c01 = a00 * b01 + a01 * b11 + a02 * b21, c02 = a00 * b02 + a01 * b12 + a02 * b22, c10 = a10 * b00 + a11 * b10 + a12 * b20, c11 = a10 * b01 + a11 * b11 + a12 * b21, c12 = a10 * b02 + a11 * b12 + a12 * b22, c20 = a20 * b00 + a21 * b10 + a22 * b20, c21 = a20 * b01 + a21 * b11 + a22 * b21, c22 = a20 * b02 + a21 * b12 + a22 * b22, c30 = a30 * b00 + a31 * b10 + a32 * b20, c31 = a30 * b01 + a31 * b11 + a32 * b21, c32 = a30 * b02 + a31 * b12 + a32 * b22, c0 = LR3.T{c00,c01,c02}, c1 = LR3.T{c10,c11,c12}, c2 = LR3.T{c20,c21,c22}, c3 = LR3.T{c30,c31,c32} DO c[0] := c0; c[1] := c1; c[2] := c2; c[3] := c3; RETURN c; END END Mul_4x3_3x3; PROCEDURE Mul_3x4_4x3(READONLY a: LR3x4; READONLY b: LR4x3) : LR3x3.T = (* Return the product of the matrix "a" 3x4 and matrix "b" 4x3. *) BEGIN WITH a00 = a[0,0], a01 = a[0,1], a02 = a[0,2], a03 = a[0,3], a10 = a[1,0], a11 = a[1,1], a12 = a[1,2], a13 = a[1,3], a20 = a[2,0], a21 = a[2,1], a22 = a[2,2], a23 = a[2,3], b00 = b[0,0], b01 = b[0,1], b02 = b[0,2], b10 = b[1,0], b11 = b[1,1], b12 = b[1,2], b20 = b[2,0], b21 = b[2,1], b22 = b[2,2], b30 = b[3,0], b31 = b[3,1], b32 = b[3,2], c00 = a00 * b00 + a01 * b10 + a02 * b20 + a03 * b30, c01 = a00 * b01 + a01 * b11 + a02 * b21 + a03 * b31, c02 = a00 * b02 + a01 * b12 + a02 * b22 + a03 * b32, c10 = a10 * b00 + a11 * b10 + a12 * b20 + a13 * b30, c11 = a10 * b01 + a11 * b11 + a12 * b21 + a13 * b31, c12 = a10 * b02 + a11 * b12 + a12 * b22 + a13 * b32, c20 = a20 * b00 + a21 * b10 + a22 * b20 + a23 * b30, c21 = a20 * b01 + a21 * b11 + a22 * b21 + a23 * b31, c22 = a20 * b02 + a21 * b12 + a22 * b22 + a23 * b32, c0 = LR3.T{c00,c01,c02}, c1 = LR3.T{c10,c11,c12}, c2 = LR3.T{c20,c21,c22} DO RETURN LR3x3.T{c0,c1,c2}; END END Mul_3x4_4x3; PROCEDURE DefVar(erg: T; READONLY variable: BOOLS) = BEGIN (* Decide which polyhedrons are relevant to "Orientation" energy. A polyhedron is relevant iff it exists,has at least one variable corner. *) WITH NV = erg.top.NV, NP = erg.top.NP, vVar = erg.vVar^, region = erg.top.region^, polyRelevant = erg.polyRelevant^ DO <* ASSERT NUMBER(variable) = NV *> vVar := variable; (* Find the relevant polyhedrons: *) FOR i := 0 TO NP-1 DO polyRelevant[i] := FALSE; END; FOR i := 0 TO NP-1 DO WITH r = region[i], a = Tors(r), r1 = Clock(Enext_1(r)), a1 = Tors(r1), u = OrgV(a), v = OrgV(Enext(a)), w = OrgV(Enext_1(a)), x = OrgV(Enext_1(a1)), vvar = vVar[u.num] OR vVar[v.num] OR vVar[w.num] OR vVar[x.num], f1 = a.facetedge.face, f2 = Fnext_1(a).facetedge.face, f3 = Fnext_1(Enext(a)).facetedge.face, f4 = Fnext_1(Enext_1(a)).facetedge.face DO <* ASSERT (f1 # f2) AND (f2 # f3) AND (f3 # f4) *> IF vvar THEN polyRelevant[i] := TRUE; END END END END END DefVar; PROCEDURE Eval( erg: T; READONLY c: Coords; VAR e: LONGREAL; grad: BOOLEAN; VAR eDc: Gradient; ) = BEGIN WITH NV = erg.top.NV, NP = erg.top.NP, polyRelevant = erg.polyRelevant^, region = erg.top.region^, vVar = erg.vVar, K = erg.K, ep = erg.ep, eDep = erg.eDep, top = erg.top, alpha = erg.alpha, beta = erg.beta, volA = (1.0d0/6.0d0) * LR3x3.Det(A) DO PROCEDURE ShapeMatrix(READONLY i: CARDINAL): LR4x3 = VAR b: LR3x4; (* _ _ | v0-u0 w0-u0 x0-u0 | B = | v1-u1 w1-u1 x1-u1 | | v2-u2 w2-u2 x2-u2 | | v3-u3 w3-u3 x3-u3 | - - *) BEGIN WITH r = top.region[i], a = Tors(r), tv = Triangulation.TetraNegVertices(a), u = c[tv[0].num], v = c[tv[1].num], w = c[tv[2].num], x = c[tv[3].num] DO b[0] := LR4.Sub(v,u); b[1] := LR4.Sub(w,u); b[2] := LR4.Sub(x,u); RETURN Transpose_3x4(b); END END ShapeMatrix; PROCEDURE ElasticEnergy(i: CARDINAL): LONGREAL = (* This procedure compute the elastic energy of a tetrahedral element. Where Delta, Gamma and Sigma are the "invariants of rotation" inside of a tetrahedron, compute although the strain tensor ("C" matrix). The metric tensor is the "T" matrix, where T = Mul(Transpose(C), C) (the matrix T is simetric). From the metric tensor, we conpute the elastic energy density: "term1+term2". Its integral over the tetrahedron T is merely the product of the elastic energy density by its volume VT in its relaxed configuration (i.e. when the elasstic energy is zero). See the section 4.2 "Calculo das forcas de elasticidade" in the Msc. Thesis "Animacao Dinamica de Corpos Elasticos" by R.L.W.L *) BEGIN WITH B = ShapeMatrix(i), C = Mul_4x3_3x3(B, LR3x3.Inv(A)), (* C = B * A_1 *) T = Mul_3x4_4x3(Transpose_4x3(C), C), T11 = T[1,1]*T[2,2] - T[1,2]*T[1,2], T12 = T[0,1]*T[2,2] - T[1,2]*T[0,2], T13 = T[0,1]*T[1,2] - T[1,1]*T[0,2], T22 = T[0,0]*T[2,2] - T[0,2]*T[0,2], T33 = T[0,0]*T[1,1] - T[0,1]*T[0,1], Delta = T[0,0]*T11 - T[0,1]*T12 + T[0,2]*T13, Sigma = T11 + T22 + T33, Gamma = T[0,0] + T[1,1] + T[2,2], term1 = alpha/32.0D0*(Delta*Delta+1.0D0/(Delta*Delta)-2.0D0), term2 = beta/6.0D0*(Gamma*Gamma - 3.0D0*Sigma), P = volA*(term1 + term2) DO RETURN P END END ElasticEnergy; PROCEDURE Accum_ep(i: CARDINAL; VAR epo: LONGREAL) = (* Compute the potential energy of the tetrahedron "i" in R^{3}. *) BEGIN epo := epo + ElasticEnergy(i); END Accum_ep; PROCEDURE Accum_e_from_ep(ep: LONGREAL; VAR e: LONGREAL; VAR eDep: LONGREAL) = (* Adds to "e" the energy term corresponding to a polyhedron with determinant "det". Also, if "grad" is true, stores in "eDdet" the derivative of that term. *) BEGIN e := e + K * ep; IF grad THEN eDep := K; ELSE eDep := 0.0d0; END END Accum_e_from_ep; PROCEDURE Distribute_eDep(i: CARDINAL; eDep: LONGREAL) = (* Accumulates in "eDc" the gradient of "e" relative to the corners of the tetrahedron "i", given the derivative "eDep" of "e" relative to the tetrahedron's elastic energy "epv". *) BEGIN WITH B = ShapeMatrix(i), C = Mul_4x3_3x3(B, LR3x3.Inv(A)), T = Mul_3x4_4x3(Transpose_4x3(C), C), T11 = T[1,1]*T[2,2] - T[1,2]*T[1,2], T12 = T[0,1]*T[2,2] - T[1,2]*T[0,2], T13 = T[0,1]*T[1,2] - T[1,1]*T[0,2], T22 = T[0,0]*T[2,2] - T[0,2]*T[0,2], T33 = T[0,0]*T[1,1] - T[0,1]*T[0,1], Delta = T[0,0]*T11 - T[0,1]*T12 + T[0,2]*T13, Sigma = T11 + T22 + T33, Del_3 = 1.0d0/(Delta*Delta*Delta), t = region[i], a = Tors(t), t1 = Clock(Enext_1(t)), a1 = Tors(t1), iu = OrgV(a).num, iv = OrgV(Enext(a)).num, iw = OrgV(Enext_1(a)).num, ix = OrgV(Enext_1(a1)).num, t00 = T[0,0], t01 = T[0,1], t02 = T[0,2], t11 = T[1,1], t12 = T[1,2], t22 = T[2,2], c00 = C[0,0], c01 = C[0,1], c02 = C[0,2], c10 = C[1,0], c11 = C[1,1], c12 = C[1,2], c20 = C[2,0], c21 = C[2,1], c22 = C[2,2], c30 = C[3,0], c31 = C[3,1], c32 = C[3,2], b00Du0 = -1.0d0, b01Du0 = -1.0d0, b02Du0 = -1.0d0, b10Du0 = 0.0d0, b11Du0 = 0.0d0, b12Du0 = 0.0d0, b20Du0 = 0.0d0, b21Du0 = 0.0d0, b22Du0 = 0.0d0, b30Du0 = 0.0d0, b31Du0 = 0.0d0, b32Du0 = 0.0d0, b00Du1 = 0.0d0, b01Du1 = 0.0d0, b02Du1 = 0.0d0, b10Du1 = -1.0d0, b11Du1 = -1.0d0, b12Du1 = -1.0d0, b20Du1 = 0.0d0, b21Du1 = 0.0d0, b22Du1 = 0.0d0, b30Du1 = 0.0d0, b31Du1 = 0.0d0, b32Du1 = 0.0d0, b00Du2 = 0.0d0, b01Du2 = 0.0d0, b02Du2 = 0.0d0, b10Du2 = 0.0d0, b11Du2 = 0.0d0, b12Du2 = 0.0d0, b20Du2 = -1.0d0, b21Du2 = -1.0d0, b22Du2 = -1.0d0, b30Du2 = 0.0d0, b31Du2 = 0.0d0, b32Du2 = 0.0d0, b00Du3 = 0.0d0, b01Du3 = 0.0d0, b02Du3 = 0.0d0, b10Du3 = 0.0d0, b11Du3 = 0.0d0, b12Du3 = 0.0d0, b20Du3 = 0.0d0, b21Du3 = 0.0d0, b22Du3 = 0.0d0, b30Du3 = -1.0d0, b31Du3 = -1.0d0, b32Du3 = -1.0d0, b00Dv0 = 1.0d0, b01Dv0 = 0.0d0, b02Dv0 = 0.0d0, b10Dv0 = 0.0d0, b11Dv0 = 0.0d0, b12Dv0 = 0.0d0, b20Dv0 = 0.0d0, b21Dv0 = 0.0d0, b22Dv0 = 0.0d0, b30Dv0 = 0.0d0, b31Dv0 = 0.0d0, b32Dv0 = 0.0d0, b00Dv1 = 0.0d0, b01Dv1 = 0.0d0, b02Dv1 = 0.0d0, b10Dv1 = 1.0d0, b11Dv1 = 0.0d0, b12Dv1 = 0.0d0, b20Dv1 = 0.0d0, b21Dv1 = 0.0d0, b22Dv1 = 0.0d0, b30Dv1 = 0.0d0, b31Dv1 = 0.0d0, b32Dv1 = 0.0d0, b00Dv2 = 0.0d0, b01Dv2 = 0.0d0, b02Dv2 = 0.0d0, b10Dv2 = 0.0d0, b11Dv2 = 0.0d0, b12Dv2 = 0.0d0, b20Dv2 = 1.0d0, b21Dv2 = 0.0d0, b22Dv2 = 0.0d0, b30Dv2 = 0.0d0, b31Dv2 = 0.0d0, b32Dv2 = 0.0d0, b00Dv3 = 0.0d0, b01Dv3 = 0.0d0, b02Dv3 = 0.0d0, b10Dv3 = 0.0d0, b11Dv3 = 0.0d0, b12Dv3 = 0.0d0, b20Dv3 = 0.0d0, b21Dv3 = 0.0d0, b22Dv3 = 0.0d0, b30Dv3 = 1.0d0, b31Dv3 = 0.0d0, b32Dv3 = 0.0d0, b00Dw0 = 0.0d0, b01Dw0 = 1.0d0, b02Dw0 = 0.0d0, b10Dw0 = 0.0d0, b11Dw0 = 0.0d0, b12Dw0 = 0.0d0, b20Dw0 = 0.0d0, b21Dw0 = 0.0d0, b22Dw0 = 0.0d0, b30Dw0 = 0.0d0, b31Dw0 = 0.0d0, b32Dw0 = 0.0d0, b00Dw1 = 0.0d0, b01Dw1 = 0.0d0, b02Dw1 = 0.0d0, b10Dw1 = 0.0d0, b11Dw1 = 1.0d0, b12Dw1 = 0.0d0, b20Dw1 = 0.0d0, b21Dw1 = 0.0d0, b22Dw1 = 0.0d0, b30Dw1 = 0.0d0, b31Dw1 = 0.0d0, b32Dw1 = 0.0d0, b00Dw2 = 0.0d0, b01Dw2 = 0.0d0, b02Dw2 = 0.0d0, b10Dw2 = 0.0d0, b11Dw2 = 0.0d0, b12Dw2 = 0.0d0, b20Dw2 = 0.0d0, b21Dw2 = 1.0d0, b22Dw2 = 0.0d0, b30Dw2 = 0.0d0, b31Dw2 = 0.0d0, b32Dw2 = 0.0d0, b00Dw3 = 0.0d0, b01Dw3 = 0.0d0, b02Dw3 = 0.0d0, b10Dw3 = 0.0d0, b11Dw3 = 0.0d0, b12Dw3 = 0.0d0, b20Dw3 = 0.0d0, b21Dw3 = 0.0d0, b22Dw3 = 0.0d0, b30Dw3 = 0.0d0, b31Dw3 = 1.0d0, b32Dw3 = 0.0d0, b00Dx0 = 0.0d0, b01Dx0 = 0.0d0, b02Dx0 = 1.0d0, b10Dx0 = 0.0d0, b11Dx0 = 0.0d0, b12Dx0 = 0.0d0, b20Dx0 = 0.0d0, b21Dx0 = 0.0d0, b22Dx0 = 0.0d0, b30Dx0 = 0.0d0, b31Dx0 = 0.0d0, b32Dx0 = 0.0d0, b00Dx1 = 0.0d0, b01Dx1 = 0.0d0, b02Dx1 = 0.0d0, b10Dx1 = 0.0d0, b11Dx1 = 0.0d0, b12Dx1 = 1.0d0, b20Dx1 = 0.0d0, b21Dx1 = 0.0d0, b22Dx1 = 0.0d0, b30Dx1 = 0.0d0, b31Dx1 = 0.0d0, b32Dx1 = 0.0d0, b00Dx2 = 0.0d0, b01Dx2 = 0.0d0, b02Dx2 = 0.0d0, b10Dx2 = 0.0d0, b11Dx2 = 0.0d0, b12Dx2 = 0.0d0, b20Dx2 = 0.0d0, b21Dx2 = 0.0d0, b22Dx2 = 1.0d0, b30Dx2 = 0.0d0, b31Dx2 = 0.0d0, b32Dx2 = 0.0d0, b00Dx3 = 0.0d0, b01Dx3 = 0.0d0, b02Dx3 = 0.0d0, b10Dx3 = 0.0d0, b11Dx3 = 0.0d0, b12Dx3 = 0.0d0, b20Dx3 = 0.0d0, b21Dx3 = 0.0d0, b22Dx3 = 0.0d0, b30Dx3 = 0.0d0, b31Dx3 = 0.0d0, b32Dx3 = 1.0d0, c00Du0 = 0.5d0 * (-b00Du0 + b01Du0 + b02Du0), c01Du0 = 0.5d0 * ( b00Du0 - b01Du0 + b02Du0), c02Du0 = 0.5d0 * ( b00Du0 + b01Du0 - b02Du0), c10Du0 = 0.5d0 * (-b10Du0 + b11Du0 + b12Du0), c11Du0 = 0.5d0 * ( b10Du0 - b11Du0 + b12Du0), c12Du0 = 0.5d0 * ( b10Du0 + b11Du0 - b12Du0), c20Du0 = 0.5d0 * (-b20Du0 + b21Du0 + b22Du0), c21Du0 = 0.5d0 * ( b20Du0 - b21Du0 + b22Du0), c22Du0 = 0.5d0 * ( b20Du0 + b21Du0 - b22Du0), c30Du0 = 0.5d0 * (-b30Du0 + b31Du0 + b32Du0), c31Du0 = 0.5d0 * ( b30Du0 - b31Du0 + b32Du0), c32Du0 = 0.5d0 * ( b30Du0 + b31Du0 - b32Du0), c00Du1 = 0.5d0 * (-b00Du1 + b01Du1 + b02Du1), c01Du1 = 0.5d0 * ( b00Du1 - b01Du1 + b02Du1), c02Du1 = 0.5d0 * ( b00Du1 + b01Du1 - b02Du1), c10Du1 = 0.5d0 * (-b10Du1 + b11Du1 + b12Du1), c11Du1 = 0.5d0 * ( b10Du1 - b11Du1 + b12Du1), c12Du1 = 0.5d0 * ( b10Du1 + b11Du1 - b12Du1), c20Du1 = 0.5d0 * (-b20Du1 + b21Du1 + b22Du1), c21Du1 = 0.5d0 * ( b20Du1 - b21Du1 + b22Du1), c22Du1 = 0.5d0 * ( b20Du1 + b21Du1 - b22Du1), c30Du1 = 0.5d0 * (-b30Du1 + b31Du1 + b32Du1), c31Du1 = 0.5d0 * ( b30Du1 - b31Du1 + b32Du1), c32Du1 = 0.5d0 * ( b30Du1 + b31Du1 - b32Du1), c00Du2 = 0.5d0 * (-b00Du2 + b01Du2 + b02Du2), c01Du2 = 0.5d0 * ( b00Du2 - b01Du2 + b02Du2), c02Du2 = 0.5d0 * ( b00Du2 + b01Du2 - b02Du2), c10Du2 = 0.5d0 * (-b10Du2 + b11Du2 + b12Du2), c11Du2 = 0.5d0 * ( b10Du2 - b11Du2 + b12Du2), c12Du2 = 0.5d0 * ( b10Du2 + b11Du2 - b12Du2), c20Du2 = 0.5d0 * (-b20Du2 + b21Du2 + b22Du2), c21Du2 = 0.5d0 * ( b20Du2 - b21Du2 + b22Du2), c22Du2 = 0.5d0 * ( b20Du2 + b21Du2 - b22Du2), c30Du2 = 0.5d0 * (-b30Du2 + b31Du2 + b32Du2), c31Du2 = 0.5d0 * ( b30Du2 - b31Du2 + b32Du2), c32Du2 = 0.5d0 * ( b30Du2 + b31Du2 - b32Du2), c00Du3 = 0.5d0 * (-b00Du3 + b01Du3 + b02Du3), c01Du3 = 0.5d0 * ( b00Du3 - b01Du3 + b02Du3), c02Du3 = 0.5d0 * ( b00Du3 + b01Du3 - b02Du3), c10Du3 = 0.5d0 * (-b10Du3 + b11Du3 + b12Du3), c11Du3 = 0.5d0 * ( b10Du3 - b11Du3 + b12Du3), c12Du3 = 0.5d0 * ( b10Du3 + b11Du3 - b12Du3), c20Du3 = 0.5d0 * (-b20Du3 + b21Du3 + b22Du3), c21Du3 = 0.5d0 * ( b20Du3 - b21Du3 + b22Du3), c22Du3 = 0.5d0 * ( b20Du3 + b21Du3 - b22Du3), c30Du3 = 0.5d0 * (-b30Du3 + b31Du3 + b32Du3), c31Du3 = 0.5d0 * ( b30Du3 - b31Du3 + b32Du3), c32Du3 = 0.5d0 * ( b30Du3 + b31Du3 - b32Du3), c00Dv0 = 0.5d0 * (-b00Dv0 + b01Dv0 + b02Dv0), c01Dv0 = 0.5d0 * ( b00Dv0 - b01Dv0 + b02Dv0), c02Dv0 = 0.5d0 * ( b00Dv0 + b01Dv0 - b02Dv0), c10Dv0 = 0.5d0 * (-b10Dv0 + b11Dv0 + b12Dv0), c11Dv0 = 0.5d0 * ( b10Dv0 - b11Dv0 + b12Dv0), c12Dv0 = 0.5d0 * ( b10Dv0 + b11Dv0 - b12Dv0), c20Dv0 = 0.5d0 * (-b20Dv0 + b21Dv0 + b22Dv0), c21Dv0 = 0.5d0 * ( b20Dv0 - b21Dv0 + b22Dv0), c22Dv0 = 0.5d0 * ( b20Dv0 + b21Dv0 - b22Dv0), c30Dv0 = 0.5d0 * (-b30Dv0 + b31Dv0 + b32Dv0), c31Dv0 = 0.5d0 * ( b30Dv0 - b31Dv0 + b32Dv0), c32Dv0 = 0.5d0 * ( b30Dv0 + b31Dv0 - b32Dv0), c00Dv1 = 0.5d0 * (-b00Dv1 + b01Dv1 + b02Dv1), c01Dv1 = 0.5d0 * ( b00Dv1 - b01Dv1 + b02Dv1), c02Dv1 = 0.5d0 * ( b00Dv1 + b01Dv1 - b02Dv1), c10Dv1 = 0.5d0 * (-b10Dv1 + b11Dv1 + b12Dv1), c11Dv1 = 0.5d0 * ( b10Dv1 - b11Dv1 + b12Dv1), c12Dv1 = 0.5d0 * ( b10Dv1 + b11Dv1 - b12Dv1), c20Dv1 = 0.5d0 * (-b20Dv1 + b21Dv1 + b22Dv1), c21Dv1 = 0.5d0 * ( b20Dv1 - b21Dv1 + b22Dv1), c22Dv1 = 0.5d0 * ( b20Dv1 + b21Dv1 - b22Dv1), c30Dv1 = 0.5d0 * (-b30Dv1 + b31Dv1 + b32Dv1), c31Dv1 = 0.5d0 * ( b30Dv1 - b31Dv1 + b32Dv1), c32Dv1 = 0.5d0 * ( b30Dv1 + b31Dv1 - b32Dv1), c00Dv2 = 0.5d0 * (-b00Dv2 + b01Dv2 + b02Dv2), c01Dv2 = 0.5d0 * ( b00Dv2 - b01Dv2 + b02Dv2), c02Dv2 = 0.5d0 * ( b00Dv2 + b01Dv2 - b02Dv2), c10Dv2 = 0.5d0 * (-b10Dv2 + b11Dv2 + b12Dv2), c11Dv2 = 0.5d0 * ( b10Dv2 - b11Dv2 + b12Dv2), c12Dv2 = 0.5d0 * ( b10Dv2 + b11Dv2 - b12Dv2), c20Dv2 = 0.5d0 * (-b20Dv2 + b21Dv2 + b22Dv2), c21Dv2 = 0.5d0 * ( b20Dv2 - b21Dv2 + b22Dv2), c22Dv2 = 0.5d0 * ( b20Dv2 + b21Dv2 - b22Dv2), c30Dv2 = 0.5d0 * (-b30Dv2 + b31Dv2 + b32Dv2), c31Dv2 = 0.5d0 * ( b30Dv2 - b31Dv2 + b32Dv2), c32Dv2 = 0.5d0 * ( b30Dv2 + b31Dv2 - b32Dv2), c00Dv3 = 0.5d0 * (-b00Dv3 + b01Dv3 + b02Dv3), c01Dv3 = 0.5d0 * ( b00Dv3 - b01Dv3 + b02Dv3), c02Dv3 = 0.5d0 * ( b00Dv3 + b01Dv3 - b02Dv3), c10Dv3 = 0.5d0 * (-b10Dv3 + b11Dv3 + b12Dv3), c11Dv3 = 0.5d0 * ( b10Dv3 - b11Dv3 + b12Dv3), c12Dv3 = 0.5d0 * ( b10Dv3 + b11Dv3 - b12Dv3), c20Dv3 = 0.5d0 * (-b20Dv3 + b21Dv3 + b22Dv3), c21Dv3 = 0.5d0 * ( b20Dv3 - b21Dv3 + b22Dv3), c22Dv3 = 0.5d0 * ( b20Dv3 + b21Dv3 - b22Dv3), c30Dv3 = 0.5d0 * (-b30Dv3 + b31Dv3 + b32Dv3), c31Dv3 = 0.5d0 * ( b30Dv3 - b31Dv3 + b32Dv3), c32Dv3 = 0.5d0 * ( b30Dv3 + b31Dv3 - b32Dv3), c00Dw0 = 0.5d0 * (-b00Dw0 + b01Dw0 + b02Dw0), c01Dw0 = 0.5d0 * ( b00Dw0 - b01Dw0 + b02Dw0), c02Dw0 = 0.5d0 * ( b00Dw0 + b01Dw0 - b02Dw0), c10Dw0 = 0.5d0 * (-b10Dw0 + b11Dw0 + b12Dw0), c11Dw0 = 0.5d0 * ( b10Dw0 - b11Dw0 + b12Dw0), c12Dw0 = 0.5d0 * ( b10Dw0 + b11Dw0 - b12Dw0), c20Dw0 = 0.5d0 * (-b20Dw0 + b21Dw0 + b22Dw0), c21Dw0 = 0.5d0 * ( b20Dw0 - b21Dw0 + b22Dw0), c22Dw0 = 0.5d0 * ( b20Dw0 + b21Dw0 - b22Dw0), c30Dw0 = 0.5d0 * (-b30Dw0 + b31Dw0 + b32Dw0), c31Dw0 = 0.5d0 * ( b30Dw0 - b31Dw0 + b32Dw0), c32Dw0 = 0.5d0 * ( b30Dw0 + b31Dw0 - b32Dw0), c00Dw1 = 0.5d0 * (-b00Dw1 + b01Dw1 + b02Dw1), c01Dw1 = 0.5d0 * ( b00Dw1 - b01Dw1 + b02Dw1), c02Dw1 = 0.5d0 * ( b00Dw1 + b01Dw1 - b02Dw1), c10Dw1 = 0.5d0 * (-b10Dw1 + b11Dw1 + b12Dw1), c11Dw1 = 0.5d0 * ( b10Dw1 - b11Dw1 + b12Dw1), c12Dw1 = 0.5d0 * ( b10Dw1 + b11Dw1 - b12Dw1), c20Dw1 = 0.5d0 * (-b20Dw1 + b21Dw1 + b22Dw1), c21Dw1 = 0.5d0 * ( b20Dw1 - b21Dw1 + b22Dw1), c22Dw1 = 0.5d0 * ( b20Dw1 + b21Dw1 - b22Dw1), c30Dw1 = 0.5d0 * (-b30Dw1 + b31Dw1 + b32Dw1), c31Dw1 = 0.5d0 * ( b30Dw1 - b31Dw1 + b32Dw1), c32Dw1 = 0.5d0 * ( b30Dw1 + b31Dw1 - b32Dw1), c00Dw2 = 0.5d0 * (-b00Dw2 + b01Dw2 + b02Dw2), c01Dw2 = 0.5d0 * ( b00Dw2 - b01Dw2 + b02Dw2), c02Dw2 = 0.5d0 * ( b00Dw2 + b01Dw2 - b02Dw2), c10Dw2 = 0.5d0 * (-b10Dw2 + b11Dw2 + b12Dw2), c11Dw2 = 0.5d0 * ( b10Dw2 - b11Dw2 + b12Dw2), c12Dw2 = 0.5d0 * ( b10Dw2 + b11Dw2 - b12Dw2), c20Dw2 = 0.5d0 * (-b20Dw2 + b21Dw2 + b22Dw2), c21Dw2 = 0.5d0 * ( b20Dw2 - b21Dw2 + b22Dw2), c22Dw2 = 0.5d0 * ( b20Dw2 + b21Dw2 - b22Dw2), c30Dw2 = 0.5d0 * (-b30Dw2 + b31Dw2 + b32Dw2), c31Dw2 = 0.5d0 * ( b30Dw2 - b31Dw2 + b32Dw2), c32Dw2 = 0.5d0 * ( b30Dw2 + b31Dw2 - b32Dw2), c00Dw3 = 0.5d0 * (-b00Dw3 + b01Dw3 + b02Dw3), c01Dw3 = 0.5d0 * ( b00Dw3 - b01Dw3 + b02Dw3), c02Dw3 = 0.5d0 * ( b00Dw3 + b01Dw3 - b02Dw3), c10Dw3 = 0.5d0 * (-b10Dw3 + b11Dw3 + b12Dw3), c11Dw3 = 0.5d0 * ( b10Dw3 - b11Dw3 + b12Dw3), c12Dw3 = 0.5d0 * ( b10Dw3 + b11Dw3 - b12Dw3), c20Dw3 = 0.5d0 * (-b20Dw3 + b21Dw3 + b22Dw3), c21Dw3 = 0.5d0 * ( b20Dw3 - b21Dw3 + b22Dw3), c22Dw3 = 0.5d0 * ( b20Dw3 + b21Dw3 - b22Dw3), c30Dw3 = 0.5d0 * (-b30Dw3 + b31Dw3 + b32Dw3), c31Dw3 = 0.5d0 * ( b30Dw3 - b31Dw3 + b32Dw3), c32Dw3 = 0.5d0 * ( b30Dw3 + b31Dw3 - b32Dw3), c00Dx0 = 0.5d0 * (-b00Dx0 + b01Dx0 + b02Dx0), c01Dx0 = 0.5d0 * ( b00Dx0 - b01Dx0 + b02Dx0), c02Dx0 = 0.5d0 * ( b00Dx0 + b01Dx0 - b02Dx0), c10Dx0 = 0.5d0 * (-b10Dx0 + b11Dx0 + b12Dx0), c11Dx0 = 0.5d0 * ( b10Dx0 - b11Dx0 + b12Dx0), c12Dx0 = 0.5d0 * ( b10Dx0 + b11Dx0 - b12Dx0), c20Dx0 = 0.5d0 * (-b20Dx0 + b21Dx0 + b22Dx0), c21Dx0 = 0.5d0 * ( b20Dx0 - b21Dx0 + b22Dx0), c22Dx0 = 0.5d0 * ( b20Dx0 + b21Dx0 - b22Dx0), c30Dx0 = 0.5d0 * (-b30Dx0 + b31Dx0 + b32Dx0), c31Dx0 = 0.5d0 * ( b30Dx0 - b31Dx0 + b32Dx0), c32Dx0 = 0.5d0 * ( b30Dx0 + b31Dx0 - b32Dx0), c00Dx1 = 0.5d0 * (-b00Dx1 + b01Dx1 + b02Dx1), c01Dx1 = 0.5d0 * ( b00Dx1 - b01Dx1 + b02Dx1), c02Dx1 = 0.5d0 * ( b00Dx1 + b01Dx1 - b02Dx1), c10Dx1 = 0.5d0 * (-b10Dx1 + b11Dx1 + b12Dx1), c11Dx1 = 0.5d0 * ( b10Dx1 - b11Dx1 + b12Dx1), c12Dx1 = 0.5d0 * ( b10Dx1 + b11Dx1 - b12Dx1), c20Dx1 = 0.5d0 * (-b20Dx1 + b21Dx1 + b22Dx1), c21Dx1 = 0.5d0 * ( b20Dx1 - b21Dx1 + b22Dx1), c22Dx1 = 0.5d0 * ( b20Dx1 + b21Dx1 - b22Dx1), c30Dx1 = 0.5d0 * (-b30Dx1 + b31Dx1 + b32Dx1), c31Dx1 = 0.5d0 * ( b30Dx1 - b31Dx1 + b32Dx1), c32Dx1 = 0.5d0 * ( b30Dx1 + b31Dx1 - b32Dx1), c00Dx2 = 0.5d0 * (-b00Dx2 + b01Dx2 + b02Dx2), c01Dx2 = 0.5d0 * ( b00Dx2 - b01Dx2 + b02Dx2), c02Dx2 = 0.5d0 * ( b00Dx2 + b01Dx2 - b02Dx2), c10Dx2 = 0.5d0 * (-b10Dx2 + b11Dx2 + b12Dx2), c11Dx2 = 0.5d0 * ( b10Dx2 - b11Dx2 + b12Dx2), c12Dx2 = 0.5d0 * ( b10Dx2 + b11Dx2 - b12Dx2), c20Dx2 = 0.5d0 * (-b20Dx2 + b21Dx2 + b22Dx2), c21Dx2 = 0.5d0 * ( b20Dx2 - b21Dx2 + b22Dx2), c22Dx2 = 0.5d0 * ( b20Dx2 + b21Dx2 - b22Dx2), c30Dx2 = 0.5d0 * (-b30Dx2 + b31Dx2 + b32Dx2), c31Dx2 = 0.5d0 * ( b30Dx2 - b31Dx2 + b32Dx2), c32Dx2 = 0.5d0 * ( b30Dx2 + b31Dx2 - b32Dx2), c00Dx3 = 0.5d0 * (-b00Dx3 + b01Dx3 + b02Dx3), c01Dx3 = 0.5d0 * ( b00Dx3 - b01Dx3 + b02Dx3), c02Dx3 = 0.5d0 * ( b00Dx3 + b01Dx3 - b02Dx3), c10Dx3 = 0.5d0 * (-b10Dx3 + b11Dx3 + b12Dx3), c11Dx3 = 0.5d0 * ( b10Dx3 - b11Dx3 + b12Dx3), c12Dx3 = 0.5d0 * ( b10Dx3 + b11Dx3 - b12Dx3), c20Dx3 = 0.5d0 * (-b20Dx3 + b21Dx3 + b22Dx3), c21Dx3 = 0.5d0 * ( b20Dx3 - b21Dx3 + b22Dx3), c22Dx3 = 0.5d0 * ( b20Dx3 + b21Dx3 - b22Dx3), c30Dx3 = 0.5d0 * (-b30Dx3 + b31Dx3 + b32Dx3), c31Dx3 = 0.5d0 * ( b30Dx3 - b31Dx3 + b32Dx3), c32Dx3 = 0.5d0 * ( b30Dx3 + b31Dx3 - b32Dx3), t00Du0 = 2.0d0 * (c00*c00Du0+c10*c10Du0+c20*c20Du0+c30*c30Du0), t10Du0 = (c00*c01Du0+c01*c00Du0) + (c10*c11Du0+c11*c10Du0) + (c20*c21Du0+c21*c20Du0) + (c30*c31Du0+c31*c30Du0), t11Du0 = 2.0d0 * (c01*c01Du0+c11*c11Du0+c21*c21Du0+c31*c31Du0), t20Du0 = (c00*c02Du0+c02*c00Du0) + (c10*c12Du0+c12*c10Du0) + (c20*c22Du0+c22*c20Du0) + (c30*c32Du0+c32*c30Du0), t21Du0 = (c01*c00Du0+c00*c01Du0) + (c11*c10Du0+c10*c11Du0) + (c21*c20Du0+c20*c21Du0) + (c31*c30Du0+c30*c31Du0), t22Du0 = 2.0d0*(c02*c02Du0+c12*c12Du0+c22*c22Du0+c32*c32Du0), t01Du0 = t10Du0, t02Du0 = t20Du0, t12Du0 = t21Du0, t00Du1 = 2.0d0 * (c00*c00Du1+c10*c10Du1+c20*c20Du1+c30*c30Du1), t10Du1 = (c00*c01Du1+c01*c00Du1) + (c10*c11Du1+c11*c10Du1) + (c20*c21Du1+c21*c20Du1) + (c30*c31Du1+c31*c30Du1), t11Du1 = 2.0d0 * (c01*c01Du1+c11*c11Du1+c21*c21Du1+c31*c31Du1), t20Du1 = (c00*c02Du1+c02*c00Du1) + (c10*c12Du1+c12*c10Du1) + (c20*c22Du1+c22*c20Du1) + (c30*c32Du1+c32*c30Du1), t21Du1 = (c01*c00Du1+c00*c01Du1) + (c11*c10Du1+c10*c11Du1) + (c21*c20Du1+c20*c21Du1) + (c31*c30Du1+c30*c31Du1), t22Du1 = 2.0d0*(c02*c02Du1+c12*c12Du1+c22*c22Du1+c32*c32Du1), t01Du1 = t10Du1, t02Du1 = t20Du1, t12Du1 = t21Du1, t00Du2 = 2.0d0 * (c00*c00Du2+c10*c10Du2+c20*c20Du2+c30*c30Du2), t10Du2 = (c00*c01Du2+c01*c00Du2) + (c10*c11Du2+c11*c10Du2) + (c20*c21Du2+c21*c20Du2) + (c30*c31Du2+c31*c30Du2), t11Du2 = 2.0d0 * (c01*c01Du2+c11*c11Du2+c21*c21Du2+c31*c31Du2), t20Du2 = (c00*c02Du2+c02*c00Du2) + (c10*c12Du2+c12*c10Du2) + (c20*c22Du2+c22*c20Du2) + (c30*c32Du2+c32*c30Du2), t21Du2 = (c01*c00Du2+c00*c01Du2) + (c11*c10Du2+c10*c11Du2) + (c21*c20Du2+c20*c21Du2) + (c31*c30Du2+c30*c31Du2), t22Du2 = 2.0d0*(c02*c02Du2+c12*c12Du2+c22*c22Du2+c32*c32Du2), t01Du2 = t10Du2, t02Du2 = t20Du2, t12Du2 = t21Du2, t00Du3 = 2.0d0 * (c00*c00Du3+c10*c10Du3+c20*c20Du3+c30*c30Du3), t10Du3 = (c00*c01Du3+c01*c00Du3) + (c10*c11Du3+c11*c10Du3) + (c20*c21Du3+c21*c20Du3) + (c30*c31Du3+c31*c30Du3), t11Du3 = 2.0d0 * (c01*c01Du3+c11*c11Du3+c21*c21Du3+c31*c31Du3), t20Du3 = (c00*c02Du3+c02*c00Du3) + (c10*c12Du3+c12*c10Du3) + (c20*c22Du3+c22*c20Du3) + (c30*c32Du3+c32*c30Du3), t21Du3 = (c01*c00Du3+c00*c01Du3) + (c11*c10Du3+c10*c11Du3) + (c21*c20Du3+c20*c21Du3) + (c31*c30Du3+c30*c31Du3), t22Du3 = 2.0d0*(c02*c02Du3+c12*c12Du3+c22*c22Du3+c32*c32Du3), t01Du3 = t10Du3, t02Du3 = t20Du3, t12Du3 = t21Du3, t00Dv0 = 2.0d0 * (c00*c00Dv0+c10*c10Dv0+c20*c20Dv0+c30*c30Dv0), t10Dv0 = (c00*c01Dv0+c01*c00Dv0) + (c10*c11Dv0+c11*c10Dv0) + (c20*c21Dv0+c21*c20Dv0) + (c30*c31Dv0+c31*c30Dv0), t11Dv0 = 2.0d0 * (c01*c01Dv0+c11*c11Dv0+c21*c21Dv0+c31*c31Dv0), t20Dv0 = (c00*c02Dv0+c02*c00Dv0) + (c10*c12Dv0+c12*c10Dv0) + (c20*c22Dv0+c22*c20Dv0) + (c30*c32Dv0+c32*c30Dv0), t21Dv0 = (c01*c00Dv0+c00*c01Dv0) + (c11*c10Dv0+c10*c11Dv0) + (c21*c20Dv0+c20*c21Dv0) + (c31*c30Dv0+c30*c31Dv0), t22Dv0 = 2.0d0*(c02*c02Dv0+c12*c12Dv0+c22*c22Dv0+c32*c32Dv0), t01Dv0 = t10Dv0, t02Dv0 = t20Dv0, t12Dv0 = t21Dv0, t00Dv1 = 2.0d0 * (c00*c00Dv1+c10*c10Dv1+c20*c20Dv1+c30*c30Dv1), t10Dv1 = (c00*c01Dv1+c01*c00Dv1) + (c10*c11Dv1+c11*c10Dv1) + (c20*c21Dv1+c21*c20Dv1) + (c30*c31Dv1+c31*c30Dv1), t11Dv1 = 2.0d0 * (c01*c01Dv1+c11*c11Dv1+c21*c21Dv1+c31*c31Dv1), t20Dv1 = (c00*c02Dv1+c02*c00Dv1) + (c10*c12Dv1+c12*c10Dv1) + (c20*c22Dv1+c22*c20Dv1) + (c30*c32Dv1+c32*c30Dv1), t21Dv1 = (c01*c00Dv1+c00*c01Dv1) + (c11*c10Dv1+c10*c11Dv1) + (c21*c20Dv1+c20*c21Dv1) + (c31*c30Dv1+c30*c31Dv1), t22Dv1 = 2.0d0*(c02*c02Dv1+c12*c12Dv1+c22*c22Dv1+c32*c32Dv1), t01Dv1 = t10Dv1, t02Dv1 = t20Dv1, t12Dv1 = t21Dv1, t00Dv2 = 2.0d0 * (c00*c00Dv2+c10*c10Dv2+c20*c20Dv2+c30*c30Dv2), t10Dv2 = (c00*c01Dv2+c01*c00Dv2) + (c10*c11Dv2+c11*c10Dv2) + (c20*c21Dv2+c21*c20Dv2) + (c30*c31Dv2+c31*c30Dv2), t11Dv2 = 2.0d0 * (c01*c01Dv2+c11*c11Dv2+c21*c21Dv2+c31*c31Dv2), t20Dv2 = (c00*c02Dv2+c02*c00Dv2) + (c10*c12Dv2+c12*c10Dv2) + (c20*c22Dv2+c22*c20Dv2) + (c30*c32Dv2+c32*c30Dv2), t21Dv2 = (c01*c00Dv2+c00*c01Dv2) + (c11*c10Dv2+c10*c11Dv2) + (c21*c20Dv2+c20*c21Dv2) + (c31*c30Dv2+c30*c31Dv2), t22Dv2 = 2.0d0*(c02*c02Dv2+c12*c12Dv2+c22*c22Dv2+c32*c32Dv2), t01Dv2 = t10Dv2, t02Dv2 = t20Dv2, t12Dv2 = t21Dv2, t00Dv3 = 2.0d0 * (c00*c00Dv3+c10*c10Dv3+c20*c20Dv3+c30*c30Dv3), t10Dv3 = (c00*c01Dv3+c01*c00Dv3) + (c10*c11Dv3+c11*c10Dv3) + (c20*c21Dv3+c21*c20Dv3) + (c30*c31Dv3+c31*c30Dv3), t11Dv3 = 2.0d0 * (c01*c01Dv3+c11*c11Dv3+c21*c21Dv3+c31*c31Dv3), t20Dv3 = (c00*c02Dv3+c02*c00Dv3) + (c10*c12Dv3+c12*c10Dv3) + (c20*c22Dv3+c22*c20Dv3) + (c30*c32Dv3+c32*c30Dv3), t21Dv3 = (c01*c00Dv3+c00*c01Dv3) + (c11*c10Dv3+c10*c11Dv3) + (c21*c20Dv3+c20*c21Dv3) + (c31*c30Dv3+c30*c31Dv3), t22Dv3 = 2.0d0*(c02*c02Dv3+c12*c12Dv3+c22*c22Dv3+c32*c32Dv3), t01Dv3 = t10Dv3, t02Dv3 = t20Dv3, t12Dv3 = t21Dv3, t00Dw0 = 2.0d0 * (c00*c00Dw0+c10*c10Dw0+c20*c20Dw0+c30*c30Dw0), t10Dw0 = (c00*c01Dw0+c01*c00Dw0) + (c10*c11Dw0+c11*c10Dw0) + (c20*c21Dw0+c21*c20Dw0) + (c30*c31Dw0+c31*c30Dw0), t11Dw0 = 2.0d0 * (c01*c01Dw0+c11*c11Dw0+c21*c21Dw0+c31*c31Dw0), t20Dw0 = (c00*c02Dw0+c02*c00Dw0) + (c10*c12Dw0+c12*c10Dw0) + (c20*c22Dw0+c22*c20Dw0) + (c30*c32Dw0+c32*c30Dw0), t21Dw0 = (c01*c00Dw0+c00*c01Dw0) + (c11*c10Dw0+c10*c11Dw0) + (c21*c20Dw0+c20*c21Dw0) + (c31*c30Dw0+c30*c31Dw0), t22Dw0 = 2.0d0*(c02*c02Dw0+c12*c12Dw0+c22*c22Dw0+c32*c32Dw0), t01Dw0 = t10Dw0, t02Dw0 = t20Dw0, t12Dw0 = t21Dw0, t00Dw1 = 2.0d0 * (c00*c00Dw1+c10*c10Dw1+c20*c20Dw1+c30*c30Dw1), t10Dw1 = (c00*c01Dw1+c01*c00Dw1) + (c10*c11Dw1+c11*c10Dw1) + (c20*c21Dw1+c21*c20Dw1) + (c30*c31Dw1+c31*c30Dw1), t11Dw1 = 2.0d0 * (c01*c01Dw1+c11*c11Dw1+c21*c21Dw1+c31*c31Dw1), t20Dw1 = (c00*c02Dw1+c02*c00Dw1) + (c10*c12Dw1+c12*c10Dw1) + (c20*c22Dw1+c22*c20Dw1) + (c30*c32Dw1+c32*c30Dw1), t21Dw1 = (c01*c00Dw1+c00*c01Dw1) + (c11*c10Dw1+c10*c11Dw1) + (c21*c20Dw1+c20*c21Dw1) + (c31*c30Dw1+c30*c31Dw1), t22Dw1 = 2.0d0*(c02*c02Dw1+c12*c12Dw1+c22*c22Dw1+c32*c32Dw1), t01Dw1 = t10Dw1, t02Dw1 = t20Dw1, t12Dw1 = t21Dw1, t00Dw2 = 2.0d0 * (c00*c00Dw2+c10*c10Dw2+c20*c20Dw2+c30*c30Dw2), t10Dw2 = (c00*c01Dw2+c01*c00Dw2) + (c10*c11Dw2+c11*c10Dw2) + (c20*c21Dw2+c21*c20Dw2) + (c30*c31Dw2+c31*c30Dw2), t11Dw2 = 2.0d0 * (c01*c01Dw2+c11*c11Dw2+c21*c21Dw2+c31*c31Dw2), t20Dw2 = (c00*c02Dw2+c02*c00Dw2) + (c10*c12Dw2+c12*c10Dw2) + (c20*c22Dw2+c22*c20Dw2) + (c30*c32Dw2+c32*c30Dw2), t21Dw2 = (c01*c00Dw2+c00*c01Dw2) + (c11*c10Dw2+c10*c11Dw2) + (c21*c20Dw2+c20*c21Dw2) + (c31*c30Dw2+c30*c31Dw2), t22Dw2 = 2.0d0*(c02*c02Dw2+c12*c12Dw2+c22*c22Dw2+c32*c32Dw2), t01Dw2 = t10Dw2, t02Dw2 = t20Dw2, t12Dw2 = t21Dw2, t00Dw3 = 2.0d0 * (c00*c00Dw3+c10*c10Dw3+c20*c20Dw3+c30*c30Dw3), t10Dw3 = (c00*c01Dw3+c01*c00Dw3) + (c10*c11Dw3+c11*c10Dw3) + (c20*c21Dw3+c21*c20Dw3) + (c30*c31Dw3+c31*c30Dw3), t11Dw3 = 2.0d0 * (c01*c01Dw3+c11*c11Dw3+c21*c21Dw3+c31*c31Dw3), t20Dw3 = (c00*c02Dw3+c02*c00Dw3) + (c10*c12Dw3+c12*c10Dw3) + (c20*c22Dw3+c22*c20Dw3) + (c30*c32Dw3+c32*c30Dw3), t21Dw3 = (c01*c00Dw3+c00*c01Dw3) + (c11*c10Dw3+c10*c11Dw3) + (c21*c20Dw3+c20*c21Dw3) + (c31*c30Dw3+c30*c31Dw3), t22Dw3 = 2.0d0*(c02*c02Dw3+c12*c12Dw3+c22*c22Dw3+c32*c32Dw3), t01Dw3 = t10Dw3, t02Dw3 = t20Dw3, t12Dw3 = t21Dw3, t00Dx0 = 2.0d0 * (c00*c00Dx0+c10*c10Dx0+c20*c20Dx0+c30*c30Dx0), t10Dx0 = (c00*c01Dx0+c01*c00Dx0) + (c10*c11Dx0+c11*c10Dx0) + (c20*c21Dx0+c21*c20Dx0) + (c30*c31Dx0+c31*c30Dx0), t11Dx0 = 2.0d0 * (c01*c01Dx0+c11*c11Dx0+c21*c21Dx0+c31*c31Dx0), t20Dx0 = (c00*c02Dx0+c02*c00Dx0) + (c10*c12Dx0+c12*c10Dx0) + (c20*c22Dx0+c22*c20Dx0) + (c30*c32Dx0+c32*c30Dx0), t21Dx0 = (c01*c00Dx0+c00*c01Dx0) + (c11*c10Dx0+c10*c11Dx0) + (c21*c20Dx0+c20*c21Dx0) + (c31*c30Dx0+c30*c31Dx0), t22Dx0 = 2.0d0*(c02*c02Dx0+c12*c12Dx0+c22*c22Dx0+c32*c32Dx0), t01Dx0 = t10Dx0, t02Dx0 = t20Dx0, t12Dx0 = t21Dx0, t00Dx1 = 2.0d0 * (c00*c00Dx1+c10*c10Dx1+c20*c20Dx1+c30*c30Dx1), t10Dx1 = (c00*c01Dx1+c01*c00Dx1) + (c10*c11Dx1+c11*c10Dx1) + (c20*c21Dx1+c21*c20Dx1) + (c30*c31Dx1+c31*c30Dx1), t11Dx1 = 2.0d0 * (c01*c01Dx1+c11*c11Dx1+c21*c21Dx1+c31*c31Dx1), t20Dx1 = (c00*c02Dx1+c02*c00Dx1) + (c10*c12Dx1+c12*c10Dx1) + (c20*c22Dx1+c22*c20Dx1) + (c30*c32Dx1+c32*c30Dx1), t21Dx1 = (c01*c00Dx1+c00*c01Dx1) + (c11*c10Dx1+c10*c11Dx1) + (c21*c20Dx1+c20*c21Dx1) + (c31*c30Dx1+c30*c31Dx1), t22Dx1 = 2.0d0*(c02*c02Dx1+c12*c12Dx1+c22*c22Dx1+c32*c32Dx1), t01Dx1 = t10Dx1, t02Dx1 = t20Dx1, t12Dx1 = t21Dx1, t00Dx2 = 2.0d0 * (c00*c00Dx2+c10*c10Dx2+c20*c20Dx2+c30*c30Dx2), t10Dx2 = (c00*c01Dx2+c01*c00Dx2) + (c10*c11Dx2+c11*c10Dx2) + (c20*c21Dx2+c21*c20Dx2) + (c30*c31Dx2+c31*c30Dx2), t11Dx2 = 2.0d0 * (c01*c01Dx2+c11*c11Dx2+c21*c21Dx2+c31*c31Dx2), t20Dx2 = (c00*c02Dx2+c02*c00Dx2) + (c10*c12Dx2+c12*c10Dx2) + (c20*c22Dx2+c22*c20Dx2) + (c30*c32Dx2+c32*c30Dx2), t21Dx2 = (c01*c00Dx2+c00*c01Dx2) + (c11*c10Dx2+c10*c11Dx2) + (c21*c20Dx2+c20*c21Dx2) + (c31*c30Dx2+c30*c31Dx2), t22Dx2 = 2.0d0*(c02*c02Dx2+c12*c12Dx2+c22*c22Dx2+c32*c32Dx2), t01Dx2 = t10Dx2, t02Dx2 = t20Dx2, t12Dx2 = t21Dx2, t00Dx3 = 2.0d0 * (c00*c00Dx3+c10*c10Dx3+c20*c20Dx3+c30*c30Dx3), t10Dx3 = (c00*c01Dx3+c01*c00Dx3) + (c10*c11Dx3+c11*c10Dx3) + (c20*c21Dx3+c21*c20Dx3) + (c30*c31Dx3+c31*c30Dx3), t11Dx3 = 2.0d0 * (c01*c01Dx3+c11*c11Dx3+c21*c21Dx3+c31*c31Dx3), t20Dx3 = (c00*c02Dx3+c02*c00Dx3) + (c10*c12Dx3+c12*c10Dx3) + (c20*c22Dx3+c22*c20Dx3) + (c30*c32Dx3+c32*c30Dx3), t21Dx3 = (c01*c00Dx3+c00*c01Dx3) + (c11*c10Dx3+c10*c11Dx3) + (c21*c20Dx3+c20*c21Dx3) + (c31*c30Dx3+c30*c31Dx3), t22Dx3 = 2.0d0*(c02*c02Dx3+c12*c12Dx3+c22*c22Dx3+c32*c32Dx3), t01Dx3 = t10Dx3, t02Dx3 = t20Dx3, t12Dx3 = t21Dx3, T11Du0 = (t11*t22Du0+t22*t11Du0) - (t12*t12Du0+t12*t12Du0), T22Du0 = (t00*t22Du0+t22*t00Du0) - (t02*t02Du0+t02*t02Du0), T33Du0 = (t00*t11Du0+t11*t00Du0) - (t01*t01Du0+t01*t01Du0), T13Du0 = (t01*t12Du0+t12*t01Du0) - (t11*t02Du0+t02*t11Du0), T12Du0 = (t01*t22Du0+t22*t01Du0) - (t12*t02Du0+t02*t12Du0), T11Du1 = (t11*t22Du1+t22*t11Du1) - (t12*t12Du1+t12*t12Du1), T22Du1 = (t00*t22Du1+t22*t00Du1) - (t02*t02Du1+t02*t02Du1), T33Du1 = (t00*t11Du1+t11*t00Du1) - (t01*t01Du1+t01*t01Du1), T13Du1 = (t01*t12Du1+t12*t01Du1) - (t11*t02Du1+t02*t11Du1), T12Du1 = (t01*t22Du1+t22*t01Du1) - (t12*t02Du1+t02*t12Du1), T11Du2 = (t11*t22Du2+t22*t11Du2) - (t12*t12Du2+t12*t12Du2), T22Du2 = (t00*t22Du2+t22*t00Du2) - (t02*t02Du2+t02*t02Du2), T33Du2 = (t00*t11Du2+t11*t00Du2) - (t01*t01Du2+t01*t01Du2), T13Du2 = (t01*t12Du2+t12*t01Du2) - (t11*t02Du2+t02*t11Du2), T12Du2 = (t01*t22Du2+t22*t01Du2) - (t12*t02Du2+t02*t12Du2), T11Du3 = (t11*t22Du3+t22*t11Du3) - (t12*t12Du3+t12*t12Du3), T22Du3 = (t00*t22Du3+t22*t00Du3) - (t02*t02Du3+t02*t02Du3), T33Du3 = (t00*t11Du3+t11*t00Du3) - (t01*t01Du3+t01*t01Du3), T13Du3 = (t01*t12Du3+t12*t01Du3) - (t11*t02Du3+t02*t11Du3), T12Du3 = (t01*t22Du3+t22*t01Du3) - (t12*t02Du3+t02*t12Du3), T11Dv0 = (t11*t22Dv0+t22*t11Dv0) - (t12*t12Dv0+t12*t12Dv0), T22Dv0 = (t00*t22Dv0+t22*t00Dv0) - (t02*t02Dv0+t02*t02Dv0), T33Dv0 = (t00*t11Dv0+t11*t00Dv0) - (t01*t01Dv0+t01*t01Dv0), T13Dv0 = (t01*t12Dv0+t12*t01Dv0) - (t11*t02Dv0+t02*t11Dv0), T12Dv0 = (t01*t22Dv0+t22*t01Dv0) - (t12*t02Dv0+t02*t12Dv0), T11Dv1 = (t11*t22Dv1+t22*t11Dv1) - (t12*t12Dv1+t12*t12Dv1), T22Dv1 = (t00*t22Dv1+t22*t00Dv1) - (t02*t02Dv1+t02*t02Dv1), T33Dv1 = (t00*t11Dv1+t11*t00Dv1) - (t01*t01Dv1+t01*t01Dv1), T13Dv1 = (t01*t12Dv1+t12*t01Dv1) - (t11*t02Dv1+t02*t11Dv1), T12Dv1 = (t01*t22Dv1+t22*t01Dv1) - (t12*t02Dv1+t02*t12Dv1), T11Dv2 = (t11*t22Dv2+t22*t11Dv2) - (t12*t12Dv2+t12*t12Dv2), T22Dv2 = (t00*t22Dv2+t22*t00Dv2) - (t02*t02Dv2+t02*t02Dv2), T33Dv2 = (t00*t11Dv2+t11*t00Dv2) - (t01*t01Dv2+t01*t01Dv2), T13Dv2 = (t01*t12Dv2+t12*t01Dv2) - (t11*t02Dv2+t02*t11Dv2), T12Dv2 = (t01*t22Dv2+t22*t01Dv2) - (t12*t02Dv2+t02*t12Dv2), T11Dv3 = (t11*t22Dv3+t22*t11Dv3) - (t12*t12Dv3+t12*t12Dv3), T22Dv3 = (t00*t22Dv3+t22*t00Dv3) - (t02*t02Dv3+t02*t02Dv3), T33Dv3 = (t00*t11Dv3+t11*t00Dv3) - (t01*t01Dv3+t01*t01Dv3), T13Dv3 = (t01*t12Dv3+t12*t01Dv3) - (t11*t02Dv3+t02*t11Dv3), T12Dv3 = (t01*t22Dv3+t22*t01Dv3) - (t12*t02Dv3+t02*t12Dv3), T11Dw0 = (t11*t22Dw0+t22*t11Dw0) - (t12*t12Dw0+t12*t12Dw0), T22Dw0 = (t00*t22Dw0+t22*t00Dw0) - (t02*t02Dw0+t02*t02Dw0), T33Dw0 = (t00*t11Dw0+t11*t00Dw0) - (t01*t01Dw0+t01*t01Dw0), T13Dw0 = (t01*t12Dw0+t12*t01Dw0) - (t11*t02Dw0+t02*t11Dw0), T12Dw0 = (t01*t22Dw0+t22*t01Dw0) - (t12*t02Dw0+t02*t12Dw0), T11Dw1 = (t11*t22Dw1+t22*t11Dw1) - (t12*t12Dw1+t12*t12Dw1), T22Dw1 = (t00*t22Dw1+t22*t00Dw1) - (t02*t02Dw1+t02*t02Dw1), T33Dw1 = (t00*t11Dw1+t11*t00Dw1) - (t01*t01Dw1+t01*t01Dw1), T13Dw1 = (t01*t12Dw1+t12*t01Dw1) - (t11*t02Dw1+t02*t11Dw1), T12Dw1 = (t01*t22Dw1+t22*t01Dw1) - (t12*t02Dw1+t02*t12Dw1), T11Dw2 = (t11*t22Dw2+t22*t11Dw2) - (t12*t12Dw2+t12*t12Dw2), T22Dw2 = (t00*t22Dw2+t22*t00Dw2) - (t02*t02Dw2+t02*t02Dw2), T33Dw2 = (t00*t11Dw2+t11*t00Dw2) - (t01*t01Dw2+t01*t01Dw2), T13Dw2 = (t01*t12Dw2+t12*t01Dw2) - (t11*t02Dw2+t02*t11Dw2), T12Dw2 = (t01*t22Dw2+t22*t01Dw2) - (t12*t02Dw2+t02*t12Dw2), T11Dw3 = (t11*t22Dw3+t22*t11Dw3) - (t12*t12Dw3+t12*t12Dw3), T22Dw3 = (t00*t22Dw3+t22*t00Dw3) - (t02*t02Dw3+t02*t02Dw3), T33Dw3 = (t00*t11Dw3+t11*t00Dw3) - (t01*t01Dw3+t01*t01Dw3), T13Dw3 = (t01*t12Dw3+t12*t01Dw3) - (t11*t02Dw3+t02*t11Dw3), T12Dw3 = (t01*t22Dw3+t22*t01Dw3) - (t12*t02Dw3+t02*t12Dw3), T11Dx0 = (t11*t22Dx0+t22*t11Dx0) - (t12*t12Dx0+t12*t12Dx0), T22Dx0 = (t00*t22Dx0+t22*t00Dx0) - (t02*t02Dx0+t02*t02Dx0), T33Dx0 = (t00*t11Dx0+t11*t00Dx0) - (t01*t01Dx0+t01*t01Dx0), T13Dx0 = (t01*t12Dx0+t12*t01Dx0) - (t11*t02Dx0+t02*t11Dx0), T12Dx0 = (t01*t22Dx0+t22*t01Dx0) - (t12*t02Dx0+t02*t12Dx0), T11Dx1 = (t11*t22Dx1+t22*t11Dx1) - (t12*t12Dx1+t12*t12Dx1), T22Dx1 = (t00*t22Dx1+t22*t00Dx1) - (t02*t02Dx1+t02*t02Dx1), T33Dx1 = (t00*t11Dx1+t11*t00Dx1) - (t01*t01Dx1+t01*t01Dx1), T13Dx1 = (t01*t12Dx1+t12*t01Dx1) - (t11*t02Dx1+t02*t11Dx1), T12Dx1 = (t01*t22Dx1+t22*t01Dx1) - (t12*t02Dx1+t02*t12Dx1), T11Dx2 = (t11*t22Dx2+t22*t11Dx2) - (t12*t12Dx2+t12*t12Dx2), T22Dx2 = (t00*t22Dx2+t22*t00Dx2) - (t02*t02Dx2+t02*t02Dx2), T33Dx2 = (t00*t11Dx2+t11*t00Dx2) - (t01*t01Dx2+t01*t01Dx2), T13Dx2 = (t01*t12Dx2+t12*t01Dx2) - (t11*t02Dx2+t02*t11Dx2), T12Dx2 = (t01*t22Dx2+t22*t01Dx2) - (t12*t02Dx2+t02*t12Dx2), T11Dx3 = (t11*t22Dx3+t22*t11Dx3) - (t12*t12Dx3+t12*t12Dx3), T22Dx3 = (t00*t22Dx3+t22*t00Dx3) - (t02*t02Dx3+t02*t02Dx3), T33Dx3 = (t00*t11Dx3+t11*t00Dx3) - (t01*t01Dx3+t01*t01Dx3), T13Dx3 = (t01*t12Dx3+t12*t01Dx3) - (t11*t02Dx3+t02*t11Dx3), T12Dx3 = (t01*t22Dx3+t22*t01Dx3) - (t12*t02Dx3+t02*t12Dx3), delDu0 = (t00*T11Du0+t00Du0*T11) - (t01*T12Du0+t01Du0*T12) + (t02*T13Du0+t02Du0*T13), gamDu0 = t00Du0 + t11Du0 + t22Du0, sigDu0 = T11Du0 + T22Du0 + T33Du0, delDu1 = (t00*T11Du1+t00Du1*T11) - (t01*T12Du1+t01Du1*T12) + (t02*T13Du1+t02Du1*T13), gamDu1 = t00Du1 + t11Du1 + t22Du1, sigDu1 = T11Du1 + T22Du1 + T33Du1, delDu2 = (t00*T11Du2+t00Du2*T11) - (t01*T12Du2+t01Du2*T12) + (t02*T13Du2+t02Du2*T13), gamDu2 = t00Du2 + t11Du2 + t22Du2, sigDu2 = T11Du2 + T22Du2 + T33Du2, delDu3 = (t00*T11Du3+t00Du3*T11) - (t01*T12Du3+t01Du3*T12) + (t02*T13Du3+t02Du3*T13), gamDu3 = t00Du3 + t11Du3 + t22Du3, sigDu3 = T11Du3 + T22Du3 + T33Du3, delDv0 = (t00*T11Dv0+t00Dv0*T11) - (t01*T12Dv0+t01Dv0*T12) + (t02*T13Dv0+t02Dv0*T13), gamDv0 = t00Dv0 + t11Dv0 + t22Dv0, sigDv0 = T11Dv0 + T22Dv0 + T33Dv0, delDv1 = (t00*T11Dv1+t00Dv1*T11) - (t01*T12Dv1+t01Dv1*T12) + (t02*T13Dv1+t02Dv1*T13), gamDv1 = t00Dv1 + t11Dv1 + t22Dv1, sigDv1 = T11Dv1 + T22Dv1 + T33Dv1, delDv2 = (t00*T11Dv2+t00Dv2*T11) - (t01*T12Dv2+t01Dv2*T12) + (t02*T13Dv2+t02Dv2*T13), gamDv2 = t00Dv2 + t11Dv2 + t22Dv2, sigDv2 = T11Dv2 + T22Dv2 + T33Dv2, delDv3 = (t00*T11Dv3+t00Dv3*T11) - (t01*T12Dv3+t01Dv3*T12) + (t02*T13Dv3+t02Dv3*T13), gamDv3 = t00Dv3 + t11Dv3 + t22Dv3, sigDv3 = T11Dv3 + T22Dv3 + T33Dv3, delDw0 = (t00*T11Dw0+t00Dw0*T11) - (t01*T12Dw0+t01Dw0*T12) + (t02*T13Dw0+t02Dw0*T13), gamDw0 = t00Dw0 + t11Dw0 + t22Dw0, sigDw0 = T11Dw0 + T22Dw0 + T33Dw0, delDw1 = (t00*T11Dw1+t00Dw1*T11) - (t01*T12Dw1+t01Dw1*T12) + (t02*T13Dw1+t02Dw1*T13), gamDw1 = t00Dw1 + t11Dw1 + t22Dw1, sigDw1 = T11Dw1 + T22Dw1 + T33Dw1, delDw2 = (t00*T11Dw2+t00Dw2*T11) - (t01*T12Dw2+t01Dw2*T12) + (t02*T13Dw2+t02Dw2*T13), gamDw2 = t00Dw2 + t11Dw2 + t22Dw2, sigDw2 = T11Dw2 + T22Dw2 + T33Dw2, delDw3 = (t00*T11Dw3+t00Dw3*T11) - (t01*T12Dw3+t01Dw3*T12) + (t02*T13Dw3+t02Dw3*T13), gamDw3 = t00Dw3 + t11Dw3 + t22Dw3, sigDw3 = T11Dw3 + T22Dw3 + T33Dw3, delDx0 = (t00*T11Dx0+t00Dx0*T11) - (t01*T12Dx0+t01Dx0*T12) + (t02*T13Dx0+t02Dx0*T13), gamDx0 = t00Dx0 + t11Dx0 + t22Dx0, sigDx0 = T11Dx0 + T22Dx0 + T33Dx0, delDx1 = (t00*T11Dx1+t00Dx1*T11) - (t01*T12Dx1+t01Dx1*T12) + (t02*T13Dx1+t02Dx1*T13), gamDx1 = t00Dx1 + t11Dx1 + t22Dx1, sigDx1 = T11Dx1 + T22Dx1 + T33Dx1, delDx2 = (t00*T11Dx2+t00Dx2*T11) - (t01*T12Dx2+t01Dx2*T12) + (t02*T13Dx2+t02Dx2*T13), gamDx2 = t00Dx2 + t11Dx2 + t22Dx2, sigDx2 = T11Dx2 + T22Dx2 + T33Dx2, delDx3 = (t00*T11Dx3+t00Dx3*T11) - (t01*T12Dx3+t01Dx3*T12) + (t02*T13Dx3+t02Dx3*T13), gamDx3 = t00Dx3 + t11Dx3 + t22Dx3, sigDx3 = T11Dx3 + T22Dx3 + T33Dx3, te1Du0 = alpha/32.0D0*(2.0d0*Delta*delDu0-2.0d0*Del_3*delDu0), te2Du0 = beta/6.0D0*(2.0d0*Sigma*gamDu0-3.0d0 *sigDu0), te1Dv0 = alpha/32.0D0*(2.0d0*Delta*delDv0-2.0d0*Del_3*delDv0), te2Dv0 = beta/6.0D0*(2.0d0*Sigma*gamDv0-3.0d0 *sigDv0), te1Dw0 = alpha/32.0D0*(2.0d0*Delta*delDw0-2.0d0*Del_3*delDw0), te2Dw0 = beta/6.0D0*(2.0d0*Sigma*gamDw0-3.0d0 *sigDw0), te1Dx0 = alpha/32.0D0*(2.0d0*Delta*delDx0-2.0d0*Del_3*delDx0), te2Dx0 = beta/6.0D0*(2.0d0*Sigma*gamDx0-3.0d0 *sigDx0), te1Du1 = alpha/32.0D0*(2.0d0*Delta*delDu1-2.0d0*Del_3*delDu1), te2Du1 = beta/6.0D0*(2.0d0*Sigma*gamDu1-3.0d0 *sigDu1), te1Dv1 = alpha/32.0D0*(2.0d0*Delta*delDv1-2.0d0*Del_3*delDv1), te2Dv1 = beta/6.0D0*(2.0d0*Sigma*gamDv1-3.0d0 *sigDv1), te1Dw1 = alpha/32.0D0*(2.0d0*Delta*delDw1-2.0d0*Del_3*delDw1), te2Dw1 = beta/6.0D0*(2.0d0*Sigma*gamDw1-3.0d0 *sigDw1), te1Dx1 = alpha/32.0D0*(2.0d0*Delta*delDx1-2.0d0*Del_3*delDx1), te2Dx1 = beta/6.0D0*(2.0d0*Sigma*gamDx1-3.0d0 *sigDx1), te1Du2 = alpha/32.0D0*(2.0d0*Delta*delDu2-2.0d0*Del_3*delDu2), te2Du2 = beta/6.0D0*(2.0d0*Sigma*gamDu2-3.0d0 *sigDu2), te1Dv2 = alpha/32.0D0*(2.0d0*Delta*delDv2-2.0d0*Del_3*delDv2), te2Dv2 = beta/6.0D0*(2.0d0*Sigma*gamDv2-3.0d0 *sigDv2), te1Dw2 = alpha/32.0D0*(2.0d0*Delta*delDw2-2.0d0*Del_3*delDw2), te2Dw2 = beta/6.0D0*(2.0d0*Sigma*gamDw2-3.0d0 *sigDw2), te1Dx2 = alpha/32.0D0*(2.0d0*Delta*delDx2-2.0d0*Del_3*delDx2), te2Dx2 = beta/6.0D0*(2.0d0*Sigma*gamDx2-3.0d0 *sigDx2), te1Du3 = alpha/32.0D0*(2.0d0*Delta*delDu3-2.0d0*Del_3*delDu3), te2Du3 = beta/6.0D0*(2.0d0*Sigma*gamDu3-3.0d0 *sigDu3), te1Dv3 = alpha/32.0D0*(2.0d0*Delta*delDv3-2.0d0*Del_3*delDv3), te2Dv3 = beta/6.0D0*(2.0d0*Sigma*gamDv3-3.0d0 *sigDv3), te1Dw3 = alpha/32.0D0*(2.0d0*Delta*delDw3-2.0d0*Del_3*delDw3), te2Dw3 = beta/6.0D0*(2.0d0*Sigma*gamDw3-3.0d0 *sigDw3), te1Dx3 = alpha/32.0D0*(2.0d0*Delta*delDx3-2.0d0*Del_3*delDx3), te2Dx3 = beta/6.0D0*(2.0d0*Sigma*gamDx3-3.0d0 *sigDx3), epDu0 = volA * ( te1Du0 + te2Du0 ), epDv0 = volA * ( te1Dv0 + te2Dv0 ), epDw0 = volA * ( te1Dw0 + te2Dw0 ), epDx0 = volA * ( te1Dx0 + te2Dx0 ), epDu1 = volA * ( te1Du1 + te2Du1 ), epDv1 = volA * ( te1Dv1 + te2Dv1 ), epDw1 = volA * ( te1Dw1 + te2Dw1 ), epDx1 = volA * ( te1Dx1 + te2Dx1 ), epDu2 = volA * ( te1Du2 + te2Du2 ), epDv2 = volA * ( te1Dv2 + te2Dv2 ), epDw2 = volA * ( te1Dw2 + te2Dw2 ), epDx2 = volA * ( te1Dx2 + te2Dx2 ), epDu3 = volA * ( te1Du3 + te2Du3 ), epDv3 = volA * ( te1Dv3 + te2Dv3 ), epDw3 = volA * ( te1Dw3 + te2Dw3 ), epDx3 = volA * ( te1Dx3 + te2Dx3 ), eDu0 = eDep * epDu0, eDv0 = eDep * epDv0, eDw0 = eDep * epDw0, eDx0 = eDep * epDx0, eDu1 = eDep * epDu1, eDv1 = eDep * epDv1, eDw1 = eDep * epDw1, eDx1 = eDep * epDx1, eDu2 = eDep * epDu2, eDv2 = eDep * epDv2, eDw2 = eDep * epDw2, eDx2 = eDep * epDx2, eDu3 = eDep * epDu3, eDv3 = eDep * epDv3, eDw3 = eDep * epDw3, eDx3 = eDep * epDx3 DO IF vVar[iu] THEN eDc[iu,0] := eDc[iu,0] + eDu0; eDc[iu,1] := eDc[iu,1] + eDu1; eDc[iu,2] := eDc[iu,2] + eDu2; eDc[iu,3] := eDc[iu,3] + eDu3; END; IF vVar[iv] THEN eDc[iv,0] := eDc[iv,0] + eDv0; eDc[iv,1] := eDc[iv,1] + eDv1; eDc[iv,2] := eDc[iv,2] + eDv2; eDc[iv,3] := eDc[iv,3] + eDv3; END; IF vVar[iw] THEN eDc[iw,0] := eDc[iw,0] + eDw0; eDc[iw,1] := eDc[iw,1] + eDw1; eDc[iw,2] := eDc[iw,2] + eDw2; eDc[iw,3] := eDc[iw,3] + eDw3; END; IF vVar[ix] THEN eDc[ix,0] := eDc[ix,0] + eDx0; eDc[ix,1] := eDc[ix,1] + eDx1; eDc[ix,2] := eDc[ix,2] + eDx2; eDc[ix,3] := eDc[ix,3] + eDx3; END; END END Distribute_eDep; BEGIN (* Clear potential energy accumulators: *) FOR j := 0 TO NP-1 DO ep[j] := 0.0d0 END; (* Accumulate potential energy of each tetrahedron *) FOR j := 0 TO NP-1 DO IF polyRelevant[j] THEN Accum_ep(j, ep[j]); END END; (* Compute energy "e" from polyhedrons determinants, and the gradient "eDdet": *) e := 0.0d0; FOR p := 0 TO NP-1 DO IF polyRelevant[p] THEN Accum_e_from_ep(ep[p], e, eDep[p]); ELSE eDep[p] := 0.0d0 END END; (* Now distribute "eDdet" over "eDc": *) FOR i := 0 TO NV-1 DO eDc[i] := LR4.T{0.0d0, ..} END; IF grad THEN FOR j := 0 TO NP-1 DO IF polyRelevant[j] THEN Distribute_eDep(j,eDep[j]) END END END END END END Eval; PROCEDURE Name(erg: T): TEXT = BEGIN RETURN "Elasticity(alpha:="&Fmt.LongReal(erg.alpha,Fmt.Style.Fix,prec:=2) & " beta:="&Fmt.LongReal(erg.beta,Fmt.Style.Fix,prec:=2)&")"; END Name; BEGIN END ElasticityEnergy. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/EquaAngleEnergy.m3 MODULE EquaAngleEnergy; IMPORT Triangulation, Math, LR4, Octf; FROM Triangulation IMPORT Topology, Ppos, Pneg, OrgV, Pair; FROM Energy IMPORT Coords, Gradient; FROM Octf IMPORT Fnext, Enext, Enext_1, Clock; TYPE BOOLS = ARRAY OF BOOLEAN; LONGS = ARRAY OF LONGREAL; DRF = REF ARRAY OF CARDINAL; Face = Triangulation.Face; Edge = Triangulation.Edge; FACES = ARRAY OF Face; Cosines = REF LONGS; Faces = REF FACES; REVEAL T = Public BRANDED OBJECT K: LONGREAL; (* The energy normalization factor *) top: Topology; (* The topology *) vVar: REF BOOLS; (* TRUE if vertex is variable *) edgeRelevant: REF BOOLS; (* TRUE if edge is relevant *) cosine: REF ARRAY OF Cosines; (* The diedral angles *) drf: DRF; (* The Facets Ring Degree for edge *) faces: REF ARRAY OF Faces; (* The faces-ring for edge *) eDcosine: REF ARRAY OF Cosines; (* (Work) Gradient of "e" rel. to the dihedral average angle "a". *) OVERRIDES init := Init; defTop := DefTop; defVar := DefVar; eval := Eval; name := Name; END; PROCEDURE Init(erg: T) : T = BEGIN RETURN erg END Init; PROCEDURE DefTop(erg: T; READONLY top: Topology) = BEGIN erg.top := top; erg.vVar := NEW(REF BOOLS, top.NV); erg.edgeRelevant := NEW(REF BOOLS, top.NE); erg.faces := CollectFacesRing(top); erg.drf := ComputeFaceRingDegree(erg.faces,top); erg.K := 1.0d0; erg.cosine := NEW(REF ARRAY OF Cosines, top.NE); erg.eDcosine := NEW(REF ARRAY OF Cosines, top.NE); FOR i := 0 TO top.NE-1 DO erg.cosine[i] := NEW(REF LONGS, erg.drf^[i]) END; FOR i := 0 TO top.NE-1 DO erg.eDcosine[i] := NEW(REF LONGS, erg.drf^[i]) END; (* Just in case the client forgets to call "defVar": *) FOR i := 0 TO top.NV-1 DO erg.vVar[i] := FALSE END; FOR i := 0 TO top.NE-1 DO erg.edgeRelevant[i] := FALSE END; END DefTop; PROCEDURE CollectFaces( READONLY e: Edge; READONLY top: Topology; ): REF FACES = VAR NT: CARDINAL := 0; ct : CARDINAL; BEGIN WITH NF = top.NF, t = NEW(REF ARRAY OF Face, NF)^ DO FOR i := 0 TO NF-1 DO ct := 0; WITH f = top.face[i], fun = f.vertex[0].num, fvn = f.vertex[1].num, fwn = f.vertex[2].num, eun = e.vertex[0].num, evn = e.vertex[1].num DO IF (fun = eun OR fun = evn) THEN INC(ct) END; IF (fvn = eun OR fvn = evn) THEN INC(ct) END; IF (fwn = eun OR fwn = evn) THEN INC(ct) END; IF ct = 2 THEN t[NT] := f; INC(NT); END; END; END; WITH r = NEW(REF ARRAY OF Face, NT) DO r^ := SUBARRAY(t,0,NT); RETURN r; END; END; END CollectFaces; PROCEDURE ComputeFaceRingDegree(READONLY faces: REF ARRAY OF Faces; READONLY top: Topology) : DRF = BEGIN WITH drf = NEW(DRF, top.NE) DO FOR l := 0 TO top.NE-1 DO WITH fie = faces[l] DO drf^[l] := NUMBER(fie^); END END; RETURN drf; END END ComputeFaceRingDegree; PROCEDURE CollectFacesRing(READONLY top: Topology) : REF ARRAY OF Faces = BEGIN WITH faces = NEW(REF ARRAY OF Faces, top.NE) DO FOR l := 0 TO top.NE-1 DO WITH e = top.edge[l], fie = CollectFaces(e,top) DO faces[l] := fie; END END; RETURN faces; END END CollectFacesRing; PROCEDURE DefVar(erg: T; READONLY variable: BOOLS) = VAR n : CARDINAL := 0; BEGIN (* This energy is computed only for edges that exist, have DegreeRingFacets three or more, and have only existing faces and vertices incident to them. *) WITH NV = erg.top.NV, NE = erg.top.NE, vVar = erg.vVar^, edge = erg.top.edge^, edgeRelevant = erg.edgeRelevant^, drf = erg.drf^, faces = erg.faces^ DO <* ASSERT NUMBER(variable) = NV *> vVar := variable; (* Find the relevant edges: *) FOR i := 0 TO NE-1 DO edgeRelevant[i] := FALSE; END; VAR fexists,pexists,interface,interpoly: BOOLEAN; BEGIN FOR i := 0 TO NE-1 DO WITH e = edge[i], u = e.vertex[0], v = e.vertex[1], vvar = vVar[u.num] OR vVar[v.num], de = drf[e.num], cf = faces[e.num] DO FOR j := 0 TO de-1 DO WITH f1 = cf^[j], a = f1.pa^, aPpos = Ppos(a), aPneg = Pneg(a) DO IF( aPpos # NIL) AND (aPneg # NIL) THEN interpoly := TRUE; ELSE interpoly := FALSE; END; IF f1.exists THEN interface := TRUE; ELSE interface := FALSE; END; fexists := f1.exists AND pexists; END; fexists := TRUE AND interface; pexists := TRUE AND interpoly; END; IF e.exists AND fexists AND pexists AND vvar AND ( de >= 3 ) THEN WITH u = NARROW(u, Triangulation.Vertex), v = NARROW(v, Triangulation.Vertex) DO <* ASSERT u.exists AND v.exists *> END; edgeRelevant[i] := TRUE; INC(n); ELSE edgeRelevant[i] := FALSE; END END END END END END DefVar; PROCEDURE Eval( erg: T; READONLY c: Coords; VAR e: LONGREAL; grad: BOOLEAN; VAR eDc: Gradient; ) = BEGIN WITH NV = erg.top.NV, NE = erg.top.NE, edge = erg.top.edge^, edgeRelevant = erg.edgeRelevant^, cosine = erg.cosine^, K = erg.K, drf = erg.drf^, faces = erg.faces^, eDcosine = erg.eDcosine^, vVar = erg.vVar DO PROCEDURE Compute_cosine( READONLY f1,f2: Pair; VAR cos: LONGREAL; ) = (* Compute the diedral angle between the faces f1 and f2. *) BEGIN WITH a = f1, b = f2, ao = OrgV(a).num, ad = OrgV(Enext(a)).num, ae = OrgV(Enext_1(a)).num, bo = OrgV(b).num, bd = OrgV(Enext(b)).num, be = OrgV(Enext_1(b)).num, v1a = LR4.Sub(c[ad],c[ao]), v2a = LR4.Sub(c[ae],c[ao]), v1b = LR4.Sub(c[bd],c[bo]), v2b = LR4.Sub(c[be],c[bo]), p1 = FindOrthogonal(v1a,v2a), p2 = FindOrthogonal(v1b,v2b), m = LR4.Norm(p1), n = LR4.Norm(p2), o = LR4.Dot(p1,p2), d = m * n DO <* ASSERT (ao = bo) AND (ad = bd) *> cos := o/d; (*Wr.PutText(stderr, Fmt.LongReal(cos) & "\n");*) END END Compute_cosine; PROCEDURE FindOrthogonal(READONLY v1,v2: LR4.T) : LR4.T = (* compute a orthogonal vector to v1, by the Gram-Schmidt decomposition. *) BEGIN WITH u1 = v1, v2_u1 = LR4.Project(v2,u1), u2 = LR4.Sub(v2,v2_u1) DO RETURN u2; END END FindOrthogonal; PROCEDURE Accum_e_from_cosine( cos: LONGREAL; d: CARDINAL; VAR eDcos: LONGREAL; ) = (* Adds to "e" the energy term corresponding to dihedral average angle "a". *) BEGIN WITH thetan = 2.0d0 * FLOAT(Math.Pi,LONGREAL), theta = thetan/FLOAT(d, LONGREAL), cosideal = Math.cos(theta), sinideal = Math.sin(theta), cos2 = cos * cos, sqr = Math.sqrt(1.0d0-cos2), first = cosideal * cos, secon = sinideal * sqr, nund = sinideal * cos, firstd = nund/sqr DO e := e + K * ( 1.0d0 - 2.0d0 * (first+secon) ); IF grad THEN eDcos:= 2.0d0 * (firstd - cosideal); ELSE eDcos := 0.0d0; END END END Accum_e_from_cosine; PROCEDURE Distribute_eDcosine( READONLY f1,f2: Pair; READONLY eDcos: LONGREAL; ) = VAR eDv1a,eDv2a,eDv2b,eDp1,eDp2: LR4.T; BEGIN WITH a = f1, b = f2, ao = OrgV(a).num, ad = OrgV(Enext(a)).num, ae = OrgV(Enext_1(a)).num, be = OrgV(Enext_1(b)).num, v1a = LR4.Sub(c[ad],c[ao]), v2a = LR4.Sub(c[ae],c[ao]), v2b = LR4.Sub(c[be],c[ao]), p1 = FindOrthogonal(v1a,v2a), p2 = FindOrthogonal(v1a,v2b), m = LR4.Norm(p1), n = LR4.Norm(p2), o = LR4.Dot(p1,p2), d = m * n, q = o/d, f1 = LR4.Cos(v2a,v1a), f2 = LR4.Cos(v2b,v1a), eDo = eDcos/d, eDd = - eDcos * q / d, eDm = eDd * n, eDn = eDd * m DO eDp1 := LR4.Mix(eDo, p2, eDm/m, p1); eDp2 := LR4.Mix(eDo, p1, eDn/n, p2); eDv1a := LR4.Mix(-f1,eDp1,-f2,eDp2); eDv2a := LR4.Neg(eDp1); eDv2b := LR4.Neg(eDp2); IF grad THEN IF vVar[ao] THEN eDc[ao]:= LR4.Sub(eDc[ao],LR4.Add(LR4.Add(eDv1a,eDv2a),eDv2b)); END; IF vVar[ad] THEN eDc[ad] := LR4.Add(eDc[ad],eDv1a); END; IF vVar[ae] THEN eDc[ae] := LR4.Add(eDc[ae],eDv2a); END; IF vVar[be] THEN eDc[be] := LR4.Add(eDc[be],eDv2b); END END END END Distribute_eDcosine; BEGIN (* Clear dihedral angle and their derivative accumulators: *) FOR j := 0 TO NE-1 DO FOR i := 0 TO drf[j]-1 DO cosine[j,i] := 0.0d0; eDcosine[j,i] := 0.0d0; END END; FOR i:= 0 TO NV-1 DO eDc[i] := LR4.T{0.0d0,0.0d0,0.0d0,0.0d0}; END; (* Enumerate edges and accumulate diedral angles: *) FOR j := 0 TO NE-1 DO IF edgeRelevant[j] THEN WITH e = edge[j], eun = e.vertex[0].num, evn = e.vertex[1].num, fie = faces[e.num] DO VAR ao,a: Pair; i: CARDINAL:= 0; BEGIN ao := fie[0].pa^; a := ao; REPEAT WITH a00 = OrgV(a).num, a11 = OrgV(Clock(a)).num, b = Fnext(a) DO <* ASSERT ((a00 = eun) OR (a00 = evn)) AND ((a11 = eun) OR (a11 = evn)) *> Compute_cosine(a,b,cosine[j,i]); INC(i); a := b; END; UNTIL ( a = ao ) END END END END; (* Compute energy "e" from dihedral angles, and the gradient "eDda": *) e := 0.0d0; FOR j := 0 TO NE-1 DO WITH ee = edge[j], fie = faces[ee.num], de = drf[ee.num] DO IF edgeRelevant[j] THEN FOR i := 0 TO de-1 DO WITH f1 = fie[i], af1 = f1.pa^, af2 = Fnext(af1) DO Accum_e_from_cosine(cosine[j,i],de,eDcosine[j,i]); IF grad THEN Distribute_eDcosine(af1,af2,eDcosine[j,i]); END END END END END END END END END Eval; PROCEDURE Name(<* UNUSED *> erg: T): TEXT = BEGIN RETURN "Angle()"; END Name; BEGIN END EquaAngleEnergy. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/ExcenEnergy.m3 MODULE ExcenEnergy; IMPORT LR4, Triangulation; FROM Triangulation IMPORT Topology, OrgV; FROM Octf IMPORT Clock; FROM Energy IMPORT Coords, Gradient; REVEAL T = Public BRANDED OBJECT top: Topology; K: LONGREAL; (* Energy normalization factor *) vVar: REF ARRAY OF BOOLEAN; (* Tells which vertices are variable *) termVar: REF ARRAY OF BOOLEAN; (* Tells which terms are variable *) deg: REF ARRAY OF CARDINAL; (* Effective degree of each vertex *) org, dst: REF ARRAY OF CARDINAL; (* Directed edges of computed terms *) NP: CARDINAL; (* Number of edges in "org", "dst" *) sum: REF ARRAY OF LR4.T; (* (Work) Sum of effective neighbors *) eDsum: REF ARRAY OF LR4.T; (* (Work) Gradient of "e" rel "sum" *) OVERRIDES init := Init; defTop := DefTop; defVar := DefVar; eval := Eval; name := Name; END; CONST Zero = LR4.T{0.0d0, 0.0d0, 0.0d0, 0.0d0}; PROCEDURE Init(erg: T): T = BEGIN RETURN erg END Init; PROCEDURE DefTop(erg: T; READONLY top: Topology) = BEGIN erg.top := top; erg.K := FLOAT(top.NV, LONGREAL); erg.vVar := NEW(REF ARRAY OF BOOLEAN, top.NV); erg.termVar := NEW(REF ARRAY OF BOOLEAN, top.NV); erg.deg := NEW(REF ARRAY OF CARDINAL, top.NV); erg.org := NEW(REF ARRAY OF CARDINAL, 2*top.NE); erg.dst := NEW(REF ARRAY OF CARDINAL, 2*top.NE); erg.sum := NEW(REF ARRAY OF LR4.T, top.NV); erg.eDsum := NEW(REF ARRAY OF LR4.T, top.NV); (* In case the client forgets to call "defVar": *) erg.NP := 0; FOR i := 0 TO top.NV-1 DO erg.vVar[i] := FALSE; erg.termVar[i] := FALSE END; END DefTop; PROCEDURE DefVar(erg: T; READONLY variable: ARRAY OF BOOLEAN) = BEGIN (* Decide which terms are variable, and compute effective degrees "erg.deg[v]". There is a term for each existing vertex. The term of "v" is variable if "v" is variable or has some effective neighbor that is variable. *) WITH NP = erg.NP, NV = erg.top.NV, NE = erg.top.NE, edge = erg.top.edge^, vVar = erg.vVar^, termVar = erg.termVar^, org = erg.org^, dst = erg.dst^, deg = erg.deg^ DO <* ASSERT NUMBER(variable) = NV *> vVar := variable; (* If a vertex is vVar, its term is vVar: *) FOR v := 0 TO NV-1 DO termVar[v] := vVar[v]; deg[v] := 0 END; (* Enumerate effective edges and accumulate efective degrees. *) (* Also set "termVar[v]" if "v" has a vVar effective neighbor. *) FOR i := 0 TO NE-1 DO WITH e = edge[i], u = NARROW(OrgV(e.pa), Triangulation.Vertex), v = NARROW(OrgV(Clock(e.pa)), Triangulation.Vertex), un = u.num, vn = v.num DO INC(deg[un]); INC(deg[vn]); termVar[un] := termVar[un] OR vVar[vn]; termVar[vn] := termVar[vn] OR vVar[un]; END END; (* A vertex with no effective neighbors (deg[v]=0) has energy zero by definition (termVar[v]=FALSE): *) FOR v := 0 TO NV-1 DO IF deg[v] = 0 THEN termVar[v] := FALSE END END; (* Now collect all efective directed edges "(org[k], dst[k])" *) (* whose origin "org[k]" is variable: *) NP := 0; FOR i := 0 TO NE-1 DO WITH e = edge[i], u = OrgV(e.pa), un = u.num, v = OrgV(Clock(e.pa)), vn = v.num DO IF termVar[un] THEN org[NP] := un; dst[NP] := vn; INC(NP) END; IF termVar[vn] THEN org[NP] := vn; dst[NP] := un; INC(NP) END; END END; END END DefVar; PROCEDURE Eval( erg: T; READONLY c: Coords; VAR e: LONGREAL; grad: BOOLEAN; VAR eDc: Gradient; ) = BEGIN WITH NP = erg.NP, NV = erg.top.NV, vVar = erg.vVar^, termVar = erg.termVar^, deg = erg.deg^, org = erg.org^, dst = erg.dst^, sum = erg.sum^, eDsum = erg.eDsum^, K = erg.K DO PROCEDURE Compute_sum () = (* Computes "sum[v]" for all relevant terms "v" *) BEGIN FOR v := 0 TO NV-1 DO IF termVar[v] THEN sum[v] := Zero END END; FOR i := 0 TO NP-1 DO WITH v = org[i], u = dst[i] DO <* ASSERT termVar[v] *> sum[v] := LR4.Add(sum[v], c[u]) END END END Compute_sum; PROCEDURE EvalTerm( READONLY cv, sumv: LR4.T; degv: CARDINAL; VAR ev: LONGREAL; VAR evDcv, evDsumv: LR4.T; ) = (* Computes the energy term "ev" for a vertex at "cv", given the sum of its "relevant neighbors" "sumv". Returns also the gradients "evDcv" and "evDsumv" of "ev" relative to "cv" and "sumv". *) BEGIN WITH f = 1.0d0/FLOAT(degv, LONGREAL), barv = LR4.Scale(f, sumv), rv = LR4.Sub(cv, barv) DO ev := K * LR4.NormSqr(rv); IF grad THEN evDcv := LR4.Scale(2.0d0 * K, rv); evDsumv := LR4.Scale(-2.0d0 * f * K, rv) ELSE evDcv := Zero; evDsumv := Zero END END END EvalTerm; PROCEDURE Distribute_eDsum () = (* Adds to the derivatives "eDc[u]" the indirect terms represented by "eDsum[v]", for all computed terms "v" that have "u" as a relevant neighbor. *) BEGIN FOR i := 0 TO NP-1 DO WITH v = org[i], u = dst[i] DO IF vVar[u] THEN eDc[u] := LR4.Add(eDc[u], eDsum[v]) END END END; END Distribute_eDsum; VAR ev: LONGREAL; BEGIN Compute_sum(); e := 0.0d0; FOR v := 0 TO NV-1 DO IF termVar[v] THEN EvalTerm(c[v], sum[v], deg[v], ev, eDc[v], eDsum[v]); e := e + ev ELSE eDc[v] := Zero; END; END; IF grad THEN Distribute_eDsum() END END; END END Eval; PROCEDURE Name(<*UNUSED*> erg: T): TEXT = BEGIN RETURN "Excen()" END Name; BEGIN END ExcenEnergy. (* Last edited on 2001-05-21 02:29:39 by stolfi *) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Heuristic.m3 MODULE Heuristic; IMPORT Triangulation, Random; FROM Triangulation IMPORT Topology, Coords, Pair, OrgV; PROCEDURE DisplaceVertex( a: Pair; VAR c: Coords; READONLY variable: BOOLS; READONLY top: Topology; <* UNUSED *> coins : Random.T; ) = BEGIN WITH u = OrgV(a), un = u.num, star = Triangulation.Neighbors(a,top), bar = Triangulation.NeighborBarycenter(star,c), bar0 = bar[0], bar1 = bar[1], bar2 = bar[2], bar3 = bar[3] DO IF variable[un] AND u.exists THEN WITH cun = c[un] DO cun[0] := bar0; cun[1] := bar1; cun[2] := bar2; cun[3] := bar3; END END END END DisplaceVertex; BEGIN END Heuristic. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Heuristics.m3 MODULE Heuristics; (*IMPORT Octf, Triangulation, LR4, LR4Extras, LR4x4, Random, Math, Debug, LRN;*) IMPORT Triangulation, Wr, Stdio, Fmt; FROM Triangulation IMPORT Pair, Coords, OrgV, Topology; CONST debug = FALSE; TYPE Vertex = Triangulation.Vertex; Face = Triangulation.Face; Edge = Triangulation.Edge; EDGES = ARRAY OF Edge; FACES = ARRAY OF Face; Faces = REF FACES; DRF = REF ARRAY OF CARDINAL; (* PROCEDURE Dir(v: LR4.T): LR4.T = (* Same as LR4.Dir(v), but returns random unit vector if "v" is zero. *) BEGIN WITH s = LR4.Norm(v) DO IF s = 0.0d0 THEN RETURN LR4.T{1.0d0, 0.0d0, 0.0d0, 0.0d0} ELSE RETURN LR4.Scale(1.0d0/s, v) END END END Dir; PROCEDURE ChooseReferenceVertex( a: Pair; READONLY variable: BOOLS; coins: Random.T ): Vertex = (* If any of the edges out of "Org(a)" has a fixed tip, picks one such edge, with probability proportional to the number of "Onext"s until the next fixed edge. Otherwise picks a random arc out of "Org(a)". *) VAR v : REF ARRAY OF Vertex; BEGIN WITH star = Triangulation.NeighborVertex(a,top), nv = Triangulation.NumberNeighborVertex(star), k = coins.integer(0, nv-1) DO v := NEW(REF ARRAY OF Vertex, nv); FOR j := 0 TO nv-1 DO v[j] := star[j]; END; FOR i := 0 TO k-1 DO IF NOT variable[v[i].num] THEN RETURN a END; a := Oprev(a) END; RETURN a END END ChooseReferenceArc; *) PROCEDURE CollectEdges(READONLY u: Vertex; READONLY top: Topology): REF EDGES = VAR NT: CARDINAL := 0; BEGIN WITH NE = top.NE, t = NEW(REF ARRAY OF Edge, NE)^ DO FOR i := 0 TO NE-1 DO WITH e = top.edge[i], eun = e.vertex[0].num, evn = e.vertex[1].num DO IF (eun = u.num OR evn = u.num) THEN t[NT] := e; INC(NT); END; END; END; WITH r = NEW(REF ARRAY OF Edge, NT) DO r^ := SUBARRAY(t,0,NT); RETURN r; END; END; END CollectEdges; PROCEDURE CollectFaces(READONLY e: Edge; READONLY top: Topology): REF FACES = VAR NT: CARDINAL := 0; ct : CARDINAL; BEGIN WITH NF = top.NF, t = NEW(REF ARRAY OF Face, NF)^ DO FOR i := 0 TO NF-1 DO ct := 0; WITH f = top.face[i], fun = f.vertex[0].num, fvn = f.vertex[1].num, fwn = f.vertex[2].num, eun = e.vertex[0].num, evn = e.vertex[1].num DO IF (fun = eun OR fun = evn) THEN INC(ct) END; IF (fvn = eun OR fvn = evn) THEN INC(ct) END; IF (fwn = eun OR fwn = evn) THEN INC(ct) END; IF ct = 2 THEN t[NT] := f; INC(NT); END; END; END; WITH r = NEW(REF ARRAY OF Face, NT) DO r^ := SUBARRAY(t,0,NT); RETURN r; END; END; END CollectFaces; <* UNUSED *> PROCEDURE ComputeFaceRingDegree(READONLY faces: REF ARRAY OF Faces; READONLY top: Topology) : DRF = BEGIN WITH drf = NEW(DRF, top.NE) DO FOR l := 0 TO top.NE-1 DO WITH fie = faces[l] DO drf^[l] := NUMBER(fie^); END END; RETURN drf; END END ComputeFaceRingDegree; <* UNUSED *> PROCEDURE CollectFacesRing(READONLY top: Topology) : REF ARRAY OF Faces = BEGIN WITH faces = NEW(REF ARRAY OF Faces, top.NE) DO FOR l := 0 TO top.NE-1 DO WITH e = top.edge[l], fie = CollectFaces(e,top) DO faces[l] := fie; END END; RETURN faces; END END CollectFacesRing; <* UNUSED *> PROCEDURE ComputeFaceRingDegreeTotal(READONLY drf: DRF) : LONGREAL = VAR n : CARDINAL := 0; BEGIN FOR l := 0 TO LAST(drf^) DO WITH d = drf^[l] DO n := n + d; END; END; RETURN FLOAT(n, LONGREAL); END ComputeFaceRingDegreeTotal; PROCEDURE EquaAngle( a: Pair; VAR c: Coords; READONLY variable: BOOLS; READONLY top : Topology; ) = BEGIN WITH u = OrgV(a), edges = CollectEdges(u,top) DO FOR j := 0 TO LAST(edges^) DO WITH e = edges^[j], fe = CollectFaces(e,top) DO EqualizeDiedralAngle(e,fe,c,u); END END END END EquaAngle; PROCEDURE EqualizeDiedralAngle(e : Edge; READONLY f : REF FACES; VAR c : Coords; READONLY u : Vertex ) = BEGIN WITH eu = e.vertex[0], ev = e.vertex[1], m = NUMBER(f^), angle = 2.0d0 * FLOAT(Math.Pi, LONGREAL)/FLOAT(m, LONGREAL), DO FOR i := 0 TO m-1 DO WITH vx = END EqualizeDiedralAngle; <* UNUSED *> PROCEDURE CollectWingPoint(READONLY ff: REF FACES; READONLY e : Edge; ) : REF ARRAY OF CARDINAL = (* Retorna para cada aresta o conjunto de vertices dobradicas *) CONST IniStackSize = 10000; VAR stack := NEW(REF ARRAY OF CARDINAL,IniStackSize); nstack: CARDINAL := 0; PROCEDURE Present(n : CARDINAL ) : BOOLEAN = VAR nstack1: CARDINAL := nstack; BEGIN WHILE nstack1 > 0 DO nstack1 := nstack1 - 1; IF stack[nstack1] = n THEN RETURN TRUE END; END; RETURN FALSE; END Present; BEGIN WITH fi = ff^[0], wingi = WingPoint(e,fi) DO stack[nstack] := wingi; INC(nstack); END; FOR i := 1 TO LAST(ff^) DO WITH f = ff^[i], wing = WingPoint(e,f) DO IF NOT Present(wing) THEN stack[nstack] := wing; INC(nstack) END; END END; WITH r = NEW(REF ARRAY OF CARDINAL, nstack) DO r^ := SUBARRAY(stack^, 0, nstack); RETURN r; END; END CollectWingPoint; PROCEDURE WingPoint(READONLY e: Edge; READONLY f: Face) : CARDINAL = VAR wp : CARDINAL; BEGIN WITH eun = e.vertex[0].num, evn = e.vertex[1].num, fn = f.vertex DO FOR i := 0 TO 2 DO IF (fn[i].num # eun AND fn[i].num # evn) THEN wp := fn[i].num; END END END; RETURN wp; END WingPoint; (* PROCEDURE FlattenVertex( a: Arc; VAR c: Coords; READONLY variable: BOOLS; <*UNUSED*> coins: Random.T; ) = VAR somaki: LONGREAL := 0.0d0; somakiti: LONGREAL := 0.0d0; N: CARDINAL := 0; PROCEDURE CalcTi(READONLY bar: LR3.T; e: Arc) = (* Computes the pseudo-force "ti" and its weight "ki" and accumulates them in "somatiki", "somaki" *) BEGIN (* Check if hinge exists and has a spring: *) WITH b = Oprev(Sym(e)), be = NARROW(b.edge, Triang.Edge), bl = LeftF(b), br = LeftF(Sym(b)) DO IF NOT (bl.exists AND br.exists AND be.spring) THEN RETURN END END; (* Do the computations: *) WITH f = Onext(e), p = OrgV(Sym(e)).num, q = OrgV(Sym(f)).num, w = OrgV(Sym(Onext(Onext(Sym(f))))).num, di = LR3.Sub(c[q], c[p]), ni = LR3Extras.Cross(di, LR3.Sub(bar, c[q])), mi = LR3Extras.Cross(LR3.Sub(c[w], c[p]), di), dimod = LR3.Norm(di), nimod = LR3.Norm(ni), mimod = LR3.Norm(mi), sinTheta = LR3x3.Det(LR3x3.T{ni, mi, di}) / (nimod*mimod*dimod), cosTheta = LR3.Cos(ni, mi), theta = Math.atan2(sinTheta, cosTheta), feta = ThetaFunc(theta), ki = dimod, ti = feta * nimod / dimod DO IF debug THEN Debug.LongReal("CalcTi: ni = ", ni); Debug.LongReal(" mi = ", mi); Debug.LongReal(" di = ", di); Debug.LongReal(" sin, cos = ", LRN.T{sinTheta, cosTheta}); Debug.LongReal(" theta, feta = ", LRN.T{theta, feta}); Debug.LongReal(" ki, ti = ", LRN.T{ki, ti}); END; somaki := somaki + ki; somakiti := somakiti + ki * ti; N := N+1; END; END CalcTi; PROCEDURE ThetaFunc(Theta: LONGREAL): LONGREAL = CONST PPi = FLOAT(Math.Pi, LONGREAL); PiCube = PPi * PPi * PPi; B = 0.5d0; A = (1.0d0 - B*PPi) / PiCube; BEGIN WITH ThetaCube = Theta * Theta * Theta DO RETURN A * ThetaCube + B * Theta END END ThetaFunc; VAR an: Arc; BEGIN WITH vx = OrgV(a), v = vx.num, bar = Triang.NeighborBarycenter(a, c), n = Triang.VertexNormal(a, c) DO IF NOT variable[v] AND vx.exists THEN RETURN END; IF debug THEN Debug.LongReal(" bar = ", bar) END; an := a; REPEAT CalcTi(bar, an); an := Onext(an) UNTIL (an = a); WITH t = somakiti / somaki, ao = OrgV(a).num, u = LR3.Add(bar, LR3.Scale(t, n)) DO IF debug THEN Debug.LongReal(" t = ", LRN.T{t}); Debug.LongReal(" n = ", n); Debug.LongReal(" u = ", u); END; c[ao] := u; END; END; END FlattenVertex; *) BEGIN END Heuristics. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/HingeEnergy.m3 MODULE HingeEnergy; IMPORT Triangulation, Math, LR4; FROM Triangulation IMPORT Topology, FaceBarycenter; FROM Energy IMPORT Coords, Gradient; TYPE BOOLS = ARRAY OF BOOLEAN; LONGS = ARRAY OF LONGREAL; DRF = REF ARRAY OF CARDINAL; EndPoints = ARRAY [0..1] OF CARDINAL; Face = Triangulation.Face; Edge = Triangulation.Edge; FACES = ARRAY OF Face; Faces = REF FACES; REVEAL T = Public BRANDED OBJECT K: LONGREAL; (* The energy normalization factor *) top: Topology; (* The topology *) vVar: REF BOOLS; (* TRUE if vertex is variable *) edgeRelevant: REF BOOLS; (* TRUE if edge is relevant *) da: REF LONGS; (* The average diedral angles *) drf: DRF; (* The Facets Ring Degreee for edge*) faces: REF ARRAY OF Faces; (* The faces-ring for edge *) zmDbe : REF ARRAY OF LR4.T; OVERRIDES init := Init; defTop := DefTop; defVar := DefVar; eval := Eval; name := Name; END; PROCEDURE Init(erg: T) : T = BEGIN RETURN erg END Init; PROCEDURE DefTop(erg: T; READONLY top: Topology) = BEGIN WITH NP = FLOAT(top.NP,LONGREAL) DO erg.top := top; erg.vVar := NEW(REF BOOLS, top.NV); erg.edgeRelevant := NEW(REF BOOLS, top.NE); erg.faces := CollectFacesRing(top); erg.drf := ComputeFaceRingDegree(erg.faces,top); erg.K := 1.0d0/(2.0d0*Math.pow(NP,5.0d0/3.0d0)); (* Allocate average dihedral angle tables: *) erg.da := NEW(REF LONGS, top.NE); erg.zmDbe := NEW(REF ARRAY OF LR4.T, top.NE); (* Just in case the client forgets to call "defVar": *) FOR i := 0 TO top.NV-1 DO erg.vVar[i] := FALSE END; FOR i := 0 TO top.NE-1 DO erg.edgeRelevant[i] := FALSE END; END; END DefTop; PROCEDURE CollectFaces(READONLY e: Edge; READONLY top: Topology): REF ARRAY OF Face = (* Return the set of faces incidents to edge "e" *) VAR NT: CARDINAL := 0; ct : CARDINAL; BEGIN WITH NF = top.NF, t = NEW(REF ARRAY OF Face, NF)^ DO FOR i := 0 TO NF-1 DO ct := 0; WITH f = top.face[i], fn = f.vertex, eun = e.vertex[0].num, evn = e.vertex[1].num DO FOR j := 0 TO 2 DO IF (fn[j].num = eun OR fn[j].num = evn) THEN INC(ct) END; END; IF ct = 2 THEN t[NT] := f; INC(NT); END; END; END; WITH r = NEW(REF ARRAY OF Face, NT) DO r^ := SUBARRAY(t,0,NT); RETURN r; END; END; END CollectFaces; PROCEDURE ComputeFaceRingDegree(READONLY faces: REF ARRAY OF Faces; READONLY top: Topology) : DRF = BEGIN WITH drf = NEW(DRF, top.NE) DO FOR l := 0 TO top.NE-1 DO WITH fie = faces[l] DO drf^[l] := NUMBER(fie^); END END; RETURN drf; END END ComputeFaceRingDegree; PROCEDURE CollectFacesRing(READONLY top: Topology) : REF ARRAY OF Faces = BEGIN WITH faces = NEW(REF ARRAY OF Faces, top.NE) DO FOR l := 0 TO top.NE-1 DO WITH e = top.edge[l], fie = CollectFaces(e,top) DO faces[l] := fie; END END; RETURN faces; END END CollectFacesRing; <* UNUSED *> PROCEDURE ComputeFaceRingDegreeTotal(READONLY drf: DRF) : LONGREAL = VAR n : CARDINAL := 0; BEGIN FOR l := 0 TO LAST(drf^) DO WITH d = drf^[l] DO n := n + d; END; END; RETURN FLOAT(n, LONGREAL); END ComputeFaceRingDegreeTotal; PROCEDURE DefVar(erg: T; READONLY variable: BOOLS) = BEGIN (* This energy is computed only for edges that have the "hinge" bit set, have DegreeRingFacets three or more, and have only existing faces and variable vertices incident to them. *) WITH NV = erg.top.NV, NE = erg.top.NE, vVar = erg.vVar^, edge = erg.top.edge^, edgeRelevant = erg.edgeRelevant^, drf = erg.drf^, faces = erg.faces^ DO <* ASSERT NUMBER(variable) = NV *> vVar := variable; (* Find the relevant edges: *) FOR i := 0 TO NE-1 DO edgeRelevant[i] := FALSE; END; VAR fexists: BOOLEAN := TRUE; BEGIN FOR i := 0 TO NE-1 DO WITH e = edge[i], u = e.vertex[0], v = e.vertex[1], vvar = vVar[u.num] OR vVar[v.num], de = drf[e.num], cf = faces[e.num] DO FOR j := 0 TO de-1 DO WITH f1 = cf^[j], f2 = cf^[(j+1) MOD de] DO fexists := (f1.exists AND f2.exists) AND fexists; END; END; IF e.hinge AND fexists AND vvar AND ( de >= 3 ) THEN WITH u = NARROW(u, Triangulation.Vertex), v = NARROW(v, Triangulation.Vertex) DO <* ASSERT e.exists *> <* ASSERT u.exists AND v.exists *> END; edgeRelevant[i] := TRUE; ELSE edgeRelevant[i] := FALSE; END END END END END END DefVar; PROCEDURE Eval( erg: T; READONLY c: Coords; VAR e: LONGREAL; grad: BOOLEAN; VAR eDc: Gradient; ) = BEGIN WITH NV = erg.top.NV, NE = erg.top.NE, edge = erg.top.edge^, edgeRelevant = erg.edgeRelevant^, da = erg.da^, K = erg.K, drf = erg.drf^, faces = erg.faces^, vVar = erg.vVar^, zmDbe = erg.zmDbe^ DO PROCEDURE ExtremusEdge(READONLY e: Edge) : EndPoints = VAR stack : EndPoints; BEGIN WITH eun = e.vertex[0].num, evn = e.vertex[1].num DO stack[0] := eun; stack[1] := evn; RETURN stack; END; END ExtremusEdge; PROCEDURE ComputeAverageDiedralAngle(READONLY e: Edge; VAR zm : LONGREAL; VAR zmDbe: LR4.T) = VAR z : LONGREAL; zDbe : LR4.T; BEGIN WITH fie = faces[e.num], de = drf[e.num], del = FLOAT(de, LONGREAL), bi = ExtremusEdge(e) DO zm := 0.0d0; zmDbe := LR4.T{0.0d0, ..}; FOR i := 0 TO de-1 DO WITH f1 = fie[i], af1 = f1.pa^, f2 = fie[(i+1) MOD de], af2 = f2.pa^, bf1 = FaceBarycenter(af1,c), bf2 = FaceBarycenter(af2,c) DO Compute_z(bf1,bf2,bi,z, zDbe); zm := zm + z; zmDbe := LR4.Add(zmDbe, zDbe); END END; zm := zm/del; zmDbe := LR4.Scale(1.0d0/del, zmDbe); END END ComputeAverageDiedralAngle; PROCEDURE Compute_z(READONLY bf1,bf2: LR4.T; READONLY e: EndPoints; VAR z : LONGREAL; VAR zDbe: LR4.T) = (* Compute the diedral angle between the faces planes f1 and f2. *) BEGIN WITH u = e[0], v = e[1], be = LR4.Scale(1.0d0/2.0d0, LR4.Add(c[u],c[v])), a = LR4.Sub(be,bf1), b = LR4.Sub(be,bf2), m = LR4.Norm(a), n = LR4.Norm(b), d = m * n, o = LR4.Dot(a,b), q = o/d DO z := Math.sqrt( 2.0d0 * (1.0d0-q)); (* Aproximation *) IF grad THEN WITH zDq = - 2.0d0, zDo = zDq /d, zDd = - zDq * q / d, zDm = zDd * n, zDn = zDd * m, zDa = LR4.Mix(zDo, b, zDm/m, a), zDb = LR4.Mix(zDo, a, zDn/n, b) DO zDbe := LR4.Neg(LR4.Add(zDa, zDb)); END END END END Compute_z; PROCEDURE Accum_e_from_ee(zm: LONGREAL; d: CARDINAL; VAR e: LONGREAL; VAR eDzm: LONGREAL) = (* Adds to "e" the energy term corresponding to hinge edge with endpoints "e" and average dihedral angle "zm". *) BEGIN WITH idealtetha = 360.0d0/FLOAT(d, LONGREAL), tetha = ABS(zm-idealtetha) DO e := e + K * tetha; IF grad THEN eDzm := K; ELSE eDzm := 0.0d0; END END END Accum_e_from_ee; PROCEDURE Distribute_eDzm(u,v: CARDINAL; READONLY eDzm: LONGREAL; READONLY zmDbe: LR4.T) = (* Distribute eDzm on endpoints "c[u]" and "c[v]" *) BEGIN WITH eDv = eDc[v], eDu = eDc[u], eDbe = LR4.Scale(eDzm, zmDbe) DO WITH eDcu = LR4.Scale(1.0d0/2.0d0, eDbe), eDcv = LR4.Scale(1.0d0/2.0d0, eDbe) DO IF vVar[v] THEN eDv := LR4.Add(eDv, eDcv); END; IF vVar[u] THEN eDu := LR4.Add(eDu, eDcu); END END END; END Distribute_eDzm; VAR eDzm : LONGREAL; BEGIN (* Clear average dihedral angle accumulators: *) FOR j := 0 TO NE-1 DO da[j] := 0.0d0; zmDbe[j] := LR4.T{0.0d0,.. } END; (* Enumerate edges and accumulate diedral angles: *) FOR j := 0 TO NE-1 DO IF edgeRelevant[j] THEN WITH e = edge[j] DO ComputeAverageDiedralAngle(e, da[j], zmDbe[j]); END END END; (* Compute energy "e" from dihedral angles, and the gradient "eDvp": *) FOR i:= 0 TO NV-1 DO eDc[i] := LR4.T{0.0d0,..} END; e := 0.0d0; FOR j := 0 TO NE-1 DO WITH ee = edge[j], de = drf[ee.num], un = ee.vertex[0].num, vn = ee.vertex[1].num DO IF edgeRelevant[j] THEN Accum_e_from_ee(da[j],de,e,eDzm); IF grad THEN Distribute_eDzm(un, vn, eDzm, zmDbe[j]); END END END END END END END Eval; PROCEDURE Name(<* UNUSED *> erg: T): TEXT = BEGIN RETURN "Hinge()"; END Name; BEGIN END HingeEnergy. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/JSTriangulation.m3 MODULE Triangulation; (* This module contain essentially procedures created by R. Marcone and J. Stolfi (see the copyright and authorship futher down), modified extensively by L. Lozada for the visualization of 3D-maps. Revisions: 03-08-2000 : Optimized version of the Read and Write procedures by J. Stolfi. 30-08-2000 : Modified the Read and Write procedures for include the case when the cells are octahedra. 07-10-2000 : Added procedure for compute the barycenter of a tetrahedron. 27-01-2001 : Modified for exploding cubic cells. *) IMPORT Octf, Random, LR4, LR4Extras, Stdio, Wr, Fmt, Thread, Math, FloatMode, FileRd, FileWr, Mis, Text, OSError, Lex, Rd, R3, FileFmt; FROM Octf IMPORT Fnext, Clock, SrotBits, RBits, SpliceFacets, Enext_1, Srot, Spin, SetFace, GetPairNum,Tors, Enext, Fnext_1, Onext, SetFnext, SetEdge, SetEdgeAll, SetEnext; FROM Stdio IMPORT stderr; FROM Mis IMPORT WriteCommentsJS; FROM FileFmt IMPORT WriteHeader, WriteFooter, ReadHeader, ReadFooter; <* FATAL Thread.Alerted, Rd.Failure, Wr.Failure *> <* FATAL Rd.EndOfFile, FloatMode.Trap, Lex.Error, OSError.E *> REVEAL FacetEdge = PublicFacetEdge BRANDED OBJECT org: ARRAY RBits OF Node; OVERRIDES init := FacetEdgeInit; END; REVEAL Vertex = PublicVertex BRANDED OBJECT END; REVEAL Polyhedron = PublicPolyhedron BRANDED OBJECT END; (* === INIT METHODS === *) PROCEDURE FacetEdgeInit(fe: FacetEdge): FacetEdge = BEGIN EVAL NARROW(fe, Octf.FacetEdge).init(); fe.org[0] := NIL; (* For now, vertex of primal: C *) fe.org[1] := NIL; (* For now, vertex of dual: C' *) fe.org[2] := NIL; (* For now, vertex of primal: C *) fe.org[3] := NIL; (* For now, vertex of dual: C' *) RETURN fe; END FacetEdgeInit; (* === ELEMENT CREATION === *) PROCEDURE MakeFacetEdge(): Pair = VAR a : Pair; BEGIN WITH e = NEW(FacetEdge).init() DO a := Pair{facetedge := e, bits := 0}; a.facetedge.edge.pa := a; a.facetedge.face.pa := a; RETURN a; END; END MakeFacetEdge; PROCEDURE MakeVertex(): Vertex = BEGIN RETURN NEW(Vertex) END MakeVertex; PROCEDURE MakePolyhedron(): Polyhedron = BEGIN RETURN NEW(Polyhedron) END MakePolyhedron; (* === PAIR PROPERTIES === *) PROCEDURE Org(a: Pair): Node = BEGIN WITH c = NARROW(a.facetedge, FacetEdge).org[SrotBits(a)] DO RETURN c; END; END Org; PROCEDURE SetOrg(a: Pair; n: Node) = BEGIN WITH c = NARROW(a.facetedge, FacetEdge).org[SrotBits(a)] DO c := n; END; END SetOrg; (* PROCEDURE Set(a: Pair; n: Node) = VAR t: Pair := a; tn: Pair; BEGIN REPEAT SetOrg(t,n); tn := Clock(Enext_1(t)); REPEAT SetOrg(tn,n); tn := Fnext(tn); UNTIL tn = Clock(Enext_1(t)); t := Fnext(t); UNTIL t = a; END Set; *) PROCEDURE Set(a: Pair; n: Node) = VAR c : Pair := a; BEGIN WITH nei = Octf.NumberEdgesForDegree(ARRAY OF Pair{a}) DO FOR i := 0 TO LAST(nei^) DO WITH b = nei[i] DO c := b; REPEAT SetOrg(c,n); c := Fnext(c) UNTIL (c = b); END END END END Set; PROCEDURE SetAllOrgs(a: Pair; n: Node) = BEGIN Set(a,n); END SetAllOrgs; PROCEDURE Pneg(a: Pair): Node = BEGIN RETURN Org(Srot(a)) END Pneg; PROCEDURE SetPneg(a: Pair; n: Node) = BEGIN SetOrg(Srot(a), n) END SetPneg; PROCEDURE SetNextPneg(a: Pair; n: Node) = VAR t: Pair := a; BEGIN REPEAT SetPneg(t, n); t := Enext_1(t); UNTIL t = a; END SetNextPneg; PROCEDURE SetAllPneg(a : Pair; n: Node) = VAR t: Pair := a; BEGIN SetNextPneg(t,n); REPEAT SetNextPneg(Clock(Fnext_1(t)),n); t := Enext_1(t); UNTIL t = a; END SetAllPneg; PROCEDURE Ppos(a: Pair): Node = BEGIN RETURN Pneg(Clock(a)) END Ppos; PROCEDURE SetPpos(a: Pair; n: Node) = BEGIN SetOrg(Tors(a), n) END SetPpos; PROCEDURE SetAllPpos(a: Pair; n: Node) = VAR t: Pair := a; BEGIN REPEAT SetPpos(t, n); t := Enext_1(t); UNTIL t = a; END SetAllPpos; PROCEDURE SetNextPpos(a : Pair; n: Node) = VAR t : Pair := Clock(a); BEGIN SetAllPneg(t,n); REPEAT SetAllPneg(Fnext_1(t),n); t := Enext_1(t); UNTIL t = Clock(a); END SetNextPpos; PROCEDURE OrgV(a: Pair): Vertex = BEGIN RETURN NARROW(Org(a), Vertex); END OrgV; PROCEDURE DesV(a: Pair): Vertex = BEGIN RETURN OrgV(Clock(a)); END DesV; PROCEDURE PnegP(a: Pair): Polyhedron = BEGIN RETURN NARROW(Pneg(a), Polyhedron); END PnegP; PROCEDURE PposP(a : Pair): Polyhedron = BEGIN RETURN PnegP(Clock(a)); END PposP; PROCEDURE TetraNegVertices(a: Pair): ARRAY [0..3] OF Vertex = (* Valid for the versions Spin(a), Clock(a) and SpinClock(a). *) BEGIN <* ASSERT Pneg(a) # NIL *> WITH p = OrgV(a), q = OrgV(Enext(a)), r = OrgV(Enext_1(a)), s = OrgV(Enext_1(Fnext_1(a))) DO <* ASSERT Pneg(a) = Ppos(Enext_1(Fnext_1(a))) *> <* ASSERT (p # q) AND (q # r) AND (r # s) *> RETURN ARRAY [0..3] OF Vertex{p,q,r,s} END END TetraNegVertices; PROCEDURE TetraFaces(a: Pair): ARRAY [0..3] OF Face = BEGIN <* ASSERT Pneg(a) # NIL *> WITH f0 = a.facetedge.face, f1 = Fnext_1(a).facetedge.face, f2 = Fnext_1(Enext(a)).facetedge.face, f3 = Fnext_1(Enext_1(a)).facetedge.face DO <* ASSERT (f0 # f1) AND (f1 # f2) AND (f2 # f3) *> RETURN ARRAY [0..3] OF Face{f0,f1,f2,f3} END END TetraFaces; PROCEDURE TetraEdges(a: Pair): ARRAY [0..5] OF Edge = BEGIN <* ASSERT Pneg(a) # NIL *> WITH e0 = a.facetedge.edge, e1 = Enext(a).facetedge.edge, e2 = Enext_1(a).facetedge.edge, e3 = Enext(Fnext_1(a)).facetedge.edge, e4 = Enext_1(Fnext_1(a)).facetedge.edge, e5 = Enext(Fnext_1(Enext(a))).facetedge.edge DO <* ASSERT (e0#e1) AND (e1#e2) AND (e2#e3) AND (e3#e4) AND (e4#e5) *> RETURN ARRAY [0..5] OF Edge{e0,e1,e2,e3,e4,e5} END END TetraEdges; PROCEDURE FaceEdges(a: Pair): ARRAY [0..2] OF Edge = BEGIN WITH e0 = a.facetedge.edge, e1 = Enext(a).facetedge.edge, e2 = Enext_1(a).facetedge.edge DO <* ASSERT (e0 # e1) AND (e1 # e2) *> RETURN ARRAY [0..2] OF Edge{e0,e1,e2} END END FaceEdges; PROCEDURE TetraPosVertices(a: Pair): ARRAY [0..3] OF Vertex = (* Valid for the versions Spin(a), Clock(a) and SpinClock(a). *) BEGIN <* ASSERT Ppos(a) # NIL *> WITH p = OrgV(a), q = OrgV(Enext(a)), r = OrgV(Enext_1(a)), s = OrgV(Enext_1(Fnext(a))) DO <* ASSERT Ppos(a) = Pneg(Enext_1(Fnext(a))) *> RETURN ARRAY [0..3] OF Vertex{p,q,r,s} END END TetraPosVertices; PROCEDURE TetraNegPosVertices(a: Pair): ARRAY [0..4] OF Node = (* Valid for the versions Spin(a), Clock(a) and SpinClock(a). We change the otion OrgV by Org such as, this procedure can be used in the dual space but the assertion is valid only in the primal space. *) BEGIN WITH p = Org(a), q = Org(Enext(a)), r = Org(Enext_1(a)), s = Org(Enext_1(Fnext_1(a))), t = Org(Enext_1(Fnext(a))) DO <* ASSERT Ppos(a) = Pneg(Enext_1(Fnext(a))) AND Pneg(a) = Ppos(Enext_1(Fnext_1(a))) *> RETURN ARRAY [0..4] OF Node{p,q,r,s,t} END END TetraNegPosVertices; (* ================= CONSTRUCTION TOOLS ========== *) PROCEDURE MakeTetraTopo(nx,ny : CARDINAL): ARRAY [0..7] OF Pair = VAR FacetEdgeCount: CARDINAL := 0; PolyhedronCount: CARDINAL := 0; PROCEDURE MakeTriangle(): Pair = (* Make one triangular face and set of the three pairs facetedges with the same face component. *) BEGIN WITH a = MakeFacetEdge(), b = MakeFacetEdge(), c = MakeFacetEdge(), f = a.facetedge.face, u = MakeVertex(), v = MakeVertex(), w = MakeVertex() DO a.facetedge.num := FacetEdgeCount; INC(FacetEdgeCount); SetOrg(a, u); SetOrg(Clock(a),v); b.facetedge.num := FacetEdgeCount; INC(FacetEdgeCount); SetEnext(a,b); SetFace(b,f); SetOrg(b,v); SetOrg(Clock(b),w); c.facetedge.num := FacetEdgeCount; INC(FacetEdgeCount); SetEnext(b,c); SetFace(c,f); SetOrg(c, w); SetOrg(Clock(c), Org(a)); RETURN a; END END MakeTriangle; PROCEDURE MakeCell(a: Pair) : Pair = (* Build a new tetrahedral cell by insertion of two triangular faces and operations SpliceFacets. The argument "a" is the pair return by MakeTriangle(). The pair "f" is return by MakeCell(). *) VAR c : Pair; BEGIN c := Enext(Fnext(a)); SetEdge(a, Enext_1(c).facetedge.edge); WITH f = MakeTriangle(), g = MakeTriangle() DO SetFnext(Enext_1(a), Enext_1(f)); SetEdge(Enext_1(f), Enext_1(a).facetedge.edge); SetAllOrgs(Enext_1(a), Org(Enext_1(a))); SetAllOrgs(Clock(Enext_1(a)), Org(Clock(Enext_1(a)))); SetFnext(Clock(f), Enext(c)); SetEdge(Clock(f), Enext(c).facetedge.edge); SetAllOrgs(Enext(c), Org(Enext(c))); SetAllOrgs(Clock(Enext(c)), Org(Clock(Enext(c)))); SetFnext(Enext(g), Enext(f)); SetEdge(Enext(g), Enext(f).facetedge.edge); SetAllOrgs(Enext(f), Org(Enext(f))); SetAllOrgs(Clock(Enext(f)), Org(Clock(Enext(f)))); SetFnext(g, c); SetEdge(g, c.facetedge.edge); SetAllOrgs(c, Org(c)); SetAllOrgs(Clock(c), Org(Clock(c))); SetFnext(Enext_1(g), Clock(Enext(a))); SetEdge(Enext_1(g), Clock(Enext(a)).facetedge.edge); SetAllOrgs(Enext(a), Org(Enext(a))); SetAllOrgs(Clock(Enext(a)), Org(Clock(Enext(a)))); WITH p = MakePolyhedron() DO p.num := PolyhedronCount; INC(PolyhedronCount); SetAllPneg(f,p); END; RETURN f; END; END MakeCell; PROCEDURE MakeCellRow(a: Pair) : Pair = (* Adds one new row of tetradedral cells and return the pair facetedge belong to the cell more rigth. *) BEGIN FOR col := 0 TO nx-1 DO a := MakeCell(a); END; RETURN a; END MakeCellRow; VAR t,b: Pair; ca: ARRAY [0..7] OF Pair; BEGIN (* =============== create bottom row of triangles =========== *) FOR col := 0 TO nx-1 DO WITH c = MakeTriangle() DO IF col = 0 THEN t := c; ELSE SpliceFacets(Enext(b), Clock(Enext_1(c))); SetEdge(Enext(b), Clock(Enext_1(c)).facetedge.edge); SetAllOrgs(Enext(b), Org(Enext(b))); SetAllOrgs(Clock(Enext(b)), Org(Clock(Enext(b)))); END; b := c; END; END; ca[2] := t; ca[7] := Spin(Clock(b)); FOR row := 0 TO ny-1 DO WITH a = MakeTriangle() DO IF row = 0 THEN ca[1] := Clock(Enext_1(a)) END; IF row = ny-1 THEN ca[4] := Spin(Enext_1(a)) END; SpliceFacets(Clock(a), Clock(Enext_1(t))); SetAllOrgs(Enext_1(t), Org(Enext_1(t))); SetAllOrgs(Clock(Enext_1(t)), Org(Clock(Enext_1(t)))); WITH aa = MakeCellRow(a) DO t := Fnext_1(t); SetOrg(Enext_1(t), Org(Enext_1(a))); b := Fnext_1(b); SetOrg(Clock(Enext(b)), Org(Enext_1(aa))); IF row = 0 THEN ca[0] := Clock(Spin(Enext_1(aa))) END; IF row = ny-1 THEN ca[5] := Enext_1(aa) END; END; END; END; ca[3] := Spin(t); ca[6] := Clock(b); RETURN ca; END MakeTetraTopo; PROCEDURE EmphasizeTetrahedron(a, b: Pair; n: CARDINAL) = PROCEDURE HiddenVertex(v: Vertex) = (* Hidden the vertex "v". *) BEGIN v.exists := FALSE; END HiddenVertex; PROCEDURE HiddenEdge(a: Pair) = (* Hidden the edge "a.facetedge.edge".*) BEGIN WITH e = NARROW(a.facetedge.edge, Edge) DO e.exists := FALSE; END; END HiddenEdge; PROCEDURE HiddenFace(a: Pair) = (* Hidden the face "a.facetedge.face".*) BEGIN WITH f = NARROW(a.facetedge.face, Face) DO f.exists := FALSE; END; END HiddenFace; PROCEDURE HiddenRingFace(a: Pair) = (* Hidden the ring face "a.facetedge.face". *) VAR an : Pair := Fnext_1(a); BEGIN FOR j := 1 TO n-1 DO HiddenFace(an); an := Fnext_1(an); END; END HiddenRingFace; VAR ta,tb: ARRAY [0..100] OF Pair; BEGIN ta[0] := a; tb[0] := b; FOR i := 1 TO n-1 DO ta[i] := Clock(Enext_1(Fnext(Enext(ta[i-1])))); tb[i] := Clock(Enext_1(Fnext(Enext(tb[i-1])))); END; FOR i := 0 TO n-1 DO HiddenRingFace(ta[i]); HiddenRingFace(tb[i]); END; FOR i := 1 TO n-1 DO HiddenVertex(OrgV(tb[i])); HiddenVertex(OrgV(ta[i])); VAR dn: Pair := tb[i]; BEGIN FOR j := 0 TO n DO HiddenEdge(Enext_1(dn)); dn := Fnext_1(dn); END END END; FOR i := 0 TO n-2 DO HiddenEdge(Enext(ta[i])); HiddenEdge(Enext(Fnext(ta[i]))); END; END EmphasizeTetrahedron; PROCEDURE Glue( a,b : Pair; n : CARDINAL; setorg: BOOLEAN := TRUE; ): Pair = (* The pair "a" and "b" have the same Orientation and Spin bits, such as, after of the glue procedure performs: Pneg(a) = Pneg(b). *) VAR ta,tb: ARRAY [0..100] OF Pair; BEGIN (* sanity check *) <* ASSERT n >= 1 *> ta[0] := a; tb[0] := b; IF n > 1 THEN FOR i := 1 TO n-1 DO ta[i] := Clock(Enext_1(Fnext_1(Enext(ta[i-1])))); tb[i] := Clock(Enext_1(Fnext(Enext(tb[i-1])))); <* ASSERT ta[i] # a *> <* ASSERT tb[i] # b *> END; END; Octf.Meld(b, a); (* updating edges relations for i=0 *) SetEdgeAll(a, a.facetedge.edge); SetEdgeAll(Enext(a), Enext(a).facetedge.edge); SetEdgeAll(Enext_1(a), Enext_1(a).facetedge.edge); IF setorg THEN (* updating vertices relations for i=0 *) SetAllOrgs(a, Org(a)); SetAllOrgs(Clock(a), Org(Clock(a))); SetAllOrgs(Enext(a), Org(Enext(a))); SetAllOrgs(Clock(Enext(a)), Org(Clock(Enext(a)))); SetAllOrgs(Enext_1(a), Org(Enext_1(a))); SetAllOrgs(Clock(Enext_1(a)), Org(Clock(Enext_1(a)))); END; (* updating polyhedron relations for i=0 *) SetPneg(a, Pneg(b)); SetPneg(Enext_1(a), Pneg(Enext_1(b))); SetPneg(Enext(a), Pneg(Enext(b))); FOR i := 1 TO n-1 DO Octf.Meld(tb[i],ta[i]); (* updating edges relations *) SetEdgeAll(ta[i], ta[i].facetedge.edge); SetEdgeAll(Enext(ta[i]), Enext(ta[i]).facetedge.edge); SetEdgeAll(Enext_1(ta[i]), Enext_1(ta[i]).facetedge.edge); IF setorg THEN (* updating vertices relations *) SetAllOrgs(ta[i], Org(ta[i])); SetAllOrgs(Clock(ta[i]), Org(Clock(ta[i]))); SetAllOrgs(Enext(ta[i]), Org(Enext(ta[i]))); SetAllOrgs(Clock(Enext(ta[i])), Org(Clock(Enext(ta[i])))); SetAllOrgs(Enext_1(ta[i]), Org(Enext_1(ta[i]))); SetAllOrgs(Clock(Enext_1(ta[i])), Org(Clock(Enext_1(ta[i])))); END; (* updating polyhedron relations *) WITH f = Pneg(tb[i]), g = Pneg(Enext_1(tb[i])), h = Pneg(Enext(tb[i])) DO SetPneg(ta[i],f); SetPneg(Enext_1(ta[i]),g); SetPneg(Enext(ta[i]),h); END END; IF setorg THEN SetAllOrgs(Clock(Enext_1(Fnext_1(Enext_1(ta[n-1])))),Org(Enext_1(a))); END; RETURN ta[n-1]; END Glue; (* === GLOBAL PROCEDURES === *) VAR seenNode: REF ARRAY OF Node := NIL; nodeOnum: REF ARRAY OF CARDINAL := NIL; seenNodeCount: CARDINAL := 0; PROCEDURE MarkNode(n: Node) = BEGIN IF seenNode = NIL OR NUMBER(seenNode^) <= seenNodeCount THEN DoubleseenNode() END; WITH k = seenNodeCount+0 DO seenNode[k] := n; nodeOnum[k] := n.num; n.num := k; INC(seenNodeCount) END END MarkNode; PROCEDURE DoubleseenNode() = VAR sz: CARDINAL; BEGIN IF seenNode = NIL THEN sz := 0 ELSE sz := NUMBER(seenNode^) END; WITH szNew = MAX(2*sz, 1000), seenNodeNew = NEW(REF ARRAY OF Node, szNew), nodeOnumNew = NEW(REF ARRAY OF CARDINAL, szNew) DO IF seenNode # NIL THEN SUBARRAY(seenNodeNew^, 0, sz) := seenNode^; SUBARRAY(nodeOnumNew^, 0, sz) := nodeOnum^; END; seenNode := seenNodeNew; nodeOnum := nodeOnumNew; END END DoubleseenNode; PROCEDURE NodeIsMarked(n: Node) : BOOLEAN = BEGIN RETURN (n.num < seenNodeCount) AND (seenNode[n.num] = n) END NodeIsMarked; PROCEDURE UnmarkMarkedNodes() = BEGIN WHILE seenNodeCount > 0 DO WITH k = seenNodeCount-1, n = seenNode[k] DO n.num := nodeOnum[k]; DEC(seenNodeCount) END END END UnmarkMarkedNodes; PROCEDURE EnumVertices(a: Pair; visit: VisitProc) = CONST IniStackSize = 1000; VAR festack := NEW(REF ARRAY OF FacetEdge, IniStackSize); bstack := NEW(REF ARRAY OF SRBits, IniStackSize); top : CARDINAL; (* top for "festack" stack *) PROCEDURE DoubleStack() = BEGIN WITH sz = NUMBER(festack^), szNew = 2*sz, festackNew = NEW(REF ARRAY OF FacetEdge, szNew), bstackNew = NEW(REF ARRAY OF SRBits, szNew) DO SUBARRAY(festackNew^, 0, sz):= festack^; festack := festackNew; SUBARRAY(bstackNew^, 0, sz) := bstack^; bstack := bstackNew; END END DoubleStack; PROCEDURE Stack(c: Pair) = VAR cn : Pair := c; dn : Pair; BEGIN REPEAT IF top > LAST(festack^) THEN DoubleStack() END; festack[top] := cn.facetedge; bstack[top] := cn.bits; top := top + 1; dn := Clock(Enext_1(cn)); REPEAT IF top > LAST(festack^) THEN DoubleStack() END; festack[top] := dn.facetedge; bstack[top] := dn.bits; top := top + 1; dn := Fnext(dn); UNTIL( dn = Clock(Enext_1(cn)) ); cn := Fnext(cn); UNTIL (cn = c); END Stack; PROCEDURE VisitAndMark(c: Pair)= (* If org(c) is diferent that the origins pairs stacked, stack the pair "c". *) VAR cn : Pair; BEGIN WITH n = Org(c) DO IF n # NIL AND NOT NodeIsMarked(n) THEN visit(c); MarkNode(n); Stack(c); cn := c; REPEAT Stack(cn); cn := Onext(cn); UNTIL (cn = c) END END; END VisitAndMark; VAR seen: CARDINAL; BEGIN top := 0; seen := 0; <* ASSERT seenNodeCount = 0 *> VisitAndMark(a); WHILE seen < top DO WITH b = Pair{festack[seen], bstack[seen]} DO VisitAndMark(Fnext(b)); VisitAndMark(Fnext(Enext(b))); VisitAndMark(Enext(b)); VisitAndMark(Fnext_1(Enext_1(b))); END; seen := seen + 1; END; UnmarkMarkedNodes(); END EnumVertices; PROCEDURE NumberVertices(a: Pair): CARDINAL = VAR n: CARDINAL := 0; PROCEDURE Visit(c: Pair) = PROCEDURE Visit_(c: Pair) = VAR cn,dn: Pair; BEGIN WITH v = Org(c) DO cn := c; REPEAT WITH vn = Org(cn) DO <* ASSERT vn = v *> vn.num := n; dn := Clock(Enext_1(cn)); REPEAT WITH wn = Org(dn) DO <* ASSERT wn = vn *> wn.num := n; dn := Fnext(dn); END; UNTIL ( dn = Clock(Enext_1(cn)) ); cn := Fnext(cn); END; UNTIL ( cn = c ); END; END Visit_; VAR cn: Pair := c; BEGIN REPEAT Visit_(cn); cn := Onext(cn); UNTIL cn = c; INC(n); END Visit; PROCEDURE VisitDual(c: Pair) = PROCEDURE VisitDual_(c: Pair) = VAR cn: Pair; p,pn: Node; BEGIN p := Org(c); IF p # NIL THEN cn := c; REPEAT pn := Org(cn); IF pn # NIL THEN <* ASSERT pn = p *> pn.num := n; END; cn := Fnext(cn); UNTIL( cn = c ) END; END VisitDual_; VAR cn: Pair := c; BEGIN VisitDual_(cn); VisitDual_(Clock(Enext_1(cn))); INC(n); END VisitDual; BEGIN IF Octf.DualBit(a) = 0 THEN EnumVertices(a, Visit); ELSE EnumVertices(a, VisitDual); END; RETURN n END NumberVertices; PROCEDURE MakeTopology(a: Pair; bdr: CARDINAL) : Topology = VAR top : Topology; euler : INTEGER; BEGIN top.NV := NumberVertices(a); top.vertex := NEW(REF ARRAY OF Vertex, top.NV); top.facetedge := Octf.NumberFacetEdges(ARRAY OF Pair{a}); top.NFE := NUMBER(top.facetedge^); top.edge := Octf.NumberEdges(ARRAY OF Pair{top.facetedge[0]}); top.face := Octf.NumberFacets(ARRAY OF Pair{top.facetedge[0]}); top.out := NEW(REF ARRAY OF Pair, top.NV); top.NE := NUMBER(top.edge^); top.NF := NUMBER(top.face^); top.NP := NumberVertices(Srot(a)); top.polyhedron := NEW(REF ARRAY OF Polyhedron, top.NP); top.region := NEW(REF ARRAY OF Pair, top.NP); top.der := Octf.DegreeEdgeRing(top.face[0].pa); top.bdr := bdr; FOR i:= 0 TO top.NFE-1 DO VAR c: Pair := top.facetedge[i]; v,p: Node; vi,pi: CARDINAL; BEGIN FOR k:= 0 TO 1 DO v := Org(c); vi := v.num; top.vertex[vi] := v; top.out[vi] := c; p := Pneg(c); IF p # NIL THEN pi := p.num; top.polyhedron[pi] := p; top.region[pi] := Srot(c); <* ASSERT Pneg(c) = Org(top.region[pi]) *> END; c := Clock(c); END END END; WITH m = Mis.NumDigits(top.NFE)+1 DO Wr.PutText(stderr, "\n"); Wr.PutText(stderr, "nv := " & Fmt.Pad(Fmt.Int(top.NV),m) & "\n"); Wr.PutText(stderr, "ne := " & Fmt.Pad(Fmt.Int(top.NE),m) & "\n"); Wr.PutText(stderr, "nf := " & Fmt.Pad(Fmt.Int(top.NF),m) & "\n"); Wr.PutText(stderr, "np := " & Fmt.Pad(Fmt.Int(top.NP),m) & "\n"); Wr.PutText(stderr, "nfe := " & Fmt.Pad(Fmt.Int(top.NFE),m) & "\n"); END; (* Euler's Number *) euler := top.NV-top.NE+top.NF-top.NP; IF euler = 0 THEN Wr.PutText(stderr,"\nThe Map performs the Euler's Number = 0\n"); ELSE Wr.PutText(stderr,"\nThe Euler's Number: " & Fmt.Int(euler) & "\n"); END; RETURN top; END MakeTopology; PROCEDURE DegreeOfVertex(a: Pair) : CARDINAL = BEGIN WITH edge = Octf.NumberEdgesForDegree(ARRAY OF Pair{a}), degree = NUMBER(edge^) DO RETURN degree; END; END DegreeOfVertex; PROCEDURE MakeAdjacencyMatrix(READONLY top: Topology): REF AdjacencyMatrix = VAR m := NEW(REF ARRAY OF ARRAY OF BOOLEAN, top.NV, top.NV); BEGIN FOR i := 0 TO top.NV-1 DO WITH mi = m[i] DO FOR j := 0 TO top.NV-1 DO mi[j] := FALSE END END END; FOR ei := 0 TO top.NFE-1 DO WITH a = top.facetedge[ei] DO WITH i = Org(a).num, j = Org(Clock(a)).num DO m[i,j] := TRUE; m[j,i] := TRUE; END END END; RETURN m; END MakeAdjacencyMatrix; PROCEDURE TriviallyIsomorphic(READONLY ta, tb: Topology): BOOLEAN = BEGIN IF ta.NV # tb.NV OR ta.NF # tb.NF OR ta.NE # tb.NE OR ta.NP # tb.NP OR ta.NFE # tb.NFE THEN RETURN FALSE END; WITH NFE = ta.NFE DO FOR i := 0 TO NFE-1 DO VAR sa: Pair := ta.facetedge[i]; sb: Pair := tb.facetedge[i]; BEGIN FOR r := 0 TO 3 DO WITH na = Org(sa).num, nb = Org(sb).num DO IF na # nb THEN RETURN FALSE END END; WITH za = GetPairNum(Fnext(sa)), zb = GetPairNum(Fnext(sb)) DO IF za # zb THEN RETURN FALSE END END; sa := Srot(sa); sb := Srot(sb); END END END END; RETURN TRUE END TriviallyIsomorphic; PROCEDURE CheckOutAndRegion(READONLY top: Topology) = BEGIN FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i], e = top.out[i] DO <* ASSERT v.num = i *> <* ASSERT Org(e) = v *> END END; FOR i := 0 TO top.NP-1 DO WITH p = top.polyhedron[i], r = top.region[i] DO <* ASSERT p.num = i *> <* ASSERT Org(r) = p *> END END; END CheckOutAndRegion; PROCEDURE GetVariableVertices(READONLY top: Topology; VAR vr: ARRAY OF BOOLEAN) = BEGIN FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i] DO vr[i] := NOT v.fixed; END; END; END GetVariableVertices; (* === GEOMETRIC TOOLS === *) PROCEDURE InitCoords( coins: Random.T; VAR c: Coords; radius: REAL := 1.0 ) = BEGIN WITH r = FLOAT(radius, LONGREAL) DO FOR i := 0 TO LAST(c) DO c[i] := LR4.T{ coins.longreal(-r, r), coins.longreal(-r, r), coins.longreal(-r, r), coins.longreal(-r, r) } END END END InitCoords; PROCEDURE GenCoords(READONLY t: Topology) : REF Coords = BEGIN WITH coins = NEW(Random.Default).init(TRUE), r = NEW(REF Coords, t.NV), c = r^ DO FOR i := 0 TO LAST(c) DO c[i] := LR4.T{ coins.longreal(-1.0d0, +1.0d0), coins.longreal(-1.0d0, +1.0d0), coins.longreal(-1.0d0, +1.0d0), coins.longreal(-1.0d0, +1.0d0) } END; RETURN r END END GenCoords; PROCEDURE Barycenter(READONLY top: Topology; READONLY c: Coords): LR4.T = VAR B: LR4.T := LR4.T{0.0d0, ..}; N: CARDINAL := 0; BEGIN FOR i := 0 TO LAST(c) DO WITH v = top.vertex[i] DO IF v.exists THEN B := LR4.Add(B, c[i]); INC(N) END; END; END; RETURN LR4.Scale(1.0d0/FLOAT(N, LONGREAL), B) END Barycenter; PROCEDURE MeanVertexDistance(READONLY top: Topology; READONLY c: Coords): LONGREAL = VAR S: LONGREAL := 0.0d0; N: CARDINAL := 0; BEGIN FOR i := 0 TO LAST(c) DO WITH v = top.vertex[i] DO IF v.exists THEN S := S + LR4.NormSqr(c[i]); INC(N) END END END; RETURN Math.sqrt(S/FLOAT(N,LONGREAL)) END MeanVertexDistance; PROCEDURE MeanEdgeLength(READONLY top: Topology; READONLY c: Coords): LONGREAL = VAR S: LONGREAL := 0.0d0; N: CARDINAL := 0; BEGIN FOR i := 0 TO top.NE-1 DO WITH e = top.edge[i] DO IF e.exists THEN WITH o = e.vertex[0].num, d = e.vertex[1].num DO S := S + LR4.DistSqr(c[o], c[d]) END; INC(N); END END END; RETURN Math.sqrt(S/FLOAT(N,LONGREAL)) END MeanEdgeLength; PROCEDURE Displace(READONLY top: Topology; d: LR4.T; VAR c: Coords) = BEGIN FOR i := 0 TO LAST(c) DO IF top.vertex[i].exists THEN WITH vc = c[i] DO vc := LR4.Add(vc, d) END END END END Displace; PROCEDURE Scale(READONLY top: Topology; s: LONGREAL; VAR c: Coords) = BEGIN FOR i := 0 TO LAST(c) DO IF top.vertex[i].exists THEN WITH vc = c[i] DO vc := LR4.Scale(s, vc) END; END END END Scale; PROCEDURE NormalizeVertexDistance(READONLY top: Topology; VAR c: Coords) = BEGIN WITH b = Barycenter(top, c) DO Displace(top, LR4.Neg(b), c) END; WITH s = MeanVertexDistance(top, c) DO Scale(top, 1.0d0/s, c) END; END NormalizeVertexDistance; PROCEDURE NormalizeEdgeLengths(READONLY top: Topology; VAR c: Coords) = BEGIN WITH b = Barycenter(top, c) DO Displace(top, LR4.Neg(b), c) END; WITH s = MeanEdgeLength(top, c) DO Scale(top, 1.0d0/s, c) END; END NormalizeEdgeLengths; PROCEDURE FaceCross(a: Pair; READONLY c: Coords): LR4.T = BEGIN IF NOT a.facetedge.face.exists THEN RETURN LR4.T{1.0d0, 0.0d0, 0.0d0, 0.0d0} ELSE WITH ov = OrgV(a), dv = OrgV(Clock(a)), pv = OrgV(Enext_1(a)), qv = OrgV(Enext_1(Fnext(a))), rv = OrgV(Enext_1(Fnext_1(a))) DO WITH o = c[ov.num], d = c[dv.num], p = c[pv.num], q = c[qv.num], r = c[rv.num], n1 = LR4Extras.Cross(LR4.Sub(p,o), LR4.Sub(r,o), LR4.Sub(d,o)), n2 = LR4Extras.Cross(LR4.Sub(p,o), LR4.Sub(d,o), LR4.Sub(q,o)) DO RETURN LR4.Add(n1,n2); END END END END FaceCross; PROCEDURE FaceNormal(a: Pair; READONLY c: Coords): LR4.T = BEGIN WITH n = FaceCross(a,c), s = LR4.Norm(n) DO IF s = 0.0d0 THEN RETURN LR4.T{1.0d0, 0.0d0, 0.0d0, 0.0d0} ELSE RETURN LR4.Scale(1.0d0/s, n) END END END FaceNormal; PROCEDURE PolyCross(a: Pair; READONLY c: Coords): LR4.T = BEGIN IF NOT PnegP(a).exists THEN RETURN LR4.T{1.0d0, 0.0d0, 0.0d0, 0.0d0} ELSE WITH ov = OrgV(a), dv = OrgV(Clock(a)), pv = OrgV(Enext_1(a)), rv = OrgV(Enext_1(Fnext_1(a))) DO WITH o = c[ov.num], d = c[dv.num], p = c[pv.num], r = c[rv.num] DO RETURN LR4Extras.Cross(LR4.Sub(p,o), LR4.Sub(r,o), LR4.Sub(d,o)); END END END END PolyCross; PROCEDURE PolyNormal(a: Pair; READONLY c: Coords): LR4.T = BEGIN WITH n = PolyCross(a, c), s = LR4.Norm(n) DO IF s = 0.0d0 THEN RETURN LR4.T{1.0d0, 0.0d0, 0.0d0, 0.0d0} ELSE RETURN LR4.Scale(1.0d0/s, n) END END END PolyNormal; PROCEDURE FaceBarycenter(a: Pair; READONLY c: Coords): LR4.T = VAR ao : Pair; n : CARDINAL := 0; sum := LR4.T{0.0d0, ..}; BEGIN ao := a; REPEAT WITH aoc = c[OrgV(ao).num] DO sum := LR4.Add(sum, aoc); INC(n); ao := Enext(ao); END; UNTIL (ao = a); IF n = 0 THEN RETURN sum ELSE RETURN LR4.Scale(1.0d0/FLOAT(n,LONGREAL), sum) END END FaceBarycenter; PROCEDURE TetraBarycenter(a: Pair; READONLY c: Coords): LR4.T = VAR n : CARDINAL := 0; sum := LR4.T{0.0d0, ..}; BEGIN WITH tetra = TetraNegVertices(a) DO FOR i := 0 TO 3 DO WITH aoc = c[tetra[i].num] DO sum := LR4.Add(sum, aoc); INC(n); END END END; RETURN LR4.Scale(1.0d0/FLOAT(n,LONGREAL), sum) END TetraBarycenter; PROCEDURE EdgeCross(a: Pair; READONLY c: Coords): LR4.T = VAR sum: LR4.T := LR4.T{0.0d0,..}; ao : Pair; BEGIN WITH uv = OrgV(a), u = c[uv.num] DO IF NOT a.facetedge.edge.exists THEN RETURN LR4.T{1.0d0, 0.0d0, 0.0d0, 0.0d0} ELSE ao := a; REPEAT WITH an = Fnext_1(ao), dv = OrgV(Clock(ao)), pv = OrgV(Enext_1(ao)), rv = OrgV(Enext_1(an)) DO WITH d = c[dv.num], p = c[pv.num], r = c[rv.num], n = LR4Extras.Cross(LR4.Sub(p,u), LR4.Sub(d,u), LR4.Sub(r,u)) DO IF ao = a THEN sum := n; ELSE sum := LR4.Add(sum,n) END; END; ao := an; END; UNTIL (ao = a); RETURN sum; END END; END EdgeCross; PROCEDURE EdgeNormal(a: Pair; READONLY c: Coords): LR4.T = BEGIN WITH n = EdgeCross(a, c), s = LR4.Norm(n) DO IF s = 0.0d0 THEN RETURN LR4.T{1.0d0, 0.0d0, 0.0d0, 0.0d0} ELSE RETURN LR4.Scale(1.0d0/s, n) END END END EdgeNormal; PROCEDURE VertexCross(a: Pair; READONLY c: Coords; READONLY top : Topology): LR4.T = VAR sum,n: LR4.T := LR4.T{0.0d0, ..}; BEGIN WITH uv = OrgV(a), poly = StarOfVertex(a,top) DO IF NOT uv.exists THEN RETURN LR4.T{1.0d0, 0.0d0, 0.0d0, 0.0d0} ELSE FOR i := 0 TO LAST(poly^) DO IF poly[i][0].exists AND poly[i][1].exists AND poly[i][2].exists AND poly[i][3].exists THEN WITH u = c[poly[i][0].num], d = c[poly[i][1].num], p = c[poly[i][2].num], r = c[poly[i][3].num] DO n:= LR4Extras.Cross(LR4.Sub(p,u), LR4.Sub(d,u), LR4.Sub(r,u)); IF i = 0 THEN sum := n; ELSE sum := LR4.Add(sum,n) END; END; END; END; END; RETURN sum; END; END VertexCross; PROCEDURE VertexNormal(a: Pair; READONLY c: Coords; READONLY top: Topology): LR4.T = BEGIN WITH n = VertexCross(a, c, top), s = LR4.Norm(n) DO IF s = 0.0d0 THEN RETURN LR4.T{1.0d0, 0.0d0, 0.0d0, 0.0d0} ELSE RETURN LR4.Scale(1.0d0/s, n) END END END VertexNormal; PROCEDURE NeighborBarycenter(neigh: REF ARRAY OF Vertex; READONLY c: Coords): LR4.T = VAR n : CARDINAL := 0; b := LR4.T{0.0d0, ..}; BEGIN WITH r = NUMBER(neigh^) DO FOR i := 0 TO r-1 DO WITH v = neigh^[i] DO IF v.exists THEN b := LR4.Add(b, c[v.num]); INC(n) END END END END; IF n = 0 THEN RETURN b ELSE RETURN LR4.Scale(1.0d0/FLOAT(n, LONGREAL), b) END; END NeighborBarycenter; PROCEDURE NeighborVertex( a: Pair; READONLY top: Topology; ): REF ARRAY OF Vertex = CONST IniStackSize = 1024; VAR tri : REF ARRAY OF Triv; vstack := NEW(REF ARRAY OF Vertex, IniStackSize); nstack: CARDINAL := 0; c : CARDINAL; PROCEDURE Present(v: Vertex) : BOOLEAN = (* Return TRUE if "v" is on the stack, FALSE c.c *) VAR nstack1: CARDINAL := nstack; BEGIN WHILE nstack1 > 0 DO nstack1 := nstack1 - 1; IF vstack[nstack1] = v THEN RETURN TRUE END; END; RETURN FALSE; END Present; BEGIN WITH poly = StarOfVertex(a,top), np = NumberPolyOfStar(poly) DO tri := NEW(REF ARRAY OF Triv, np); FOR i := 0 TO LAST(poly^) DO c := 0; FOR j := 0 TO 3 DO IF poly[i][j] # OrgV(a) THEN tri[i,c] := poly[i][j]; INC(c) END END; <* ASSERT c = 3 *> END; FOR j := 0 TO LAST(poly^) DO FOR l := 0 TO 2 DO IF NOT Present(tri[j,l]) THEN vstack[nstack] := tri[j,l]; INC(nstack); END END END; WITH r = NEW(REF ARRAY OF Vertex, nstack) DO r^ := SUBARRAY(vstack^, 0, nstack); RETURN r; END; END; END NeighborVertex; PROCEDURE Neighbors( a: Pair; READONLY top: Topology; ): REF ARRAY OF Vertex = CONST IniStackSize = 1024; VAR vstack := NEW(REF ARRAY OF Vertex, IniStackSize); nstack: CARDINAL := 0; v : CARDINAL; BEGIN v := OrgV(a).num; FOR i := 0 TO top.NE-1 DO WITH ei = top.edge[i], ei0 = ei.vertex[0].num, ei1 = ei.vertex[1].num DO IF (v = ei0) OR (v = ei1) THEN IF v = ei0 THEN vstack[nstack] := top.vertex[ei1]; INC(nstack); ELSE vstack[nstack] := top.vertex[ei0]; INC(nstack); END END END END; WITH r = NEW(REF ARRAY OF Vertex, nstack) DO r^ := SUBARRAY(vstack^, 0, nstack); RETURN r; END; END Neighbors; PROCEDURE NumberNeighborVertex(neigh: REF ARRAY OF Vertex): CARDINAL = BEGIN WITH n = NUMBER(neigh^) DO RETURN n; END; END NumberNeighborVertex; PROCEDURE StarOfVertex(a: Pair; READONLY top: Topology) : REF ARRAY OF Quadv = PROCEDURE VertexPoly(READONLY top : Topology): REF ARRAY OF Quadp = (* Return four pairs facetedges such as the origins corresponding to vertices extremes of each tetrahedron of Triangulation. *) VAR poly : REF ARRAY OF Quadp := NEW(REF ARRAY OF Quadp, top.NP); BEGIN FOR i := 0 TO top.NP-1 DO WITH da = top.region[i], a0 = Tors(da), db = Clock(Enext_1(da)), b0 = Tors(db) DO (*<* ASSERT DegreeOfVertex(a0) = 4 *> *) (* consuming time *) WITH a1 = Enext(a0), a2 = Enext(a1), a3 = Enext_1(b0) DO IF Enext(a2) # a0 THEN Wr.PutText(stderr, "\nTriangulation: This topology isn't" & " a triangulation\n"); <* ASSERT Enext(a2) = a0 *> END; <* ASSERT Pneg(a0).num = i *> IF Pneg(b0) # NIL THEN <* ASSERT Pneg(a0) = Pneg(b0) *> END; <* ASSERT a0 # b0 *> poly[i] := Quadp{a0,a1,a2,a3}; END END END; RETURN poly; END VertexPoly; VAR poly1 : REF ARRAY OF Quadv := NEW(REF ARRAY OF Quadv, top.NP); n : CARDINAL := 0; BEGIN WITH poly = VertexPoly(top), v = OrgV(a) DO FOR i := 0 TO LAST(poly^) DO IF (OrgV(poly[i][0]) = v) OR (OrgV(poly[i][1]) = v) OR (OrgV(poly[i][2]) = v) OR (OrgV(poly[i][3]) = v) THEN FOR j := 0 TO 3 DO IF OrgV(poly[i][j]) = v THEN WITH uv = OrgV(poly[i][j]), dv = OrgV(Enext(poly[i][j])), pv = OrgV(Enext_1(poly[i][j])), rv = OrgV(Enext_1(Fnext_1(poly[i][j]))) DO poly1[n] := Quadv{uv,dv,pv,rv}; INC(n); END END END END END; WITH r = NEW(REF ARRAY OF Quadv, n) DO r^ := SUBARRAY(poly1^, 0, n); RETURN r; END; END; END StarOfVertex; PROCEDURE NumberPolyOfStar(quad: REF ARRAY OF Quadv): CARDINAL = BEGIN WITH n = NUMBER(quad^) DO RETURN n; END; END NumberPolyOfStar; PROCEDURE ComputeAllVertexNormals( READONLY top: Topology; READONLY c: Coords; ): REF ARRAY OF LR4.T = BEGIN WITH rvn = NEW(REF ARRAY OF LR4.T, top.NV), vn = rvn^ DO FOR i := 0 TO top.NV-1 DO vn[i] := VertexNormal(top.out[i], c, top) END; RETURN rvn END; END ComputeAllVertexNormals; PROCEDURE ComputeAllEdgeNormals( READONLY top: Topology; READONLY c: Coords; ): REF ARRAY OF LR4.T = BEGIN WITH rvn = NEW(REF ARRAY OF LR4.T, top.NE), vn = rvn^ DO FOR i := 0 TO top.NE-1 DO vn[i] := EdgeNormal(top.edge[i].pa, c); END; RETURN rvn END; END ComputeAllEdgeNormals; PROCEDURE ComputeAllFaceNormals( READONLY top: Topology; READONLY c: Coords; ): REF ARRAY OF LR4.T = BEGIN WITH rvn = NEW(REF ARRAY OF LR4.T, top.NF), vn = rvn^ DO FOR i := 0 TO top.NF-1 DO vn[i] := FaceNormal(top.face[i].pa, c); END; RETURN rvn END; END ComputeAllFaceNormals; PROCEDURE ComputeAllPolyhedronNormals( READONLY top: Topology; READONLY c: Coords; ): REF ARRAY OF LR4.T = BEGIN WITH rvn = NEW(REF ARRAY OF LR4.T, top.NP), vn = rvn^ DO FOR i := 0 TO top.NP-1 DO vn[i] := PolyNormal(Tors(top.region[i]), c); END; RETURN rvn END; END ComputeAllPolyhedronNormals; PROCEDURE MakePolyhedronTopology(a: Pair): PolyhedronTopology = VAR ne, nv: CARDINAL; b: Pair; ptop: PolyhedronTopology; BEGIN WITH star = Octf.NumberEdgesForDegree(ARRAY OF Pair{a})^ DO (* Gather faces: *) ptop.NF := NUMBER(star); ptop.fRef := NEW(REF ARRAY OF Pair, ptop.NF); ne := 0; FOR i := 0 TO ptop.NF-1 DO WITH side = Octf.Sdual(star[i]) DO ptop.fRef[i] := side; b := side; REPEAT INC(ne); WITH e = b.facetedge.edge DO e.xmark := FALSE; OrgV(b).xmark := FALSE; END; b := Enext(b) UNTIL b = side; END END; (* Gather edges: *) <* ASSERT ne MOD 2 = 0 *> ptop.NE := ne DIV 2; ptop.eRef := NEW(REF ARRAY OF Pair, ptop.NE); ne := 0; FOR i := 0 TO ptop.NF-1 DO WITH side = Octf.Sdual(star[i]) DO b := side; REPEAT WITH e = b.facetedge.edge DO IF NOT e.xmark THEN ptop.eRef[ne] := b; INC(ne); e.xmark := TRUE; END END; b := Enext(b) UNTIL b = side END END; (* Gather vertices: *) ptop.NV := 2 + ptop.NE - ptop.NF; ptop.vRef := NEW(REF ARRAY OF Pair, ptop.NV); nv := 0; FOR i := 0 TO ptop.NE-1 DO WITH eu = ptop.eRef[i], u = OrgV(eu), ev = Clock(Fnext_1(eu)), v = OrgV(ev) DO IF NOT u.xmark THEN ptop.vRef[nv] := eu; INC(nv); u.xmark := TRUE END; IF NOT v.xmark THEN ptop.vRef[nv] := ev; INC(nv); v.xmark := TRUE END; eu.facetedge.edge.xmark := FALSE; END; END; FOR i := 0 TO ptop.NV-1 DO WITH u = OrgV(ptop.vRef[i]) DO u.xmark := FALSE END END; END; RETURN ptop END MakePolyhedronTopology; (* ========== INPUT/OUTPUT ================== *) CONST Boole = Mis.Boole; AlphaChars = Mis.AlphaChars; PROCEDURE ReadTopology(rd: Rd.T): TopCom = VAR top: Topology; comments: TEXT; n : CHAR; BEGIN (* Topology *) ReadHeader(rd,"topology","99-08-25"); comments := Mis.ReadCommentsJS(rd, '|'); (* Element counts: *) Lex.Skip(rd, cs := AlphaChars); top.NV := Lex.Int(rd); Lex.Skip(rd, cs := AlphaChars); top.NE := Lex.Int(rd); Lex.Skip(rd, cs := AlphaChars); top.NF := Lex.Int(rd); Lex.Skip(rd, cs := AlphaChars); top.NP := Lex.Int(rd); Lex.Skip(rd, cs := AlphaChars); top.NFE := Lex.Int(rd); Lex.Skip(rd, cs := AlphaChars); top.der := Lex.Int(rd); Lex.Skip(rd, cs := AlphaChars); top.bdr := Lex.Int(rd); Lex.Skip(rd); WITH map = NEW(REF ARRAY OF Octf.FacetEdge, top.NFE)^ DO (* Create vertex records: *) top.vertex := NEW(REF ARRAY OF Vertex, top.NV); top.out := NEW(REF ARRAY OF Pair, top.NV); FOR i := 0 TO top.NV-1 DO top.vertex[i] := MakeVertex(); top.vertex[i].num := i; END; (* Create edges records *) top.edge := NEW(REF ARRAY OF Octf.Edge, top.NE); FOR i := 0 TO top.NE-1 DO top.edge[i] := Octf.MakeEdge(); top.edge[i].num := i; END; (* Create face records: *) top.face := NEW(REF ARRAY OF Face, top.NF); FOR i := 0 TO top.NF-1 DO top.face[i] := Octf.MakeFace(); top.face[i].num := i; END; (* Create polyhedra records: *) top.polyhedron := NEW(REF ARRAY OF Polyhedron, top.NP); top.region := NEW(REF ARRAY OF Pair, top.NP); FOR i := 0 TO top.NP-1 DO top.polyhedron[i] := MakePolyhedron(); top.polyhedron[i].num := i; END; (* Create facetedge records: *) top.facetedge := NEW(REF ARRAY OF Octf.Pair, top.NFE); FOR i := 0 TO top.NFE-1 DO top.facetedge[i] := MakeFacetEdge(); top.facetedge[i].facetedge.num := i; map[i] := top.facetedge[i].facetedge; END; (* Read edge data: *) EVAL Mis.ReadCommentsJS(rd, '|'); FOR j := 0 TO top.NE-1 DO Lex.Skip(rd); WITH ne = Lex.Int(rd), (* index to edge *) e = top.edge[ne], pa = Octf.ReadPair(rd,map) DO <* ASSERT ne = j *> e.pa := pa END; END; Lex.Skip(rd); (* Read face data: *) EVAL Mis.ReadCommentsJS(rd, '|'); FOR j := 0 TO top.NF-1 DO Lex.Skip(rd); WITH nf = Lex.Int(rd), (* index to face *) f = top.face[nf], pa = Octf.ReadPair(rd,map) DO <* ASSERT nf = j *> f.pa := pa; END; END; Lex.Skip(rd); (* Read facetedge data: *) EVAL Mis.ReadCommentsJS(rd, '|'); FOR j := 0 TO top.NFE-1 DO Lex.Skip(rd); WITH nfe = Lex.Int(rd), (* index to facetedge *) fe = NARROW(top.facetedge[nfe].facetedge, FacetEdge) DO <* ASSERT nfe = j *> <* ASSERT top.facetedge[nfe].bits = 0 *> fe.num := nfe; Octf.ReadFacetEdge(rd, fe, map); FOR k := 0 TO 3 DO Lex.Skip(rd); n := Rd.GetChar(rd); IF n # '-' THEN Rd.UnGetChar(rd); WITH m = Lex.Int(rd), pa = Pair{facetedge := fe, bits := 2*k}, vf = fe.org[k] DO IF Rd.GetChar(rd) = 'v' THEN vf := top.vertex[m]; top.out[m] := pa; ELSE vf := top.polyhedron[m]; top.region[m] := pa; END END; END; END; Lex.Skip(rd); WITH nf = Lex.Int(rd) DO fe.face := top.face[nf]; END; <* ASSERT Rd.GetChar(rd) = 'f' *> Lex.Skip(rd); WITH ne = Lex.Int(rd) DO fe.edge := top.edge[ne] END; <* ASSERT Rd.GetChar(rd) = 'e' *> END; END; ReadFooter(rd,"topology"); Wr.PutText(stderr, "rebuilding vertex tables...\n"); RebuildVertexTables(top); RETURN TopCom{top, comments} END END ReadTopology; PROCEDURE RebuildVertexTables(READONLY top: Topology) = VAR b: Pair; BEGIN FOR i := 0 TO top.NE-1 DO WITH pa = top.edge[i].pa DO <* ASSERT pa.facetedge.edge = top.edge[i] *> <* ASSERT top.edge[i].num = i *> top.edge[i].vertex[0] := OrgV(pa); top.edge[i].vertex[1] := OrgV(Clock(pa)) END END; FOR i := 0 TO top.NF-1 DO WITH a = top.face[i].pa, deg = Octf.DegreeFaceRing(a), vr = NEW(REF ARRAY OF Node, deg) DO <* ASSERT a.facetedge.face = top.face[i] *> <* ASSERT top.face[i].num = i *> top.face[i].vertex := vr; b := a; FOR j := 0 TO deg-1 DO vr[j] := Org(b); b := Enext(b); END END END; FOR i := 0 TO top.NP-1 DO WITH a = top.region[i], ptop = MakePolyhedronTopology(a), vr = NEW(REF ARRAY OF Node, ptop.NV) DO <* ASSERT Org(a) = top.polyhedron[i] *> <* ASSERT top.polyhedron[i].num = i *> top.polyhedron[i].vertex := vr; FOR j := 0 TO ptop.NV-1 DO vr[j] := Org(ptop.vRef[j]) END END END; END RebuildVertexTables; PROCEDURE ReadMaterials( rd: Rd.T; READONLY top: Topology; ro_te: BOOLEAN := FALSE; ) = BEGIN (* Materials *) ReadHeader(rd,"materials","99-08-25"); (* Read vertex data Materials: *) EVAL Mis.ReadCommentsJS(rd, '|'); FOR j := 0 TO top.NV-1 DO Lex.Skip(rd); WITH nv = Lex.Int(rd), (* index to vertex *) v = top.vertex[nv] DO <* ASSERT nv = j *> v.num := nv; Lex.Skip(rd); v.exists := Mis.ReadBool(rd); Lex.Skip(rd); v.fixed := Mis.ReadBool(rd); Lex.Skip(rd); WITH cc = v.color DO cc[0] := Lex.Real(rd); Lex.Skip(rd); cc[1] := Lex.Real(rd); Lex.Skip(rd); cc[2] := Lex.Real(rd); END; Lex.Skip(rd); WITH tt = v.transp DO tt[0] := Lex.Real(rd); Lex.Skip(rd); tt[1] := Lex.Real(rd); Lex.Skip(rd); tt[2] := Lex.Real(rd); END; Lex.Skip(rd); v.radius := Lex.Real(rd); Lex.Skip(rd); v.label := Rd.GetText(rd,2); END END; Lex.Skip(rd); (* Read edge data materials: *) EVAL Mis.ReadCommentsJS(rd, '|'); FOR j := 0 TO top.NE-1 DO Lex.Skip(rd); WITH ne = Lex.Int(rd), (* index to edge *) e = top.edge[ne] DO <* ASSERT ne = j *> e.num := ne; Lex.Skip(rd); e.exists := Mis.ReadBool(rd); Lex.Skip(rd); WITH cc = e.color DO cc[0] := Lex.Real(rd); Lex.Skip(rd); cc[1] := Lex.Real(rd); Lex.Skip(rd); cc[2] := Lex.Real(rd); END; Lex.Skip(rd); WITH tt = e.transp DO tt[0] := Lex.Real(rd); Lex.Skip(rd); tt[1] := Lex.Real(rd); Lex.Skip(rd); tt[2] := Lex.Real(rd); END; Lex.Skip(rd); e.radius := Lex.Real(rd); Lex.Skip(rd); e.degenerate := Mis.ReadBool(rd); Lex.Skip(rd); WITH n = Rd.GetChar(rd) DO IF n # '-' THEN Rd.UnGetChar(rd); e.root := Lex.Int(rd); ELSE e.root := -1; END END END END; Lex.Skip(rd); (* Read face data materials: *) EVAL Mis.ReadCommentsJS(rd, '|'); FOR j := 0 TO top.NF-1 DO Lex.Skip(rd); WITH nf = Lex.Int(rd), (* index to face *) f = top.face[nf] DO <* ASSERT nf = j *> f.num := nf; Lex.Skip(rd); f.exists := Mis.ReadBool(rd); Lex.Skip(rd); WITH cc = f.color DO cc[0] := Lex.Real(rd); Lex.Skip(rd); cc[1] := Lex.Real(rd); Lex.Skip(rd); cc[2] := Lex.Real(rd); END; Lex.Skip(rd); WITH tt = f.transp DO tt[0] := Lex.Real(rd); Lex.Skip(rd); tt[1] := Lex.Real(rd); Lex.Skip(rd); tt[2] := Lex.Real(rd); END; Lex.Skip(rd); f.degenerate := Mis.ReadBool(rd); Lex.Skip(rd); WITH n = Rd.GetChar(rd) DO IF n # '-' THEN Rd.UnGetChar(rd); f.root := Lex.Int(rd); ELSE f.root := -1; END END END END; Lex.Skip(rd); (* Read polyhedron data materials: *) IF top.NP # 0 THEN EVAL Mis.ReadCommentsJS(rd, '|'); END; FOR j := 0 TO top.NP-1 DO Lex.Skip(rd); WITH np = Lex.Int(rd), (* index to polyhedron *) p = top.polyhedron[np] DO <* ASSERT np = j *> p.num := np; Lex.Skip(rd); p.exists := Mis.ReadBool(rd); Lex.Skip(rd); WITH cc = p.color DO cc[0] := Lex.Real(rd); Lex.Skip(rd); cc[1] := Lex.Real(rd); Lex.Skip(rd); cc[2] := Lex.Real(rd); END; Lex.Skip(rd); WITH tt = p.transp DO tt[0] := Lex.Real(rd); Lex.Skip(rd); tt[1] := Lex.Real(rd); Lex.Skip(rd); tt[2] := Lex.Real(rd); END; Lex.Skip(rd); p.degenerate := Mis.ReadBool(rd); IF ro_te THEN Lex.Skip(rd); WITH n = Rd.GetChar(rd) DO IF n # '-' THEN Rd.UnGetChar(rd); p.root := Lex.Int(rd); ELSE p.root := -1; END END END END END; ReadFooter(rd,"materials"); Rd.Close(rd); CheckOutAndRegion(top); END ReadMaterials; PROCEDURE ReadToTaMa(name: TEXT; ro_te: BOOLEAN := FALSE): TopCom = (* Where ro_te meaning "root tetrahedron". *) VAR tc: TopCom; BEGIN WITH ntp = name & ".tp", rtp = FileRd.Open(ntp) DO Wr.PutText(stderr, "reading " & ntp & "\n"); tc := ReadTopology(rtp); Wr.PutText(stderr, "OK leio tp\n"); Rd.Close(rtp); END; WITH nma = name & ".ma", rma = FileRd.Open(nma) DO Wr.PutText(stderr, "reading " & nma & "\n"); ReadMaterials(rma, tc.top, ro_te); Rd.Close(rma); END; Wr.PutText(stderr, "OK leio ma\n"); RETURN tc END ReadToTaMa; PROCEDURE ReadState(name: TEXT): REF Coords = <* FATAL Rd.Failure, Thread.Alerted,FloatMode.Trap, Lex.Error, OSError.E *> VAR c: REF Coords; comments: TEXT; nv : CARDINAL; BEGIN WITH rs = FileRd.Open(name & ".st") DO (* Read Headers File Formats*) ReadHeader(rs,"state","99-08-25"); (* Element counts: *) Lex.Skip(rs, cs := AlphaChars); nv := Lex.Int(rs); Lex.Skip(rs); comments := Mis.ReadCommentsJS(rs, '|'); c := NEW(REF Coords, nv); (* Read vertex data state: *) FOR j := 0 TO nv-1 DO Lex.Skip(rs); WITH nv = Lex.Int(rs) DO WITH cv = c[nv] DO cv[0] := Lex.LongReal(rs); Lex.Skip(rs); cv[1] := Lex.LongReal(rs); Lex.Skip(rs); cv[2] := Lex.LongReal(rs); Lex.Skip(rs); cv[3] := Lex.LongReal(rs); END END END; ReadFooter(rs,"state"); Rd.Close(rs); RETURN c; END; END ReadState; PROCEDURE WriteState( name: TEXT; READONLY top: Topology; READONLY c: Coords; comments: TEXT := ""; ) = <* FATAL Wr.Failure, Thread.Alerted *> <* FATAL OSError.E *> BEGIN WITH st = FileWr.Open(name & ".st"), vWidth = Mis.NumDigits(top.NV - 1) DO PROCEDURE WriteCoord(x: LONGREAL) = BEGIN Wr.PutText(st, Fmt.Pad(Fmt.LongReal(x, Fmt.Style.Sci, prec := 3), 7)); END WriteCoord; PROCEDURE WritePoint(READONLY c: LR4.T) = BEGIN WriteCoord(c[0]); Wr.PutText(st, " "); WriteCoord(c[1]); Wr.PutText(st, " "); WriteCoord(c[2]); Wr.PutText(st, " "); WriteCoord(c[3]); END WritePoint; BEGIN WriteHeader(st,"state","99-08-25"); Wr.PutText(st, "vertices "); Wr.PutText(st, Fmt.Int(top.NV) & "\n"); IF NOT Text.Empty(comments) THEN Mis.WriteCommentsJS(st, comments & "\n", '|') END; Mis.WriteCommentsJS(st, "\nVertex data:\n", '|'); FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i] DO (* state *) Wr.PutText(st, Fmt.Pad(Fmt.Int(v.num), vWidth)); Wr.PutText(st, " "); WritePoint(c[v.num]); Wr.PutText(st, "\n"); END END; END; WriteFooter(st, "state"); Wr.Close(st); END; END WriteState; PROCEDURE WriteMaterials( name: TEXT; READONLY top: Topology; comments: TEXT := ""; ro_te: BOOLEAN := FALSE; (* root tetrahedron *) ) = <* FATAL Wr.Failure, Thread.Alerted, OSError.E *> VAR pWidth : INTEGER; BEGIN IF top.NP = 0 THEN pWidth := 2 ELSE pWidth := Mis.NumDigits(top.NP-1) END; WITH ma = FileWr.Open(name & ".ma"), vWidth = Mis.NumDigits(top.NV - 1), fWidth = Mis.NumDigits(top.NF - 1), eWidth = Mis.NumDigits(top.NE - 1) DO PROCEDURE WriteIntensity(r: REAL) = BEGIN Wr.PutText(ma, Fmt.Real(r, Fmt.Style.Fix, prec := 2)); END WriteIntensity; PROCEDURE WriteColor(READONLY c: R3.T) = BEGIN WriteIntensity(c[0]); Wr.PutText(ma, " "); WriteIntensity(c[1]); Wr.PutText(ma, " "); WriteIntensity(c[2]); END WriteColor; PROCEDURE WriteRadius(r: REAL) = BEGIN IF r = 0.02 THEN Wr.PutText(ma, "0.020"); ELSE Wr.PutText(ma,Fmt.Real(r, prec := 4)); END END WriteRadius; PROCEDURE WriteLabel(label: TEXT) = BEGIN Wr.PutText(ma, label); END WriteLabel; BEGIN WriteHeader(ma,"materials","99-08-25"); IF NOT Text.Empty(comments) THEN WriteCommentsJS(ma, comments & "\n", '|') END; WITH m = Mis.NumDigits(top.NP) DO WriteCommentsJS(ma,"vertices " & Fmt.Pad(Fmt.Int(top.NV),m), '|'); WriteCommentsJS(ma,"edges " & Fmt.Pad(Fmt.Int(top.NE),m), '|'); WriteCommentsJS(ma,"faces " & Fmt.Pad(Fmt.Int(top.NF),m), '|'); WriteCommentsJS(ma,"polyhedra " & Fmt.Int(top.NP), '|'); END; WriteCommentsJS(ma, "\nVertex data:\n", '|'); FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i] DO (* materials *) Wr.PutText(ma, Fmt.Pad(Fmt.Int(v.num), vWidth)); Wr.PutText(ma, " "); Wr.PutText(ma, Fmt.Char(Boole[v.exists])); Wr.PutText(ma, " "); Wr.PutText(ma, Fmt.Char(Boole[v.fixed])); Wr.PutText(ma, " "); WriteColor(v.color); Wr.PutText(ma, " "); WriteColor(v.transp); Wr.PutText(ma, " "); WriteRadius(v.radius); Wr.PutText(ma, " "); WriteLabel(v.label); Wr.PutText(ma, "\n"); END END; WriteCommentsJS(ma, "\nEdge data:\n", '|'); FOR i := 0 TO top.NE-1 DO WITH e = top.edge[i] DO (* materials *) Wr.PutText(ma, Fmt.Pad(Fmt.Int(e.num), eWidth)); Wr.PutText(ma, " "); Wr.PutText(ma, Fmt.Char(Boole[e.exists])); Wr.PutText(ma, " "); WriteColor(e.color); Wr.PutText(ma, " "); WriteColor(e.transp); Wr.PutText(ma, " "); WriteRadius(e.radius); Wr.PutText(ma, " "); Wr.PutText(ma, Fmt.Char(Boole[e.degenerate])); Wr.PutText(ma, " "); IF e.root = -1 THEN Wr.PutText(ma, " - "); ELSE Wr.PutText(ma, Fmt.Pad(Fmt.Int(e.root), eWidth)); END; Wr.PutText(ma, "\n"); END END; WriteCommentsJS(ma, "\nFace data:\n", '|'); FOR i := 0 TO top.NF-1 DO WITH f = top.face[i] DO Wr.PutText(ma, Fmt.Pad(Fmt.Int(f.num), fWidth)); Wr.PutText(ma, " "); Wr.PutText(ma, Fmt.Char(Boole[f.exists])); Wr.PutText(ma, " "); WriteColor(f.color); Wr.PutText(ma, " "); WriteColor(f.transp); Wr.PutText(ma, " "); Wr.PutText(ma, Fmt.Char(Boole[f.degenerate])); Wr.PutText(ma, " "); IF f.root = -1 THEN Wr.PutText(ma, " - "); ELSE Wr.PutText(ma, Fmt.Pad(Fmt.Int(f.root), fWidth)); END; Wr.PutText(ma, "\n"); END END; IF top.NP # 0 THEN WriteCommentsJS(ma, "\nPolyhedron data:\n", '|'); END; FOR i := 0 TO top.NP-1 DO WITH p = top.polyhedron[i] DO Wr.PutText(ma, Fmt.Pad(Fmt.Int(p.num), pWidth)); Wr.PutText(ma, " "); Wr.PutText(ma, Fmt.Char(Boole[p.exists])); Wr.PutText(ma, " "); WriteColor(p.color); Wr.PutText(ma, " "); WriteColor(p.transp); Wr.PutText(ma, " "); Wr.PutText(ma, Fmt.Char(Boole[p.degenerate])); IF ro_te THEN Wr.PutText(ma, " "); IF p.root = -1 THEN Wr.PutText(ma, " - "); ELSE Wr.PutText(ma, Fmt.Pad(Fmt.Int(p.root), pWidth)); END END; Wr.PutText(ma, "\n"); END END END; WriteFooter(ma, "materials"); Wr.Close(ma); END; END WriteMaterials; PROCEDURE FindDegeneracies(READONLY top: Topology) = VAR allTriangles, allTetrahedra: BOOLEAN; vei, vej: REF ARRAY OF INTEGER; vfi, vfj: REF ARRAY OF INTEGER; vpi, vpj: REF ARRAY OF INTEGER; BEGIN (* Clean the marks for the attribute degenerate *) FOR i := 0 TO top.NE-1 DO WITH ei = top.edge[i] DO ei.degenerate := FALSE END END; (* Now, find edge degeneracies *) vei := NEW(REF ARRAY OF INTEGER, 2); vej := NEW(REF ARRAY OF INTEGER, 2); FOR i := 0 TO top.NE-1 DO FOR j := i+1 TO top.NE-1 DO WITH ei = NARROW(top.edge[i], Edge), ej = NARROW(top.edge[j], Edge) DO FOR k := 0 TO 1 DO vei[k] := ei.vertex[k].num; vej[k] := ej.vertex[k].num END; Mis.InsertionSort(1,vei); Mis.InsertionSort(1,vej); IF (vei[0] = vej[0]) AND (vei[1] = vej[1]) THEN ei.degenerate := TRUE; ej.degenerate := TRUE; END END END END; (* Clean the marks for the attribute degenerate *) allTriangles := TRUE; FOR i := 0 TO top.NF-1 DO WITH fi = top.face[i], di = NUMBER(fi.vertex^) DO fi.degenerate := (di # 3); allTriangles := allTriangles AND (di = 3) END END; IF NOT allTriangles THEN RETURN END; (* Now, find degenerate pairs of triangles *) vfi := NEW(REF ARRAY OF INTEGER, 3); vfj := NEW(REF ARRAY OF INTEGER, 3); FOR i := 0 TO top.NF-1 DO FOR j := i+1 TO top.NF-1 DO WITH fi = top.face[i], fj = top.face[j] DO FOR k := 0 TO 2 DO vfi[k] := fi.vertex^[k].num; vfj[k] := fj.vertex^[k].num END; Mis.InsertionSort(2,vfi); Mis.InsertionSort(2,vfj); IF (vfi[0] = vfj[0]) AND (vfi[1] = vfj[1]) AND (vfi[2] = vfj[2]) THEN fi.degenerate := TRUE; fj.degenerate := TRUE END END END END; (* Clean the marks for the attribute degenerate *) allTetrahedra := TRUE; FOR i := 0 TO top.NP-1 DO WITH pi = top.polyhedron[i], di = NUMBER(pi.vertex^) DO pi.degenerate := (di # 4); allTetrahedra := allTetrahedra AND (di = 4) END END; IF NOT allTetrahedra THEN RETURN END; (* Now, find polyhedron degeneracies *) vpi := NEW(REF ARRAY OF INTEGER, 4); vpj := NEW(REF ARRAY OF INTEGER, 4); FOR i := 0 TO top.NP-1 DO FOR j := i+1 TO top.NP-1 DO WITH pi = top.polyhedron[i], pj = top.polyhedron[j] DO FOR k := 0 TO 3 DO vpi[k] := pi.vertex^[k].num; vpj[k] := pj.vertex^[k].num END; Mis.InsertionSort(3,vpi); Mis.InsertionSort(3,vpj); IF (vpi[0]=vpj[0]) AND (vpi[1]=vpj[1]) AND (vpi[2]=vpj[2]) AND (vpi[3]=vpj[3]) THEN pi.degenerate := TRUE; pj.degenerate := TRUE; END END END END END FindDegeneracies; PROCEDURE WriteTopology( name: TEXT; READONLY top: Topology; comments: TEXT := " "; ) = <* FATAL Wr.Failure, Thread.Alerted, OSError.E *> VAR pWidth : INTEGER; BEGIN IF top.NP = 0 THEN pWidth:= 2 ELSE pWidth := Mis.NumDigits(top.NP-1) END; WITH tp = FileWr.Open(name & ".tp"), vWidth = Mis.NumDigits(top.NV - 1), eWidth = Mis.NumDigits(top.NE - 1), fWidth = Mis.NumDigits(top.NF - 1), feWidth = Mis.NumDigits(top.NFE -1) DO WriteHeader(tp,"topology","99-08-25"); IF NOT Text.Empty(comments) THEN WriteCommentsJS(tp, comments & "\n", '|') END; WITH m = Mis.NumDigits(top.NFE) DO Wr.PutText(tp, "vertices "); Wr.PutText(tp, Fmt.Pad(Fmt.Int(top.NV),m) & "\n"); Wr.PutText(tp, "edges "); Wr.PutText(tp, Fmt.Pad(Fmt.Int(top.NE),m) & "\n"); Wr.PutText(tp, "faces "); Wr.PutText(tp, Fmt.Pad(Fmt.Int(top.NF),m) & "\n"); Wr.PutText(tp, "polyhedra "); Wr.PutText(tp, Fmt.Pad(Fmt.Int(top.NP),m) & "\n"); Wr.PutText(tp, "facetedges "); Wr.PutText(tp, Fmt.Int(top.NFE) & "\n"); Wr.PutText(tp, "der "); Wr.PutText(tp, Fmt.Pad(Fmt.Int(top.der),m) & "\n"); Wr.PutText(tp, "bdr "); Wr.PutText(tp, Fmt.Pad(Fmt.Int(top.bdr),m) & "\n"); END; WriteCommentsJS(tp, "\nEdge data:\n", '|'); FOR i := 0 TO top.NE-1 DO WITH e = top.edge[i] DO Wr.PutText(tp, Fmt.Pad(Fmt.Int(e.num), eWidth)); Wr.PutText(tp, " "); Octf.PrintPair(tp, e.pa, eWidth+1, TRUE); END END; WriteCommentsJS(tp, "\nFace data:\n", '|'); FOR i := 0 TO top.NF-1 DO WITH f = top.face[i] DO Wr.PutText(tp, Fmt.Pad(Fmt.Int(f.num), fWidth)); Wr.PutText(tp, " "); Octf.PrintPair(tp, f.pa, fWidth+1, TRUE); END END; WriteCommentsJS(tp, "\nFacetEdge data:\n", '|'); FOR i := 0 TO top.NFE-1 DO WITH fe = NARROW(top.facetedge[i].facetedge, FacetEdge) DO Wr.PutText(tp, Fmt.Pad(Fmt.Int(fe.num), feWidth)); Wr.PutText(tp, " "); Octf.PrintFacetEdge(tp, fe, feWidth); Wr.PutText(tp, " "); FOR j := 0 TO 3 DO WITH n = fe.org[j] DO TYPECASE n OF | NULL => FOR i:= 0 TO pWidth-2 DO Wr.PutText(tp," "); END; Wr.PutText(tp, " - "); | Vertex(v) => Wr.PutText(tp, Fmt.Pad(Fmt.Int(v.num), vWidth) & "v "); | Polyhedron(p) => Wr.PutText(tp, Fmt.Pad(Fmt.Int(p.num), pWidth) & "p "); ELSE (* nothing *) END; END; END; Wr.PutText(tp, " "); WITH f = fe.face DO Wr.PutText(tp, Fmt.Pad(Fmt.Int(f.num), fWidth)); END; Wr.PutText(tp, "f "); WITH e = fe.edge DO Wr.PutText(tp, Fmt.Pad(Fmt.Int(e.num), eWidth)); END; Wr.PutText(tp, "e\n"); END END; WriteFooter(tp, "topology"); Wr.Close(tp); END; END WriteTopology; PROCEDURE WriteDualTopology( name: TEXT; READONLY top: Topology; comments: TEXT := " "; ) = <* FATAL Wr.Failure, Thread.Alerted, OSError.E *> PROCEDURE PrintDualPair(wr: Wr.T; a: Pair; feWidth: CARDINAL) = BEGIN Wr.PutText(wr,Fmt.Pad(Fmt.Int(a.facetedge.num), feWidth) & ":" & Fmt.Int((Octf.SrotBits(a)+ 3) MOD 4) & ":" & Fmt.Int(Octf.SpinBit(a))); END PrintDualPair; PROCEDURE PrintDualFacetEdge(wr: Wr.T; n: FacetEdge; feWidth: CARDINAL) = VAR b: Pair; BEGIN b := Srot(Pair{facetedge := n, bits := 0}); FOR i := 0 TO 3 DO PrintDualPair(wr, Fnext(b), feWidth); Wr.PutText(wr, " "); b := Srot(b) END END PrintDualFacetEdge; BEGIN WITH tp = FileWr.Open(name & ".tp"), vWidth = Mis.NumDigits(MAX(1,top.NV - 1)), eWidth = Mis.NumDigits(MAX(1,top.NE - 1)), fWidth = Mis.NumDigits(MAX(1,top.NF - 1)), pWidth = Mis.NumDigits(MAX(1,top.NP - 1)), feWidth = Mis.NumDigits(MAX(1,top.NFE -1)) DO WriteHeader(tp,"topology","99-08-25"); IF NOT Text.Empty(comments) THEN WriteCommentsJS(tp, comments & "\n", '|') END; WITH m = Mis.NumDigits(top.NFE) DO Wr.PutText(tp, "vertices "); Wr.PutText(tp, Fmt.Pad(Fmt.Int(top.NP),m) & "\n"); Wr.PutText(tp, "edges "); Wr.PutText(tp, Fmt.Pad(Fmt.Int(top.NF),m) & "\n"); Wr.PutText(tp, "faces "); Wr.PutText(tp, Fmt.Pad(Fmt.Int(top.NE),m) & "\n"); Wr.PutText(tp, "polyhedra "); Wr.PutText(tp, Fmt.Pad(Fmt.Int(top.NV),m) & "\n"); Wr.PutText(tp, "facetedges "); Wr.PutText(tp, Fmt.Int(top.NFE) & "\n"); Wr.PutText(tp, "der "); Wr.PutText(tp, Fmt.Pad(Fmt.Int(1),m) & "\n"); Wr.PutText(tp, "bdr "); Wr.PutText(tp, Fmt.Pad(Fmt.Int(1),m) & "\n"); END; WriteCommentsJS(tp, "\nEdge data:\n", '|'); FOR i := 0 TO top.NF-1 DO WITH f = top.face[i] DO Wr.PutText(tp, Fmt.Pad(Fmt.Int(f.num), fWidth)); Wr.PutText(tp, " "); Octf.PrintPair(tp, f.pa, feWidth); (* [sic] *) Wr.PutText(tp, "\n") END END; WriteCommentsJS(tp, "\nFace data:\n", '|'); FOR i := 0 TO top.NE-1 DO WITH e = top.edge[i] DO Wr.PutText(tp, Fmt.Pad(Fmt.Int(e.num), eWidth)); Wr.PutText(tp, " "); Octf.PrintPair(tp, e.pa, feWidth+1); (* [sic] *) Wr.PutText(tp, "\n") END END; WriteCommentsJS(tp, "\nFacetEdge data:\n", '|'); FOR i := 0 TO top.NFE-1 DO WITH fe = NARROW(top.facetedge[i].facetedge, FacetEdge) DO Wr.PutText(tp, Fmt.Pad(Fmt.Int(fe.num), feWidth)); Wr.PutText(tp, " "); PrintDualFacetEdge(tp, fe, feWidth); Wr.PutText(tp, " "); FOR j := 0 TO 3 DO WITH n = fe.org[(j+1) MOD 4] DO TYPECASE n OF | NULL => FOR i:= 0 TO pWidth-2 DO Wr.PutText(tp," "); END; Wr.PutText(tp, " - "); | Vertex(v) => Wr.PutText(tp, Fmt.Pad(Fmt.Int(v.num), vWidth) & "p "); | Polyhedron(p) => Wr.PutText(tp, Fmt.Pad(Fmt.Int(p.num), pWidth) & "v "); ELSE (* nothing *) END; END; END; Wr.PutText(tp, " "); WITH e = fe.edge DO Wr.PutText(tp, Fmt.Pad(Fmt.Int(e.num), eWidth)); END; Wr.PutText(tp, "f "); WITH f = fe.face DO Wr.PutText(tp, Fmt.Pad(Fmt.Int(f.num), fWidth)); END; Wr.PutText(tp, "e"); Wr.PutText(tp, "\n"); END END; WriteFooter(tp, "topology"); Wr.Close(tp); END; END WriteDualTopology; PROCEDURE WriteTable( name: TEXT; READONLY top: Topology; comments: TEXT := ""; <*UNUSED*> debug : BOOLEAN := FALSE; ) = <* FATAL Wr.Failure, Thread.Alerted, OSError.E *> BEGIN RebuildVertexTables(top); WITH tab = FileWr.Open(name & ".tb"), vWidth = Mis.NumDigits(MAX(1, top.NV - 1)), eWidth = Mis.NumDigits(MAX(1, top.NE - 1)), fWidth = Mis.NumDigits(MAX(1, top.NF - 1)), pWidth = Mis.NumDigits(MAX(1, top.NP - 1)) DO WriteHeader(tab,"table","99-08-25"); IF NOT Text.Empty(comments) THEN Mis.WriteCommentsJS(tab, comments & "\n", '|') END; (* Now, writes edge vertices *) Mis.WriteCommentsJS(tab,"\nEdge data:\n", '|'); FOR i := 0 TO top.NE-1 DO WITH e = top.edge[i] DO Wr.PutText(tab, Fmt.Pad(Fmt.Int(e.num), eWidth)); Wr.PutText(tab, " "); Wr.PutText(tab, Fmt.Pad(Fmt.Int(e.vertex[0].num),eWidth) & "v "); Wr.PutText(tab, Fmt.Pad(Fmt.Int(e.vertex[1].num),eWidth) & "v\n"); END; END; (* Now, writes face vertices *) Mis.WriteCommentsJS(tab, "\nFace data:\n", '|'); FOR i := 0 TO top.NF-1 DO WITH f = top.face[i], fv = f.vertex^ DO Wr.PutText(tab, Fmt.Pad(Fmt.Int(f.num), fWidth)); Wr.PutText(tab, " "); FOR j := 0 TO LAST(fv) DO Wr.PutText(tab,Fmt.Pad(Fmt.Int(fv[j].num), vWidth) & "v "); END; Wr.PutText(tab, "\n"); END END; (* Now, writes polyhedron vertices *) IF top.NP # 0 THEN Mis.WriteCommentsJS(tab, "\nPolyhedron data:\n", '|'); END; FOR i := 0 TO top.NP-1 DO WITH p = top.polyhedron[i], pv = p.vertex^ DO Wr.PutText(tab, Fmt.Pad(Fmt.Int(p.num), pWidth)); Wr.PutText(tab, " "); FOR j := 0 TO LAST(pv) DO Wr.PutText(tab,Fmt.Pad(Fmt.Int(pv[j].num), vWidth) & "v "); END; Wr.PutText(tab, "\n"); END END; WriteFooter(tab, "table"); Wr.Close(tab); END; END WriteTable; PROCEDURE WriteStDe( wr: Wr.T; READONLY c: Coords; READONLY Dc: Coords; prec: CARDINAL := 4; comments: TEXT := ""; ) = PROCEDURE WriteCoord(x: LONGREAL) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(wr, Fmt.LongReal(x, Fmt.Style.Sci, prec := prec)) END WriteCoord; PROCEDURE WritePoint(READONLY p: LR4.T) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WriteCoord(p[1]); Wr.PutText(wr, " "); WriteCoord(p[0]); Wr.PutText(wr, " "); WriteCoord(p[2]); Wr.PutText(wr, " "); WriteCoord(p[3]); Wr.PutText(wr, " "); END WritePoint; <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH NV = NUMBER(c), d = Mis.NumDigits(NV-1) DO WriteHeader(wr,"state-derivatives","99-08-25"); Mis.WriteCommentsJS(wr, "\n" & comments & "\n",'|'); Wr.PutText(wr, "vertices = " & Fmt.Int(NV) & "\n"); FOR i := 0 TO NV-1 DO Wr.PutText(wr, Fmt.Pad(Fmt.Int(i), d) & ": "); WritePoint(c[i]); Wr.PutText(wr, " "); (* if the derivatives of vertices are zero them writes "0 0 0 0" else writes velocites with the format for write points defined here. *) IF Dc[i][0] = 0.0d0 AND Dc[i][1] = 0.0d0 AND Dc[i][2] = 0.0d0 AND Dc[i][3] = 0.0d0 THEN Wr.PutText(wr, "0 0 0 0") ELSE WritePoint(Dc[i]) END; Wr.PutText(wr, "\n"); END; WriteFooter(wr, "state-derivatives"); Wr.PutText(wr, "\n"); Wr.Flush(wr); END; END WriteStDe; BEGIN END Triangulation. (* (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) *) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Mapi.m3 MODULE Mapi; (* This module contain essentially procedures created by J. Stolfi and R. Marcone (see the copyright and authorship futher down), modified L. P. Lozada for the case tridimensional. *) IMPORT Octf, Triangulation, Word; FROM Octf IMPORT Spin; REVEAL FacetEdge = PublicFacetEdge BRANDED OBJECT OVERRIDES init := MapInit; END; PROCEDURE MapInit(s: FacetEdge; order1,order2: CARDINAL): FacetEdge = BEGIN EVAL NARROW(s, Octf.FacetEdge).init(); s.ca := Triangulation.MakeTetraTopo(order1,order2); s.order1 := order1; s.order2 := order2; RETURN s END MapInit; PROCEDURE MakeFacetEdge(order1,order2: CARDINAL): Pair = BEGIN WITH e = NEW(FacetEdge).init(order1,order2) DO RETURN Pair{facetedge := e, bits := 0}; END; END MakeFacetEdge; PROCEDURE Corner(a: Pair): Triangulation.Pair = BEGIN WITH r = a.bits DO RETURN a.facetedge.ca[r]; END; END Corner; PROCEDURE SetCorner(a: Pair; c: Triangulation.Pair) = BEGIN WITH r = a.bits DO a.facetedge.ca[r] := c; END; END SetCorner; PROCEDURE CCorner(a: Pair): Triangulation.Pair = BEGIN WITH r = Word.Xor(a.bits, 1) DO RETURN Spin(a.facetedge.ca[r]); END; END CCorner; PROCEDURE SetCCorner(a: Pair; c: Triangulation.Pair) = BEGIN WITH r = Word.Xor(a.bits, 1) DO a.facetedge.ca[r] := Spin(c); END; END SetCCorner; BEGIN END Mapi. (* ***************** START OF COPYRIGHT AND AUTHORSHIP NOTICE ********** All files in this directory tree are Copyright 1996 by Jorge Stolfi, Rober Marcone Rosi, and Universidade Estadual de Campinas, Brazil--- unless stated otherwise in the files themselves. THESE FILES ARE DISTRIBUTED WITH NO GUARANTEE OF ANY KIND. Neither the authors nor their employers may be held responsible for any losses or damages attributed to their use. These files may be freely copied, distributed, modified, and used for any purpose; provided that any subtantial excerpt of these files that is redistributed or incorporated in other software packages is accompanied by this copyright and authorship notice, and is made freely available under these same terms. ***************** END OF COPYRIGHT AND AUTHORSHIP NOTICE ************ *)~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Mis.m3 MODULE Mis; (* This module contain "miscelaneus" procedures reused without extensive modifications, created by J. Stolfi and R. Marcone. See the copyright and authorship futher down. Last Modification: 06-01-00 by lozada *) IMPORT Wr, Rd, TextRd, TextWr, Thread, Fmt, R3, LR4, Random, Lex, LR3, Date, Time, LR2; PROCEDURE InitLongReal(coins: Random.T; radius: REAL:= 0.20): LONGREAL = BEGIN WITH r = FLOAT(radius, LONGREAL), p = coins.longreal(-r,r) DO RETURN p; END END InitLongReal; PROCEDURE WriteLong(wr: Wr.T; x: LONGREAL) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(wr, Fmt.Pad(Fmt.LongReal(x, Fmt.Style.Fix, prec := 2), 8)); END WriteLong; PROCEDURE WriteInt(wr: Wr.T; x: INTEGER) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(wr, Fmt.Pad(Fmt.Int(x), 4)); END WriteInt; PROCEDURE WriteCoord(wr: Wr.T; x: LONGREAL) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(wr, Fmt.Pad(Fmt.LongReal(x, Fmt.Style.Fix, prec := 5), 10)); END WriteCoord; PROCEDURE WritePoint4D(wr: Wr.T; READONLY c: LR4.T) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WriteCoord(wr, c[0]); Wr.PutText(wr, " "); WriteCoord(wr, c[1]); Wr.PutText(wr, " "); WriteCoord(wr, c[2]); Wr.PutText(wr, " "); WriteCoord(wr, c[3]); END WritePoint4D; PROCEDURE WritePoint3D(wr: Wr.T; READONLY c: LR3.T) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WriteCoord(wr, c[0]); Wr.PutText(wr, " "); WriteCoord(wr, c[1]); Wr.PutText(wr, " "); WriteCoord(wr, c[2]); Wr.PutText(wr, " "); END WritePoint3D; PROCEDURE WritePoint2D(wr: Wr.T; READONLY c: LR2.T) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WriteCoord(wr, c[0]); Wr.PutText(wr, " "); WriteCoord(wr, c[1]); Wr.PutText(wr, " "); END WritePoint2D; PROCEDURE WriteIntensity(wr: Wr.T; r: REAL) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(wr, Fmt.Real(r, Fmt.Style.Fix, prec := 2)); END WriteIntensity; PROCEDURE WriteColor(wr: Wr.T; READONLY c: R3.T) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WriteIntensity(wr, c[0]); Wr.PutText(wr, " "); WriteIntensity(wr, c[1]); Wr.PutText(wr, " "); WriteIntensity(wr, c[2]); END WriteColor; PROCEDURE WriteRadius(wr: Wr.T; r: REAL) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(wr, Fmt.Real(r, prec := 2)); END WriteRadius; EXCEPTION MissingFinalNewLine; PROCEDURE WriteCommentsJS(wr: Wr.T; comments: TEXT; prefix: CHAR) = (* Writes the given "comments" text to "wr", with a "prefix" character and a blank in front of every line. Supplies a final '\n' if the text is non-empty but does not end with newline. *) VAR rd: Rd.T := TextRd.New(comments); PROCEDURE CopyLine() RAISES {Rd.EndOfFile} = (* Copy one line from "rd" to "wr", prefixed by "prefix" and a space. Supplies a final '\n' if the next line exists but does NOT end with newline. Raises "Rd.EndOfFile" if there are no more lines in "rd". *) <* FATAL Rd.Failure, Wr.Failure, Thread.Alerted *> VAR c: CHAR; BEGIN c := Rd.GetChar(rd); (* If EOF here, propagate to caller *) Wr.PutChar(wr, prefix); Wr.PutChar(wr, ' '); Wr.PutChar(wr, c); WHILE c # '\n' DO TRY c := Rd.GetChar(rd) EXCEPT Rd.EndOfFile => c := '\n' END; Wr.PutChar(wr, c) END END CopyLine; BEGIN TRY LOOP CopyLine() END EXCEPT Rd.EndOfFile => (* Ok *) END; END WriteCommentsJS; PROCEDURE ReadBool(rd: Rd.T): BOOLEAN RAISES {Lex.Error} = <* FATAL Rd.Failure, Rd.EndOfFile, Thread.Alerted *> BEGIN WITH c = Rd.GetChar(rd) DO IF c = 'T' THEN RETURN TRUE ELSIF c = 'F' THEN RETURN FALSE ELSE Rd.UnGetChar(rd); RAISE Lex.Error END END END ReadBool; PROCEDURE ReadCommentsJS(rd: Rd.T; prefix: CHAR): TEXT = VAR wr: Wr.T := TextWr.New(); PROCEDURE CopyLine() RAISES {Rd.EndOfFile} = (* Copy one comment line from "rd" to "wr", removing the "prefix" and the following blank, but leaving the final (mandatory) newline. Raises "Rd.EndOfFile" if "rd" is exhausted or the next char is not "prefix". *) <* FATAL Rd.Failure, Wr.Failure, Thread.Alerted *> <* FATAL MissingFinalNewLine *> VAR c: CHAR; BEGIN c := Rd.GetChar(rd); (* If EOF here, propagate to caller *) IF c # prefix THEN Rd.UnGetChar(rd); RAISE Rd.EndOfFile END; TRY c := Rd.GetChar(rd) EXCEPT Rd.EndOfFile => RAISE MissingFinalNewLine END; IF c = ' ' THEN TRY c := Rd.GetChar(rd) EXCEPT Rd.EndOfFile => RAISE MissingFinalNewLine END; END; WHILE c # '\n' DO Wr.PutChar(wr, c); TRY c := Rd.GetChar(rd) EXCEPT Rd.EndOfFile => RAISE MissingFinalNewLine END; END; Wr.PutChar(wr, c); END CopyLine; BEGIN TRY LOOP CopyLine() END EXCEPT Rd.EndOfFile => (* Ok *) END; RETURN TextWr.ToText(wr); END ReadCommentsJS; PROCEDURE NumDigits(n: CARDINAL): CARDINAL = (* Width of "n" when printed. *) VAR w: CARDINAL := 1; BEGIN WHILE n > 9 DO INC(w); n := n DIV 10 END; RETURN w END NumDigits; PROCEDURE InsertionSort(n: CARDINAL; VAR a: REF ARRAY OF INTEGER) = PROCEDURE cmp(a,b: INTEGER) : INTEGER = (* compare two integer values *) BEGIN IF a > b THEN RETURN 1; ELSIF a < b THEN RETURN -1; ELSE RETURN 0; END; END cmp; VAR j,lo,hi,key: INTEGER; BEGIN lo := 0; hi := n+1; FOR i := lo+1 TO hi-1 DO key := a[i]; j := i-1; WHILE (j >= lo) AND cmp (key, a[j]) < 0 DO a[j+1] := a[j]; DEC (j); END; a[j+1] := key; END; END InsertionSort; PROCEDURE Sort(n: CARDINAL; VAR a: REF ARRAY OF CARDINAL) = PROCEDURE cmp(a,b: CARDINAL) : INTEGER = (* compare two CARDINAL values *) BEGIN IF a > b THEN RETURN 1; ELSIF a < b THEN RETURN -1; ELSE RETURN 0; END; END cmp; VAR j,lo,hi,key: INTEGER; BEGIN lo := 0; hi := n+1; FOR i := lo+1 TO hi-1 DO key := a[i]; j := i-1; WHILE (j >= lo) AND cmp (key, a[j]) < 0 DO a[j+1] := a[j]; DEC (j); END; a[j+1] := key; END; END Sort; PROCEDURE Today(): TEXT = (* Print the character chain with the actual date and time. *) BEGIN WITH d = Date.FromTime(Time.Now(), Date.Local) DO RETURN Fmt.Pad(Fmt.Int(d.year - 0), 4, '0') & "-" & Fmt.Pad(Fmt.Int(ORD(d.month)+1), 2, '0') & "-" & Fmt.Pad(Fmt.Int(d.day), 2, '0') & " at " & Fmt.Pad(Fmt.Int(d.hour), 2, '0') & ":" & Fmt.Pad(Fmt.Int(d.minute), 2, '0') & ":" & Fmt.Pad(Fmt.Int(d.second), 2, '0') END END Today; (* use so: VAR f : REF ARRAY OF INTEGER f := NEW(REF ARRAY OF INTEGER, n) FOR i := 0 TO n-1 DO f[i] := END InsertionSort(n-1,f); *) BEGIN END Mis. (* ***************** START OF COPYRIGHT AND AUTHORSHIP NOTICE ********** All files in this directory tree are Copyright 1996 by Jorge Stolfi, Rober Marcone Rosi, and Universidade Estadual de Campinas, Brazil--- unless stated otherwise in the files themselves. THESE FILES ARE DISTRIBUTED WITH NO GUARANTEE OF ANY KIND. Neither the authors nor their employers may be held responsible for any losses or damages attributed to their use. These files may be freely copied, distributed, modified, and used for any purpose; provided that any subtantial excerpt of these files that is redistributed or incorporated in other software packages is accompanied by this copyright and authorship notice, and is made freely available under these same terms. ***************** END OF COPYRIGHT AND AUTHORSHIP NOTICE ************ *)~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/MixedEnergy.m3 MODULE MixedEnergy; IMPORT Fmt, Wr, Thread, TextWr, Energy, LR4; FROM Triangulation IMPORT Topology; FROM Energy IMPORT Coords, Gradient; REVEAL T = Public BRANDED OBJECT ekDc: REF ARRAY OF LR4.T; (* (Work) Gradient of some ingredient *) OVERRIDES init := Init; defTop := DefTop; defVar := DefVar; eval := Eval; name := Name; END; PROCEDURE Init(erg: T; READONLY term: ARRAY OF Energy.T; READONLY weight: ARRAY OF REAL ): T = BEGIN WITH NT = NUMBER(term) DO <* ASSERT NUMBER(weight) = NT *> erg.term := NEW(REF ARRAY OF Energy.T, NT); erg.weight := NEW(REF ARRAY OF REAL, NT); erg.termValue := NEW(REF ARRAY OF LONGREAL, NT); erg.term^ := term; erg.weight^ := weight; RETURN erg END END Init; PROCEDURE DefTop(erg: T; READONLY top: Topology) = (* defTop(), for each energy ingredient *) BEGIN WITH term = erg.term^, NT = NUMBER(term) DO erg.ekDc := NEW(REF ARRAY OF LR4.T, top.NV); FOR k := 0 TO NT-1 DO term[k].defTop(top) END END; END DefTop; PROCEDURE DefVar(erg: T; READONLY variable: ARRAY OF BOOLEAN) = (* defVar(), for each energy ingredient *) BEGIN WITH term = erg.term^, NT = NUMBER(term) DO FOR k := 0 TO NT-1 DO term[k].defVar(variable) END END; END DefVar; PROCEDURE Eval(erg: T; READONLY c: Coords; VAR e: LONGREAL; grad: BOOLEAN; VAR eDc: Gradient; ) = (* eval(), for each energy ingredient *) BEGIN WITH term = erg.term^, weight = erg.weight^, termValue = erg.termValue^, ekDc = erg.ekDc^, NT = NUMBER(term), NV = NUMBER(c) DO <* ASSERT NUMBER(eDc) = NV *> e := 0.0d0; FOR v := 0 TO NV-1 DO eDc[v] := LR4.T{0.0d0, ..} END; FOR k := 0 TO NT-1 DO term[k].eval(c, termValue[k], grad, ekDc); e := e + FLOAT(weight[k], LONGREAL) * termValue[k]; IF grad THEN FOR v := 0 TO NV-1 DO eDc[v] := LR4.Mix(1.0d0,eDc[v], FLOAT(weight[k], LONGREAL), ekDc[v]) END END END END; END Eval; PROCEDURE Name(erg: T): TEXT = <* FATAL Wr.Failure, Thread.Alerted *> VAR wr := NEW(TextWr.T).init(); (* escritor de texto *) BEGIN WITH term = erg.term^, weight = erg.weight^, NT = NUMBER(term) DO Wr.PutText(wr, "Mixed("); FOR i := 0 TO NT-1 DO IF i > 0 THEN Wr.PutText(wr, ",\n") END; IF i = 0 THEN Wr.PutText(wr, "["); ELSE Wr.PutText(wr, " ["); END; Wr.PutText(wr, Fmt.Int(i)); Wr.PutText(wr, "] = "); Wr.PutText(wr, Fmt.Real(weight[i], Fmt.Style.Fix, 2)); Wr.PutText(wr, "·"); Wr.PutText(wr, term[i].name() ) END; Wr.PutText(wr, ")") END; RETURN TextWr.ToText(wr) END Name; BEGIN END MixedEnergy. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/ModKamSpring.m3 MODULE ModKamSpring; (* Last Version: 18-11-2000 *) IMPORT LR4, Triangulation, Fmt, Stdio, Wr, Thread, Octf; FROM Triangulation IMPORT Topology, OrgV; FROM Energy IMPORT Coords, Gradient; FROM Stdio IMPORT stderr; FROM Octf IMPORT Clock; CONST inf = LAST(CARDINAL); TYPE BOOLS = ARRAY OF BOOLEAN; LONGS = ARRAY OF LONGREAL; AdjacencyMatrix = ARRAY OF ARRAY OF CARDINAL; REVEAL T = Public BRANDED OBJECT top: Topology; (* The topology *) termVar: REF BOOLS; (* TRUE if vertex is variable & existing *) m : REF AdjacencyMatrix; (* Matrix of initial distances *) eDdif: REF ARRAY OF LONGS; (* (Work) Gradient of "e" rel. to "dif" *) L : LONGREAL; (* length of spring *) OVERRIDES init := Init; defTop := DefTop; defVar := DefVar; eval := Eval; name := Name; END; PROCEDURE Init(erg: T): T = BEGIN RETURN erg END Init; PROCEDURE DefTop(erg: T; READONLY top: Topology) = VAR dmax : LONGREAL; BEGIN WITH NV = top.NV DO erg.m := MakeAdjacencyMatrix(top); (*PrintHalfMatrix(erg.m, NV);*) ShortestPath(erg.m, NV); (*PrintHalfMatrix(erg.m, NV);*) dmax := FLOAT(FindMaxDistance(erg.m, NV), LONGREAL); erg.L := FLOAT(erg.length,LONGREAL)/dmax; erg.top := top; erg.termVar := NEW(REF BOOLS, NV); erg.eDdif := NEW(REF ARRAY OF LONGS, NV, NV); (*PrintHalfMatrix(erg.k, NV);*) (* Just in case the client forgets to call "defVar": *) FOR i := 0 TO top.NV-1 DO erg.termVar^[i] := FALSE END; END END DefTop; PROCEDURE DefVar(erg: T; READONLY variable: BOOLS) = BEGIN (* Decide which vertices are relevant to kamada energy. A vertex is relevant iff it is variable. *) WITH NV = erg.top.NV, termVar = erg.termVar^ DO (* Find the relevant vertices: *) <* ASSERT NUMBER(variable) = NV *> FOR v := 0 TO NV-1 DO termVar[v] := variable[v]; END END END DefVar; PROCEDURE MakeAdjacencyMatrix( READONLY top : Triangulation.Topology; ) : REF AdjacencyMatrix = VAR m: REF AdjacencyMatrix; BEGIN m := NEW(REF ARRAY OF ARRAY OF CARDINAL, top.NV, top.NV); FOR i := 0 TO top.NV-1 DO FOR j := 0 TO top.NV-1 DO m[i,j] := inf; END; m[i,i] := 0; END; FOR i := 0 TO top.NE-1 DO WITH a = top.edge[i].pa, i = OrgV(a).num, j = OrgV(Clock(a)).num DO m[i,j] := 1; m[j,i] := 1; END END; RETURN m; END MakeAdjacencyMatrix; PROCEDURE FindMaxDistance( READONLY m: REF AdjacencyMatrix; n: INTEGER; ) : CARDINAL = VAR max := 0; BEGIN FOR i := 0 TO n-1 DO FOR j := 0 TO i DO IF m[i,j] > max THEN max := m[i,j]; END END END; RETURN max; END FindMaxDistance; PROCEDURE CalculateStrength(dist : CARDINAL) : LONGREAL = BEGIN IF dist = 0 THEN RETURN 0.0d0 ELSE WITH d = FLOAT(dist, LONGREAL) DO RETURN 1.0d0/(d*d); END END END CalculateStrength; PROCEDURE CalculateLength(dist : CARDINAL) : LONGREAL = BEGIN IF dist = 0 THEN RETURN 0.0d0 ELSE WITH d = FLOAT(dist, LONGREAL) DO RETURN d; END END END CalculateLength; <* UNUSED *> PROCEDURE PrintAdjacencyMatrix(READONLY m : REF AdjacencyMatrix; n: INTEGER) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN FOR i := 0 TO n-1 DO FOR j := 0 TO n-1 DO IF m[i,j] = inf THEN Wr.PutText(stderr, "# "); ELSE Wr.PutText(stderr, Fmt.Int(m[i,j]) & " "); END; END; Wr.PutText(stderr, "\n"); END; END PrintAdjacencyMatrix; <* UNUSED *> PROCEDURE PrintHalfMatrix(READONLY m : REF AdjacencyMatrix; n: INTEGER) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN FOR i := 0 TO n-1 DO FOR j := 0 TO i DO IF m[i,j] = inf THEN Wr.PutText(stderr, "# "); ELSE Wr.PutText(stderr, Fmt.Int(m[i,j]) & " "); END; END; Wr.PutText(stderr, "\n"); END; END PrintHalfMatrix; PROCEDURE ShortestPath(VAR m : REF AdjacencyMatrix; n : INTEGER) = VAR s : CARDINAL; BEGIN FOR i := 0 TO n-1 DO FOR j := 0 TO n-1 DO IF m[j,i] < inf THEN FOR k := 0 TO n-1 DO IF m[i,k] < inf THEN s := m[j,i] + m[i,k]; IF s < m[j,k] THEN m[j,k] := s END; END END END END END END ShortestPath; PROCEDURE Eval( erg: T; READONLY c: Coords; VAR e: LONGREAL; grad: BOOLEAN; VAR eDc: Gradient; ) = BEGIN WITH NV = erg.top.NV, eDdif = erg.eDdif^, termVar = erg.termVar, length = erg.L, strength = FLOAT(erg.strength, LONGREAL), m = erg.m^ DO PROCEDURE AccumTerm(READONLY u: CARDINAL) = (* Adds to "e" the energy term corresponding to a vertex "u". Returns also the gradient "eDdif". *) CONST Epsilon = 1.0d-10; BEGIN WITH cu = c[u] DO FOR i := u+1 TO NV-1 DO WITH cv = c[i], n = LR4.Sub(cu,cv), dif = LR4.Norm(n), d2 = dif * dif + Epsilon, duv = m[u,i], luv = length * CalculateLength(duv), kuv = strength * CalculateStrength(duv), l2 = luv * luv + Epsilon, d3 = d2 * dif + Epsilon DO e := e + kuv * ( (d2/l2) + (l2/d2) - 2.0d0 ); IF grad THEN eDdif[u,i] := 2.0d0 * kuv * ( (dif/l2) - (l2/d3) ); eDdif[i,u] := eDdif[u,i]; ELSE eDdif[u,i] := 0.0d0; eDdif[i,u] := eDdif[u,i]; END END END END END AccumTerm; PROCEDURE Distribute_eDdif(READONLY u: CARDINAL) = (* Distribute eDdif on endpoints "c[u]" and "c[v]" *) CONST Epsilon = 1.0d-10; BEGIN WITH cu = c[u] DO FOR i := u+1 TO NV-1 DO WITH ci = c[i], n = LR4.Sub(cu,ci), dif = LR4.Norm(n)+Epsilon, eDi = eDc[i], eDu = eDc[u], difDcu = LR4.Scale(1.0d0/dif, n), difDci = LR4.Scale(-1.0d0/dif,n), eDcu = LR4.Scale(eDdif[u,i], difDcu), eDci = LR4.Scale(eDdif[u,i], difDci) DO IF termVar[i] THEN eDi := LR4.Add(eDi, eDci); END; IF termVar[u] THEN eDu := LR4.Add(eDu, eDcu); END END END END; END Distribute_eDdif; BEGIN FOR i := 0 TO NV-1 DO eDc[i]:=LR4.T{0.0d0, 0.0d0, 0.0d0, 0.0d0} END; e := 0.0d0; FOR l := 0 TO NV-1 DO IF termVar[l] THEN AccumTerm(l); IF grad THEN Distribute_eDdif(l); END END END END END END Eval; PROCEDURE Name(erg: T): TEXT = BEGIN RETURN "ModKamada(ilenth := " & Fmt.Real(erg.length,Fmt.Style.Fix,prec := 3) & " istrength := " & Fmt.Real(erg.strength,Fmt.Style.Fix,prec:= 3) & ")"; END Name; BEGIN END ModKamSpring. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/MyCurvature2D.m3 MODULE Curvature2D; IMPORT Triangulation, LR4, Stat, Octf; FROM Triangulation IMPORT Topology, Face, OrgV; FROM Energy IMPORT Coords, Gradient; FROM LR4 IMPORT Add, Neg, Dot; FROM Octf IMPORT Enext, Enext_1; CONST zero = LR4.T{0.0d0,0.0d0,0.0d0,0.0d0}; IniStackSize = 100000; Epsilon = 0.0000000001d0; VAR str,stc: Stat.T; (* statistical accumulators to the number of "root" elements and the number of "children" elements inside each "root" element. *) TYPE BOOLS = ARRAY OF BOOLEAN; StackF = REF ARRAY OF Face; Number = RECORD nre : INTEGER; (* number of "root" faces. *) nce : CARDINAL; (* number of "children" faces inside each "root" face.*) END; REVEAL T = Public BRANDED OBJECT K : LONGREAL; (* The energy normalization factor *) top : Topology; (* The topology *) vVar: REF BOOLS; (* TRUE if vertex is variable *) num : Number; (* Number of "root" and "children" faces*) ChilFace: REF ARRAY OF StackF; (* The "children" faces *) OVERRIDES init := Init; defTop := DefTop; defVar := DefVar; eval := Eval; name := Name; END; PROCEDURE Statistics(READONLY top: Topology) : Number = VAR num: Number; BEGIN FOR i:= 0 TO top.NF-1 DO WITH f = top.face[i], fr = FLOAT(f.root,REAL) DO Stat.Accum(str,fr); IF fr = 0.0 THEN Stat.Accum(stc,fr) END; END END; num.nre := FLOOR(str.maximum)+1; num.nce := FLOOR(stc.num); RETURN num; END Statistics; PROCEDURE CropChilFaces( READONLY top: Triangulation.Topology; READONLY num: Number; ) : REF ARRAY OF StackF = VAR topi : REF ARRAY OF CARDINAL; (* Crop the "children" faces for each "root" face. *) BEGIN (* initialize the "top" indexes for each of the "num.nre" stacks of faces. *) topi := NEW(REF ARRAY OF CARDINAL, num.nre); FOR k := 0 TO num.nre-1 DO topi[k] := 0 END; WITH t = NEW(REF ARRAY OF StackF, num.nre) DO FOR k := 0 TO num.nre-1 DO t[k] := NEW(REF ARRAY OF Face, IniStackSize); END; FOR j := 0 TO top.NF-1 DO WITH f = top.face[j], fr = f.root DO IF fr # -1 THEN SaveF(t[fr],topi[fr],f) END; END END; RETURN t; END; END CropChilFaces; PROCEDURE SaveF( VAR Stack : StackF; VAR top: CARDINAL; VAR face : Face; ) = (* Save the face "face" on the stack "Stack" *) BEGIN Stack[top] := face; top := top +1 END SaveF; PROCEDURE Init(erg: T) : T = BEGIN RETURN erg END Init; PROCEDURE DefTop(erg: T; READONLY top: Topology) = BEGIN erg.K := 1.0d0; erg.top := top; erg.vVar := NEW(REF BOOLS, top.NV); erg.num := Statistics(top); erg.ChilFace := CropChilFaces(top,erg.num); (* Just in case the client forgets to call "defVar": *) FOR i := 0 TO top.NV-1 DO erg.vVar[i] := FALSE END; END DefTop; PROCEDURE DefVar(erg: T; READONLY variable: BOOLS) = BEGIN WITH NV = erg.top.NV, vVar = erg.vVar^ DO <* ASSERT NUMBER(variable) = NV *> vVar := variable; END END DefVar; PROCEDURE Eval( erg: T; READONLY c: Coords; VAR e: LONGREAL; grad: BOOLEAN; VAR eDc: Gradient; ) = BEGIN WITH NV = erg.top.NV, K = erg.K, vVar = erg.vVar^, ChilFace = erg.ChilFace, num = erg.num DO PROCEDURE AddTerm(READONLY iu,iv,iw,ix: CARDINAL) = (* Adds one term of the curvature energy to "e" (and its derivative to "eDc, if "grad" is TRUE). The terms correspond to the faces "f1 = u v w" and "f2 = u w x". See the follow picture: v /|\ / | \ / | \ / / | \ \ ------ w / | \ x ----- \ \ f1 | f2 / / \ | / \ | / \ | / \|/ u *) VAR eterm: LONGREAL; eDdu, eDdv, eDdw, eDdx: LR4.T; BEGIN WITH u = c[iu], v = c[iv], w = c[iw], x = c[ix] DO term(u,v,w,x, eterm, eDdu, eDdv, eDdw, eDdx); e := e + eterm; IF grad THEN IF vVar[iu] THEN eDc[iu] := LR4.Add(eDc[iu],eDdu); END; IF vVar[iv] THEN eDc[iv] := LR4.Add(eDc[iv],eDdv); END; IF vVar[iw] THEN eDc[iw] := LR4.Add(eDc[iw],eDdw); END; IF vVar[ix] THEN eDc[ix] := LR4.Add(eDc[ix],eDdx); END END END END AddTerm; PROCEDURE term(u,v,w,x: LR4.T; VAR eterm: LONGREAL; VAR dedu,dedv,dedw,dedx: LR4.T; ) = VAR dedDv,dedDw,dedDx: LR4.T; BEGIN WITH Dv = LR4.Sub(v,u), (* V *) Dw = LR4.Sub(w,u), (* V *) Dx = LR4.Sub(x,u) DO EangleAux(Dv,Dw, Dx, eterm, dedDv,dedDw,dedDx); dedv := dedDv; (* V *) dedw := dedDw; (* V *) dedx := dedDx; (* V *) dedu := Neg(Add(Add(dedDv,dedDw),dedDx)); END END term; PROCEDURE EangleAux(f,a,b: LR4.T; VAR eterm: LONGREAL; VAR dedf,deda,dedb: LR4.T; ) = (* compute the derivative of the orthogonal vectors "f" and "g" where "f= s - Proj(s,r)" and "g = r". *) VAR dedr,deds: LR4.T; BEGIN WITH m = LR4.Dot(f,f)+Epsilon, (* S *) u = LR4.Dot(f,a), (* S *) v = LR4.Dot(f,b), (* S *) U = u/m, (* S *) V = v/m, (* S *) Uf = LR4.Scale(U,f), (* V *) Vf = LR4.Scale(V,f), (* V *) R = LR4.Sub(a,Uf), (* V *) S = LR4.Sub(b,Vf) (* V *) DO Eangle(R,S,eterm,dedr,deds); WITH dedV = - Dot(deds, f), (* S *) dedU = - Dot(dedr, f), (* S *) dedu = dedU/m, (* S *) dedv = dedV/m, (* S *) dedm = (-1.0d0/m) * (dedU*U + dedV*V), (* S *) dedm2 = LR4.Scale(2.0d0,f), (* S *) dedm2f = LR4.Scale(dedm, dedm2), (* V *) dedua = LR4.Scale(dedu, a), (* V *) dedvb = LR4.Scale(dedv, b), (* V *) dedrU = LR4.Neg(LR4.Scale(U, dedr)), (* V *) dedsV = LR4.Neg(LR4.Scale(V, deds)), (* V *) t1 = LR4.Add(dedm2f,dedua), (* V *) t2 = LR4.Add(t1, dedvb), (* V *) t3 = LR4.Add(t2, dedrU), (* V *) t4 = LR4.Add(t3, dedsV), (* V *) deduf = LR4.Scale(dedu, f), (* V *) dedvf = LR4.Scale(dedv, f), (* V *) c1 = LR4.Add(deduf, dedr), (* V *) d1 = LR4.Add(dedvf, deds) (* V *) DO dedf := t4; deda := c1; dedb := d1; END END END EangleAux; PROCEDURE Eangle( READONLY R,S: LR4.T; VAR E: LONGREAL; VAR EDR,EDS: LR4.T; ) = (* Given two vectors "R" and "S" compute the "cos" of the angle between the vectors, the curvature term and the derivatives of energy respect to the two vectors: eeDR and eeDS. *) BEGIN WITH m = LR4.Norm(R) + Epsilon, n = LR4.Norm(S) + Epsilon, o = LR4.Dot(R,S), d = m*n, q = o/d DO IF d # 0.0d0 THEN E := K * (1.0d0 + q); IF grad THEN WITH eDq = 1.0d0 * K, eDo = eDq / d, eDd = - eDq * q / d, eDm = eDd * n, eDn = eDd * m DO EDR := LR4.Mix(eDo, S, eDm/m, R); EDS := LR4.Mix(eDo, R, eDn/n, S); END END END END END Eangle; BEGIN (* Initialize *) FOR i := 0 TO NV-1 DO eDc[i] := zero END; (* Compute energy "e", and the gradient "eDr": *) e := 0.0d0; FOR i := 0 TO num.nre-1 DO FOR j := 0 TO num.nce-1 DO FOR k := j+1 TO num.nce-1 DO IF ChilFace[i,j].exists AND ChilFace[i,k].exists THEN IF Adjacent(ChilFace[i,j], ChilFace[i,k]) THEN WITH u1 = OrgV(ChilFace[i,j].pa).num, v1 = OrgV(Enext (ChilFace[i,j].pa)).num, w1 = OrgV(Enext_1(ChilFace[i,j].pa)).num, u2 = OrgV(ChilFace[i,k].pa).num, v2 = OrgV(Enext (ChilFace[i,k].pa)).num, w2 = OrgV(Enext_1(ChilFace[i,k].pa)).num DO IF (v1 = v2) AND (u1 = w2) THEN AddTerm(v1,u1,w1,u2); ELSIF (v1 = w2) AND (u1 = u2) THEN AddTerm(v1,u1,w1,v2); ELSIF (v1 = u2) AND (u1 = v2) THEN AddTerm(v1,u1,w1,w2); ELSIF (u1 = v2) AND (w1 = w2) THEN AddTerm(u1,w1,v1,u2); ELSIF (u1 = w2) AND (w1 = u2) THEN AddTerm(u1,w1,v1,v2); ELSIF (u1 = u2) AND (w1 = v2) THEN AddTerm(u1,w1,v1,w2); ELSIF (w1 = v2) AND (v1 = w2) THEN AddTerm(w1,v1,u1,u2); ELSIF (w1 = w2) AND (v1 = u2) THEN AddTerm(w1,v1,u1,v2); ELSIF (w1 = u2) AND (v1 = v2) THEN AddTerm(w1,v1,u1,w2); ELSIF (v1 = w2) AND (u1 = v2) THEN AddTerm(v1,u1,w1,u2); ELSIF (v1 = v2) AND (u1 = u2) THEN AddTerm(v1,u1,w1,w2); ELSIF (v1 = u2) AND (u1 = w2) THEN AddTerm(v1,u1,w1,v2); ELSIF (u1 = w2) AND (w1 = v2) THEN AddTerm(u1,w1,v1,u2); ELSIF (u1 = v2) AND (w1 = u2) THEN AddTerm(u1,w1,v1,w2); ELSIF (u1 = u2) AND (w1 = w2) THEN AddTerm(u1,w1,v1,v2); ELSIF (w1 = w2) AND (v1 = v2) THEN AddTerm(w1,v1,u1,u2); ELSIF (w1 = v2) AND (v1 = u2) THEN AddTerm(w1,v1,u1,w2); ELSIF (w1 = u2) AND (v1 = w2) THEN AddTerm(w1,v1,u1,v2); END END END END END END END END END END Eval; PROCEDURE Adjacent(f1,f2: Face) : BOOLEAN = VAR count : INTEGER := 0; BEGIN WITH u1 = OrgV(f1.pa).num, v1 = OrgV(Enext (f1.pa)).num, w1 = OrgV(Enext_1(f1.pa)).num, u2 = OrgV(f2.pa).num, v2 = OrgV(Enext (f2.pa)).num, w2 = OrgV(Enext_1(f2.pa)).num DO IF u1 = u2 OR u1 = v2 OR u1 = w2 THEN count := count + 1; END; IF v1 = u2 OR v1 = v2 OR v1 = w2 THEN count := count + 1; END; IF w1 = u2 OR w1 = v2 OR w1 = w2 THEN count := count + 1; END; IF count = 2 THEN RETURN TRUE ELSE RETURN FALSE END END END Adjacent; PROCEDURE Name(<* UNUSED *> erg: T): TEXT = BEGIN RETURN "Curv2D()" END Name; BEGIN END Curvature2D. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Octf.m3 MODULE Octf; (* Facet-Edge data structure. Created on 1998 by Luis Arturo Perez Lozada, (see notice of copyright at the end of this file), inspired in the im- plementation of Quad-Edge data structure (by J. Stolfi and R. Marcone) See : "Primitives for the Manipulation of Three-Dimensional Subdivisions" by D. Dobkin and J. Laszlo, Algorithmica 1989. Last Modification: 03-08-00 by stolfi: *) IMPORT Lex, Word, Wr, Rd, Fmt, FloatMode, Thread, Stdio; FROM Stdio IMPORT stdout; TYPE MarkBit = BOOLEAN; REVEAL Node = PublicNode BRANDED OBJECT END; REVEAL Edge = PublicEdge BRANDED OBJECT marks: ARRAY [0..1] OF MarkBit; (* Used by NumberEdges, ex: marks[SpinBit(a)] associated to Edge *) OVERRIDES init := EdgeInit; END; REVEAL Face = PublicFace BRANDED OBJECT marks: ARRAY [0..1] OF MarkBit; (* Used by NumberFacets, ex: marks[DualBit(a)] associated to Face *) OVERRIDES init := FaceInit; END; REVEAL FacetEdge = PublicFacetEdge BRANDED OBJECT marks: ARRAY [0..1] OF MarkBit; (* Used by EnumVertices, EnumFacetEdges *) (* ex: marks[OrientationBit(a)] associarted to Vertices *) (* Element index [r] refers to pair a[r] = Pair{n,r}: *) (* and r is RBits the Rotations Bits, r = {0,1,2,3} *) fenext: ARRAY [0..3] OF FacetEdge; (* FacetEdge of Fnext(a[r]) *) bnext: ARRAY [0..3] OF SRBits; (* SRBits of Fnext(a[r]) *) ind : CARDINAL := 0; (* index of FacetEdge used by procedures NumberFacets, Number- Edges and NumberEdgesForDegree *) OVERRIDES init := OctInit; END; (* Description for computational of bits for Spin and Srot If "a = spin^s(srot^r(a0))", where "a0" is the reference pair of "a", "r" in [0..3], and "s" in [0..1], then "a.bits = (2r + s)". Therefore, | a.spin.bits = XOR(a.bits, 1) | If sbit is 0 | a.srot.bits = (a.bits + 2) MOD 8 | otherwise | a.srot.bits = (a.bits + 6) MOD 8 The pair "Fnext(a)" is given by "pair(a.facetedge.fenext[rbit], a.facetedge.bnext[rbit])", provided that the "spin" bit of "a" is 0. Otherwise "Fnext(a)" is computed by the formula: "Fnext(a) = Spin(Clock(Fnext(Clock(Spin(a)))))". rbit is obtained by "rbit = Word.And( Word.RightShift( a.bits , 1 ), 3 ) *) PROCEDURE OctInit(n: FacetEdge): FacetEdge = BEGIN n.marks[0] := FALSE; n.marks[1] := FALSE; FOR i := 0 TO 3 DO n.fenext[i] := n END; n.bnext[0] := 0; n.bnext[1] := 2; n.bnext[2] := 4; n.bnext[3] := 6; n.edge := MakeEdge(); n.face := MakeFace(); RETURN n END OctInit; PROCEDURE EdgeInit(e: Edge): Edge = BEGIN e.marks[0] := FALSE; e.marks[1] := FALSE; RETURN e; END EdgeInit; PROCEDURE FaceInit(f: Face): Face = BEGIN f.marks[0] := FALSE; f.marks[1] := FALSE; RETURN f; END FaceInit; PROCEDURE MakeEdge(): Edge = BEGIN WITH e = NEW(Edge).init() DO RETURN e END; END MakeEdge; PROCEDURE MakeFace(): Face = BEGIN WITH f = NEW(Face).init() DO RETURN f END; END MakeFace; PROCEDURE MakeFacetEdge (): Pair = VAR a : Pair; BEGIN WITH n = NEW(FacetEdge).init() DO a := Pair{facetedge := n, bits := 0}; a.facetedge.edge.pa := a; a.facetedge.face.pa := a; RETURN a; END; END MakeFacetEdge; (* ====== Updating relations ====== *) PROCEDURE SetFace(a: Pair; n: Face) = BEGIN WITH c = a.facetedge.face DO c := n; END; END SetFace; PROCEDURE SetEdge(a: Pair; n: Edge) = BEGIN WITH c = a.facetedge.edge DO c := n; END; END SetEdge; PROCEDURE SetEdgeAll(a: Pair; n: Edge) = VAR t: Pair := a; BEGIN REPEAT SetEdge(t,n); t := Fnext(t); UNTIL (t = a); END SetEdgeAll; PROCEDURE SetFaceAll(a: Pair; n: Face) = VAR t: Pair := a; BEGIN REPEAT SetFace(t,n); t := Enext(t); UNTIL (t = a); END SetFaceAll; (* ====== Counting ====== *) PROCEDURE DegreeFaceRing(a: Pair): CARDINAL = VAR n: CARDINAL := 0; s: Pair := a; BEGIN REPEAT INC(n); s := Fnext_1(s); UNTIL s = a; RETURN n END DegreeFaceRing; PROCEDURE DegreeEdgeRing(a: Pair): CARDINAL = VAR n: CARDINAL := 0; s: Pair := a; BEGIN REPEAT INC(n); s := Enext(s); UNTIL s = a; RETURN n END DegreeEdgeRing; (* ====== Computing Bits ====== *) PROCEDURE OrientationBit(a: Pair): OBit = BEGIN RETURN Word.RightShift(a.bits, 2) END OrientationBit; PROCEDURE SpinBit(a: Pair): SBit = BEGIN RETURN Word.And(a.bits, 1) END SpinBit; PROCEDURE DualBit(a: Pair): DBit = BEGIN RETURN Word.And(Word.RightShift(a.bits, 1), 1) END DualBit; PROCEDURE SrotBits(a: Pair): RBits = BEGIN RETURN Word.And( Word.RightShift(a.bits, 1), 3) END SrotBits; PROCEDURE GetPairNum(a: Pair): PairNum = BEGIN RETURN Word.LeftShift(a.facetedge.num, 3) + a.bits END GetPairNum; PROCEDURE Srot(a: Pair): Pair = BEGIN RETURN Pair{facetedge := a.facetedge, bits := Word.And(a.bits + 2 + Word.LeftShift( Word.And(a.bits, 1), 2), 7) }; END Srot; PROCEDURE Spin(a: Pair): Pair = BEGIN RETURN Pair{facetedge := a.facetedge, bits := Word.Xor( a.bits, 1 )}; END Spin; PROCEDURE Clock(a: Pair): Pair = BEGIN RETURN Pair{facetedge := a.facetedge, bits := Word.And( (a.bits + 4), 7 )}; END Clock; PROCEDURE Tors(a: Pair): Pair = BEGIN RETURN Pair{facetedge := a.facetedge, bits := Word.And(a.bits + 6 + Word.LeftShift( Word.And(a.bits, 1), 2), 7) }; END Tors; PROCEDURE Fnext(a: Pair) : Pair = PROCEDURE Fnext_(a: Pair): Pair = VAR r : SRBits; BEGIN WITH s = Word.And( Word.RightShift( a.bits, 1 ), 3 ) DO r := a.facetedge.bnext[s]; a.facetedge := a.facetedge.fenext[s]; a.bits := r; RETURN a; END; END Fnext_; BEGIN IF ( Word.And( a.bits, 1 ) = 0 ) THEN RETURN Fnext_(a); ELSE RETURN Spin(Clock(Fnext_(Clock(a)))); END; END Fnext; PROCEDURE Sdual(a: Pair): Pair = BEGIN RETURN Spin(Srot(a)) END Sdual; PROCEDURE Enext(a: Pair): Pair = BEGIN RETURN Srot(Fnext(Tors(a))) END Enext; PROCEDURE Enext_1(a: Pair): Pair = BEGIN RETURN Clock(Srot(Fnext(Srot(a)))) END Enext_1; PROCEDURE Fnext_1(a: Pair): Pair = BEGIN RETURN Clock(Fnext(Clock(a))) END Fnext_1; PROCEDURE SpliceFacets(a,b: Pair) = BEGIN <* ASSERT b # Spin(Fnext(a)) *> IF a # b THEN WITH ta = Fnext(a), tb = Fnext(b), c = Clock(ta), d = Clock(tb), tc = Fnext(c), td = Fnext(d) DO IF ( Word.And(a.bits, 1) = 0 ) THEN WITH rba = SrotBits(a) DO a.facetedge.fenext[rba] := tb.facetedge; a.facetedge.bnext[rba] := tb.bits; END ELSE WITH ra = Clock(Spin(a)), fd = Spin(d), rbra = SrotBits(ra) DO ra.facetedge.fenext[rbra] := fd.facetedge; ra.facetedge.bnext[rbra] := fd.bits; END END; IF ( Word.And(b.bits, 1) = 0 ) THEN WITH rbb = SrotBits(b) DO b.facetedge.fenext[rbb] := ta.facetedge; b.facetedge.bnext[rbb] := ta.bits; END ELSE WITH rb = Clock(Spin(b)), fc = Spin(c), rbrb = SrotBits(rb) DO rb.facetedge.fenext[rbrb] := fc.facetedge; rb.facetedge.bnext[rbrb] := fc.bits; END END; IF ( Word.And(c.bits, 1) = 0 ) THEN WITH rbc = SrotBits(c) DO c.facetedge.fenext[rbc] := td.facetedge; c.facetedge.bnext[rbc] := td.bits; END ELSE WITH rc = Clock(Spin(c)), fb = Spin(b), rbrc = SrotBits(rc) DO rc.facetedge.fenext[rbrc] := fb.facetedge; rc.facetedge.bnext[rbrc] := fb.bits; END END; IF ( Word.And(d.bits, 1) = 0 ) THEN WITH rbd = SrotBits(d) DO d.facetedge.fenext[rbd] := tc.facetedge; d.facetedge.bnext[rbd] := tc.bits; END ELSE WITH rd = Clock(Spin(d)), fa = Spin(a), rbrd = SrotBits(rd) DO rd.facetedge.fenext[rbrd] := fa.facetedge; rd.facetedge.bnext[rbrd] := fa.bits; END END; END; END; END SpliceFacets; PROCEDURE SpliceEdges(a,b: Pair) = BEGIN SpliceFacets(Sdual(a), Sdual(b)); END SpliceEdges; PROCEDURE DeleteFacetEdge (a : Pair) = BEGIN SpliceFacets(a, Fnext_1(a)); SpliceFacets(Clock(a), Fnext_1(Clock(a))); END DeleteFacetEdge; PROCEDURE Meld(a,b : Pair) = (* Delete the first pair facetedge argument *) VAR firsta,a_1 : Pair; BEGIN firsta := a; REPEAT a_1 := Fnext_1(a); IF Fnext(a) # b THEN SpliceFacets(a, Fnext_1(b)); <* ASSERT Fnext(a) = b *> END; DeleteFacetEdge(a); IF SpinBit(a_1) = SpinBit(b) THEN <* ASSERT Fnext(a_1) = b *> END; a := Enext(a); b := Enext(b); UNTIL a = firsta; END Meld; (* ================= Traversal's functions of QuadEdge ========= *) PROCEDURE Onext(s: Pair): Pair = BEGIN IF DualBit(s)= 0 THEN RETURN Clock(Fnext(Enext_1(s))); ELSE RETURN Enext_1(s); END; END Onext; PROCEDURE Onext_1(s: Pair): Pair = (* Procedure equivalent to function Onext but change Fnext by Fnext_1 *) BEGIN RETURN Clock(Fnext_1(Enext_1(s))); END Onext_1; (* ================ TRAVESAL ===================== *) PROCEDURE EnumFacetEdges(a: Pair; visit: VisitProc; facetedges: BOOLEAN := FALSE) = CONST IniStackSize = 1024; VAR festack := NEW(REF ARRAY OF FacetEdge, IniStackSize); bstack := NEW(REF ARRAY OF SRBits, IniStackSize); top: CARDINAL; PROCEDURE DoubleStack() = BEGIN WITH sz = NUMBER(festack^), szNew = 2*sz, festackNew = NEW(REF ARRAY OF FacetEdge, szNew), bstackNew = NEW(REF ARRAY OF SRBits, szNew) DO SUBARRAY(festackNew^, 0, sz) := festack^; festack := festackNew; SUBARRAY(bstackNew^, 0, sz) := bstack^; bstack := bstackNew; END END DoubleStack; PROCEDURE VisitandMark(c: Pair)= (* If facetedge(c) is unmarked: visit, mark, and stack it. *) BEGIN IF NOT c.facetedge.marks[DualBit(c)] THEN visit(c); IF NOT facetedges THEN visit(Clock(c)) END; c.facetedge.marks[DualBit(c)] := TRUE; (* c.facetedge marked *) IF top >= NUMBER(festack^) THEN DoubleStack() END; festack[top] := c.facetedge; bstack[top] := c.bits; top := top + 1; END; END VisitandMark; VAR seen: CARDINAL; (* # of quads whose childeren were looked at *) BEGIN <* ASSERT NOT a.facetedge.marks[DualBit(a)] *> top := 0; seen := 0; TRY VisitandMark(a); WHILE seen < top DO WITH b = Pair{facetedge := festack[seen], bits := bstack[seen]} DO VisitandMark(Fnext_1(b)); VisitandMark(Enext_1(b)); VisitandMark(Enext(b)); VisitandMark(Fnext(Enext_1(b))); END; seen := seen + 1 END; FINALLY (* Erase all marks *) WHILE top > 0 DO top := top - 1; WITH b = Pair{facetedge := festack[top], bits := bstack[top]} DO b.facetedge.marks[DualBit(b)] := FALSE; END END END END EnumFacetEdges; PROCEDURE NumberEdges(READONLY a: ARRAY OF Pair): REF ARRAY OF Edge = (* Note: I change the SpinBit by DualBit for purpouses of gluing octahedra. *) CONST IniStackSize = 1024; VAR estack := NEW(REF ARRAY OF Edge, IniStackSize); stack := NEW(REF ARRAY OF Pair, IniStackSize); top: CARDINAL; (* top for stack "estack" *) nstack: CARDINAL; (* top for stack "nstack" *) PROCEDURE DoubleStack() = BEGIN WITH sz = NUMBER(stack^), szNew = 2*sz, estackNew = NEW(REF ARRAY OF Edge, szNew), stackNew = NEW(REF ARRAY OF Pair, szNew) DO SUBARRAY(estackNew^, 0, sz) := estack^; estack := estackNew; SUBARRAY(stackNew^, 0, sz) := stack^; stack := stackNew; END END DoubleStack; PROCEDURE VisitAndMark(t: Pair) = (* If t is unmarked: visit, mark, and stack it. *) VAR tn : Pair; BEGIN WITH ind = t.facetedge.ind, tnum1 = t.facetedge.edge.num DO IF ind < nstack AND stack[ind].facetedge = t.facetedge THEN (* FacetEdge is already marked, not do nothing *) ELSE (* FacetEdge not marked, do *) (* If component edge of pair "t" not are marked, then *) IF NOT t.facetedge.edge.marks[DualBit(t)] THEN (* mark t.facetedge.edge and alls components edges of pairs adjacents to "t" *) tn := t; REPEAT tn.facetedge.edge.marks[DualBit(tn)] := TRUE; tn := Fnext(tn); UNTIL (tn = t); IF top >= NUMBER(estack^) THEN DoubleStack() END; estack[top] := t.facetedge.edge; estack[top].pa := t; tnum1 := top; top := top + 1; END; IF nstack = NUMBER(stack^) THEN DoubleStack() END; ind := nstack; stack[nstack] := t; INC(nstack); END; END; END VisitAndMark; VAR seen: CARDINAL := 0; (* # of facetedges whose childeren were looked at *) BEGIN seen := 0; top := 0; nstack := 0; FOR i := 0 TO LAST(a) DO VisitAndMark (a[i]) END; WHILE seen < nstack DO WITH s = stack[seen] DO VisitAndMark(Fnext(s)); VisitAndMark(Fnext(Enext_1(s))); VisitAndMark(Enext(s)); VisitAndMark(Fnext_1(s)); END; seen := seen + 1 END; (* Erase all marks *) WHILE nstack > 0 DO nstack := nstack - 1; WITH b = stack[nstack] DO VAR atn: Pair := b; BEGIN REPEAT atn.facetedge.edge.marks[DualBit(atn)] := FALSE; atn:= Fnext(atn); UNTIL (atn = b); END; END END; WITH r = NEW(REF ARRAY OF Edge, top) DO r^ := SUBARRAY(estack^, 0, top); RETURN r END; END NumberEdges; PROCEDURE NumberEdgesForDegree(READONLY a: ARRAY OF Pair): REF ARRAY OF Pair = (* Computes the degree of a vertex, i.e. the number of edges incidents to this vertex. *) CONST IniStackSize = 20; VAR estack := NEW(REF ARRAY OF Pair, IniStackSize); stack := NEW(REF ARRAY OF Pair, IniStackSize); top: CARDINAL; (* top for stack "estack" *) nstack: CARDINAL; (* top for stack "nstack" *) PROCEDURE DoubleStack() = BEGIN WITH sz = NUMBER(stack^), szNew = 2*sz, estackNew = NEW(REF ARRAY OF Pair, szNew), stackNew = NEW(REF ARRAY OF Pair, szNew) DO SUBARRAY(estackNew^, 0, sz) := estack^; estack := estackNew; SUBARRAY(stackNew^, 0, sz) := stack^; stack := stackNew; END END DoubleStack; PROCEDURE VisitAndMark(t: Pair) = (* If t is unmarked: visit, mark, and stack it. *) VAR tn : Pair; BEGIN WITH tind = t.facetedge.ind, tdg = t.facetedge.edge.dg DO IF tind < nstack AND stack[tind].facetedge = t.facetedge THEN (* FacetEdge is already marked, not do nothing *) ELSE (* FacetEdge not marked, do *) (* If component edge of pair "t" not are marked, then *) IF NOT t.facetedge.marks[DualBit(t)] THEN (* mark t.facetedge.edge and alls components edges of pairs adjacents to "t" *) tn := t; REPEAT tn.facetedge.marks[DualBit(tn)] := TRUE; tn := Fnext(tn); UNTIL (tn = t); IF top >= NUMBER(estack^) THEN DoubleStack() END; estack[top] := t; tdg := top; top := top + 1; END; IF nstack = NUMBER(stack^) THEN DoubleStack() END; tind := nstack; stack[nstack] := t; INC(nstack); END; END; END VisitAndMark; VAR seen: CARDINAL := 0; BEGIN seen := 0; top := 0; nstack := 0; FOR i := 0 TO LAST(a) DO VisitAndMark(a[i]); END; WHILE seen < nstack DO WITH s = stack[seen] DO IF DualBit(s) = 0 THEN VisitAndMark(Onext(s)); VisitAndMark(Onext(Fnext(s))); ELSE VisitAndMark(Clock(Onext(s))); VisitAndMark(Clock(Onext(Fnext(s)))); END; END; seen := seen + 1 END; (* Erase all marks *) WHILE nstack > 0 DO nstack := nstack - 1; WITH b = stack[nstack] DO VAR atn: Pair := b; BEGIN REPEAT atn.facetedge.marks[DualBit(atn)] := FALSE; atn:= Fnext(atn); UNTIL (atn = b); END END END; WITH r = NEW(REF ARRAY OF Pair, top) DO r^ := SUBARRAY(estack^, 0, top); RETURN r END; END NumberEdgesForDegree; PROCEDURE NumberFacets(READONLY a: ARRAY OF Pair): REF ARRAY OF Face = CONST IniStackSize = 1024; VAR fstack := NEW(REF ARRAY OF Face, IniStackSize); stack := NEW(REF ARRAY OF Pair, IniStackSize); top: CARDINAL; (* top for stack "festack" *) nstack: CARDINAL; (* top for stack "stack" *) PROCEDURE DoubleStack() = BEGIN WITH sz = NUMBER(stack^), szNew = 2*sz, fstackNew = NEW(REF ARRAY OF Face, szNew), stackNew = NEW(REF ARRAY OF Pair, szNew) DO SUBARRAY(fstackNew^, 0, sz) := fstack^; fstack := fstackNew; SUBARRAY(stackNew^, 0, sz) := stack^; stack := stackNew; END END DoubleStack; PROCEDURE VisitAndMark (t: Pair) = (* If t is unmarked: visit, mark, and stack it. *) VAR tn : Pair; BEGIN WITH ind = t.facetedge.ind, tnum1 = t.facetedge.face.num DO IF ind < nstack AND stack[ind].facetedge = t.facetedge THEN (* FacetEdge is already marked, not do nothing *) ELSE (* FacetEdge no marked, do *) (* if component face of pair "t" not are marked, then *) IF NOT t.facetedge.face.marks[DualBit(t)] THEN (* mark t.facetedge.face and alls components facets of pairs adjacents to "t" *) tn := t; REPEAT tn.facetedge.face.marks[DualBit(tn)] := TRUE; tn := Enext_1(tn); UNTIL (tn = t); IF top >= NUMBER(fstack^) THEN DoubleStack() END; fstack[top] := t.facetedge.face; fstack[top].pa := t; tnum1 := top; top := top + 1; END; IF nstack = NUMBER(stack^) THEN DoubleStack() END; ind := nstack; stack[nstack] := t; INC(nstack); END; END; END VisitAndMark; VAR seen: CARDINAL := 0; (* # of facetedges whose childeren were looked at *) BEGIN seen := 0; top := 0; nstack := 0; FOR i := 0 TO LAST(a) DO VisitAndMark (a[i]) END; WHILE seen < nstack DO WITH s = stack[seen] DO VisitAndMark(Fnext(s)); VisitAndMark(Fnext(Enext_1(s))); VisitAndMark(Enext(s)); VisitAndMark(Fnext_1(s)); END; seen := seen + 1 END; (* Erase all marks *) WHILE nstack > 0 DO nstack := nstack - 1; WITH b = stack[nstack] DO VAR atn: Pair := b; BEGIN REPEAT atn.facetedge.face.marks[DualBit(atn)] := FALSE; atn:= Enext_1(atn); UNTIL (atn = b); END; END END; WITH r = NEW(REF ARRAY OF Face, top) DO r^ := SUBARRAY(fstack^, 0, top); RETURN r END; END NumberFacets; <* UNUSED *> PROCEDURE PrintMark(a: Pair) = (* Print the mark of facetedge.edge *) <* FATAL Wr.Failure, Thread.Alerted *> VAR an: Pair := a; BEGIN REPEAT PrintPair(stdout, an); Wr.PutText(stdout, " **" & Fmt.Bool(an.facetedge.marks[SpinBit(an)]) & "\n"); an := Fnext(an); UNTIL(an = a) END PrintMark; PROCEDURE NumberFacetEdges(READONLY a: ARRAY OF Pair): REF ARRAY OF Pair = CONST IniStackSize = 1024; VAR stack := NEW(REF ARRAY OF Pair, IniStackSize); nstack: CARDINAL := 0; PROCEDURE DoubleStack() = BEGIN WITH sz = NUMBER(stack^), szNew = 2*sz, stackNew = NEW(REF ARRAY OF Pair, szNew) DO SUBARRAY(stackNew^, 0, sz) := stack^; stack := stackNew; END END DoubleStack; (* An facetedge "n" is "marked" if stack[n.num].facetedge = n. i.e whether stacked *) PROCEDURE VisitAndMark(t: Pair) = (* If t is unmarked: visit, mark, and stack it. *) BEGIN WITH num = t.facetedge.num DO IF num < nstack AND stack[num].facetedge = t.facetedge THEN (* FacetEdge is already marked, not do nothing *) ELSE IF nstack = NUMBER(stack^) THEN DoubleStack() END; num := nstack; stack[nstack] := t; INC(nstack); END END END VisitAndMark; VAR seen: CARDINAL := 0; (* # of facetedges whose childeren were looked at *) BEGIN nstack := 0; seen := 0; FOR i := 0 TO LAST(a) DO VisitAndMark (a[i]) END; WHILE seen < nstack DO WITH s = stack[seen] DO VisitAndMark(Fnext_1(s)); VisitAndMark(Enext_1(s)); VisitAndMark(Enext(s)); VisitAndMark(Fnext(Enext_1(s))); END; seen := seen + 1 END; WITH r = NEW(REF ARRAY OF Pair, nstack) DO r^ := SUBARRAY(stack^, 0, nstack); RETURN r END; END NumberFacetEdges; PROCEDURE SetFnext(a,b: Pair) = BEGIN IF Fnext(a) # b THEN SpliceFacets(a, Fnext_1(b)) END END SetFnext; PROCEDURE SetEnext(a, b: Pair) = BEGIN IF Enext(a) # b THEN SpliceEdges(a, Enext_1(b)) END END SetEnext; PROCEDURE PrintPair( wr: Wr.T; a: Pair; feWidth: CARDINAL := 1; nl : BOOLEAN := FALSE; ) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN IF nl THEN Wr.PutText(wr,Fmt.Pad(Fmt.Int(a.facetedge.num), feWidth) & ":" & Fmt.Int(SrotBits(a)) & ":" & Fmt.Int(SpinBit(a)) & "\n"); ELSE Wr.PutText(wr,Fmt.Pad(Fmt.Int(a.facetedge.num), feWidth) & ":" & Fmt.Int(SrotBits(a)) & ":" & Fmt.Int(SpinBit(a))); END END PrintPair; PROCEDURE ReadPair(rd: Rd.T; READONLY map: ARRAY OF FacetEdge): Pair = VAR m, r, s: CARDINAL; <* FATAL Rd.Failure, Rd.EndOfFile, Thread.Alerted, FloatMode.Trap, Lex.Error *> BEGIN Lex.Skip(rd); m := Lex.Int(rd); <* ASSERT Rd.GetChar(rd) = ':' *> r := Lex.Int(rd); <* ASSERT Rd.GetChar(rd) = ':' *> s := Lex.Int(rd); <* ASSERT m < NUMBER(map) *> <* ASSERT r < 4 AND s < 2 *> RETURN Pair{facetedge := map[m], bits := 2 * r + s} END ReadPair; PROCEDURE PrintFacetEdge(wr: Wr.T; n: FacetEdge; feWidth: CARDINAL := 1) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN FOR i := 0 TO 3 DO IF i > 0 THEN Wr.PutChar(wr, ' ') END; PrintPair(wr, Pair{facetedge := n.fenext[i], bits := n.bnext[i]}, feWidth); END END PrintFacetEdge; PROCEDURE ReadFacetEdge(rd: Rd.T; n: FacetEdge; READONLY map: ARRAY OF FacetEdge) = BEGIN FOR i := 0 TO 3 DO SetFnext(Pair{facetedge := n, bits := 2 * i}, ReadPair(rd, map)) END END ReadFacetEdge; BEGIN END Octf. (**************************************************************************) (* *) (* Copyright (C) 1998 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/OldCurvature2D.m3 MODULE OldCurvature2D; IMPORT Triangulation, LR4, Stat, Octf; FROM Triangulation IMPORT Topology, Face, OrgV; FROM Energy IMPORT Coords, Gradient; FROM LR4 IMPORT Add, Neg, Dot; FROM Octf IMPORT Enext, Enext_1; CONST zero = LR4.T{0.0d0,0.0d0,0.0d0,0.0d0}; IniStackSize = 100000; Epsilon = 0.0000000001d0; VAR str,stc: Stat.T; (* statistical accumulators to the number of "root" elements and the number of "children" elements inside each "root" element. *) TYPE BOOLS = ARRAY OF BOOLEAN; StackF = REF ARRAY OF Face; Number = RECORD nre : INTEGER; (* number of "root" faces. *) nce : CARDINAL; (* number of "children" faces inside each "root" face.*) END; REVEAL T = Public BRANDED OBJECT K : LONGREAL; (* The energy normalization factor *) top : Topology; (* The topology *) vVar: REF BOOLS; (* TRUE if vertex is variable *) num : Number; (* Number of "root" and "children" faces*) ChilFace: REF ARRAY OF StackF; (* The "children" faces *) OVERRIDES init := Init; defTop := DefTop; defVar := DefVar; eval := Eval; name := Name; END; PROCEDURE Statistics(READONLY top: Topology) : Number = VAR num: Number; BEGIN FOR i:= 0 TO top.NF-1 DO WITH f = top.face[i], fr = FLOAT(f.root,REAL) DO Stat.Accum(str,fr); IF fr = 0.0 THEN Stat.Accum(stc,fr) END; END END; num.nre := FLOOR(str.maximum)+1; num.nce := FLOOR(stc.num); RETURN num; END Statistics; PROCEDURE CropChilFaces( READONLY top: Triangulation.Topology; READONLY num: Number; ) : REF ARRAY OF StackF = VAR topi : REF ARRAY OF CARDINAL; (* Crop the "children" faces for each "root" face. *) BEGIN (* initialize the "top" indexes for each of the "num.nre" stacks of faces. *) topi := NEW(REF ARRAY OF CARDINAL, num.nre); FOR k := 0 TO num.nre-1 DO topi[k] := 0 END; WITH t = NEW(REF ARRAY OF StackF, num.nre) DO FOR k := 0 TO num.nre-1 DO t[k] := NEW(REF ARRAY OF Face, IniStackSize); END; FOR j := 0 TO top.NF-1 DO WITH f = top.face[j], fr = f.root DO IF fr # -1 THEN SaveF(t[fr],topi[fr],f) END; END END; RETURN t; END; END CropChilFaces; PROCEDURE SaveF( VAR Stack : StackF; VAR top: CARDINAL; VAR face : Face; ) = (* Save the face "face" on the stack "Stack" *) BEGIN Stack[top] := face; top := top +1 END SaveF; PROCEDURE Init(erg: T) : T = BEGIN RETURN erg END Init; PROCEDURE DefTop(erg: T; READONLY top: Topology) = BEGIN erg.K := 1.0d0; erg.top := top; erg.vVar := NEW(REF BOOLS, top.NV); erg.num := Statistics(top); erg.ChilFace := CropChilFaces(top,erg.num); (* Just in case the client forgets to call "defVar": *) FOR i := 0 TO top.NV-1 DO erg.vVar[i] := FALSE END; END DefTop; PROCEDURE DefVar(erg: T; READONLY variable: BOOLS) = BEGIN WITH NV = erg.top.NV, vVar = erg.vVar^ DO <* ASSERT NUMBER(variable) = NV *> vVar := variable; END END DefVar; PROCEDURE Eval( erg: T; READONLY c: Coords; VAR e: LONGREAL; grad: BOOLEAN; VAR eDc: Gradient; ) = BEGIN WITH NV = erg.top.NV, K = erg.K, vVar = erg.vVar^, ChilFace = erg.ChilFace, num = erg.num DO PROCEDURE AddTerm(READONLY iu,iv,iw,ix: CARDINAL) = (* Adds one term of the curvature energy to "e" (and its derivative to "eDc, if "grad" is TRUE). The terms correspond to the faces "f1 = u v w" and "f2 = u w x". See the follow picture: v /|\ / | \ / | \ / / | \ \ ------ w / | \ x ----- \ \ f1 | f2 / / \ | / \ | / \ | / \|/ u *) VAR eterm: LONGREAL; eDdu, eDdv, eDdw, eDdx: LR4.T; BEGIN WITH u = c[iu], v = c[iv], w = c[iw], x = c[ix] DO term(u,v,w,x, eterm, eDdu, eDdv, eDdw, eDdx); e := e + eterm; IF grad THEN IF vVar[iu] THEN eDc[iu] := LR4.Add(eDc[iu],eDdu); END; IF vVar[iv] THEN eDc[iv] := LR4.Add(eDc[iv],eDdv); END; IF vVar[iw] THEN eDc[iw] := LR4.Add(eDc[iw],eDdw); END; IF vVar[ix] THEN eDc[ix] := LR4.Add(eDc[ix],eDdx); END END END END AddTerm; PROCEDURE term(u,v,w,x: LR4.T; VAR eterm: LONGREAL; VAR dedu,dedv,dedw,dedx: LR4.T; ) = VAR dedDv,dedDw,dedDx: LR4.T; BEGIN WITH Dv = LR4.Sub(v,u), (* V *) Dw = LR4.Sub(w,u), (* V *) Dx = LR4.Sub(x,u) DO EangleAux(Dv,Dw, Dx, eterm, dedDv,dedDw,dedDx); dedv := dedDv; (* V *) dedw := dedDw; (* V *) dedx := dedDx; (* V *) dedu := Neg(Add(Add(dedDv,dedDw),dedDx)); END END term; PROCEDURE EangleAux(f,a,b: LR4.T; VAR eterm: LONGREAL; VAR dedf,deda,dedb: LR4.T; ) = (* compute the derivative of the orthogonal vectors "f" and "g" where "f= s - Proj(s,r)" and "g = r". *) VAR dedr,deds: LR4.T; BEGIN WITH m = LR4.Dot(f,f)+Epsilon, (* S *) u = LR4.Dot(f,a), (* S *) v = LR4.Dot(f,b), (* S *) U = u/m, (* S *) V = v/m, (* S *) Uf = LR4.Scale(U,f), (* V *) Vf = LR4.Scale(V,f), (* V *) R = LR4.Sub(a,Uf), (* V *) S = LR4.Sub(b,Vf) (* V *) DO Eangle(R,S,eterm,dedr,deds); WITH dedV = - Dot(deds, f), (* S *) dedU = - Dot(dedr, f), (* S *) dedu = dedU/m, (* S *) dedv = dedV/m, (* S *) dedm = (-1.0d0/m) * (dedU*U + dedV*V), (* S *) dedm2 = LR4.Scale(2.0d0,f), (* S *) dedm2f = LR4.Scale(dedm, dedm2), (* V *) dedua = LR4.Scale(dedu, a), (* V *) dedvb = LR4.Scale(dedv, b), (* V *) dedrU = LR4.Neg(LR4.Scale(U, dedr)), (* V *) dedsV = LR4.Neg(LR4.Scale(V, deds)), (* V *) t1 = LR4.Add(dedm2f,dedua), (* V *) t2 = LR4.Add(t1, dedvb), (* V *) t3 = LR4.Add(t2, dedrU), (* V *) t4 = LR4.Add(t3, dedsV), (* V *) deduf = LR4.Scale(dedu, f), (* V *) dedvf = LR4.Scale(dedv, f), (* V *) c1 = LR4.Add(deduf, dedr), (* V *) d1 = LR4.Add(dedvf, deds) (* V *) DO dedf := t4; deda := c1; dedb := d1; END END END EangleAux; PROCEDURE Eangle( READONLY R,S: LR4.T; VAR E: LONGREAL; VAR EDR,EDS: LR4.T; ) = (* Given two vectors "R" and "S" compute the "cos" of the angle between the vectors, the curvature term and the derivatives of energy respect to the two vectors: eeDR and eeDS. *) BEGIN WITH m = LR4.Norm(R) + Epsilon, n = LR4.Norm(S) + Epsilon, o = LR4.Dot(R,S), d = m*n, q = o/d DO IF d # 0.0d0 THEN E := K * (1.0d0 + q); IF grad THEN WITH eDq = 1.0d0 * K, eDo = eDq / d, eDd = - eDq * q / d, eDm = eDd * n, eDn = eDd * m DO EDR := LR4.Mix(eDo, S, eDm/m, R); EDS := LR4.Mix(eDo, R, eDn/n, S); END END END END END Eangle; BEGIN (* Initialize *) FOR i := 0 TO NV-1 DO eDc[i] := zero END; (* Compute energy "e", and the gradient "eDr": *) e := 0.0d0; FOR i := 0 TO num.nre-1 DO FOR j := 0 TO num.nce-1 DO FOR k := j+1 TO num.nce-1 DO IF ChilFace[i,j].exists AND ChilFace[i,k].exists THEN IF Adjacent(ChilFace[i,j], ChilFace[i,k]) THEN WITH u1 = OrgV(ChilFace[i,j].pa).num, v1 = OrgV(Enext (ChilFace[i,j].pa)).num, w1 = OrgV(Enext_1(ChilFace[i,j].pa)).num, u2 = OrgV(ChilFace[i,k].pa).num, v2 = OrgV(Enext (ChilFace[i,k].pa)).num, w2 = OrgV(Enext_1(ChilFace[i,k].pa)).num DO IF (v1 = v2) AND (u1 = w2) THEN AddTerm(v1,u1,w1,u2); ELSIF (v1 = w2) AND (u1 = u2) THEN AddTerm(v1,u1,w1,v2); ELSIF (v1 = u2) AND (u1 = v2) THEN AddTerm(v1,u1,w1,w2); ELSIF (u1 = v2) AND (w1 = w2) THEN AddTerm(u1,w1,v1,u2); ELSIF (u1 = w2) AND (w1 = u2) THEN AddTerm(u1,w1,v1,v2); ELSIF (u1 = u2) AND (w1 = v2) THEN AddTerm(u1,w1,v1,w2); ELSIF (w1 = v2) AND (v1 = w2) THEN AddTerm(w1,v1,u1,u2); ELSIF (w1 = w2) AND (v1 = u2) THEN AddTerm(w1,v1,u1,v2); ELSIF (w1 = u2) AND (v1 = v2) THEN AddTerm(w1,v1,u1,w2); ELSIF (v1 = w2) AND (u1 = v2) THEN AddTerm(v1,u1,w1,u2); ELSIF (v1 = v2) AND (u1 = u2) THEN AddTerm(v1,u1,w1,w2); ELSIF (v1 = u2) AND (u1 = w2) THEN AddTerm(v1,u1,w1,v2); ELSIF (u1 = w2) AND (w1 = v2) THEN AddTerm(u1,w1,v1,u2); ELSIF (u1 = v2) AND (w1 = u2) THEN AddTerm(u1,w1,v1,w2); ELSIF (u1 = u2) AND (w1 = w2) THEN AddTerm(u1,w1,v1,v2); ELSIF (w1 = w2) AND (v1 = v2) THEN AddTerm(w1,v1,u1,u2); ELSIF (w1 = v2) AND (v1 = u2) THEN AddTerm(w1,v1,u1,w2); ELSIF (w1 = u2) AND (v1 = w2) THEN AddTerm(w1,v1,u1,v2); END END END END END END END END END END Eval; PROCEDURE Adjacent(f1,f2: Face) : BOOLEAN = VAR count : INTEGER := 0; BEGIN WITH u1 = OrgV(f1.pa).num, v1 = OrgV(Enext (f1.pa)).num, w1 = OrgV(Enext_1(f1.pa)).num, u2 = OrgV(f2.pa).num, v2 = OrgV(Enext (f2.pa)).num, w2 = OrgV(Enext_1(f2.pa)).num DO IF u1 = u2 OR u1 = v2 OR u1 = w2 THEN count := count + 1; END; IF v1 = u2 OR v1 = v2 OR v1 = w2 THEN count := count + 1; END; IF w1 = u2 OR w1 = v2 OR w1 = w2 THEN count := count + 1; END; IF count = 2 THEN RETURN TRUE ELSE RETURN FALSE END END END Adjacent; PROCEDURE Name(<* UNUSED *> erg: T): TEXT = BEGIN RETURN "Curv2D()" END Name; BEGIN END OldCurvature2D. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/OriKamSpring.m3 MODULE OriKamSpring; (* In this module non exists an Apropiate factor normalization for this energy, actually it is 0.5. Revisions: 18-11-2000: Added the constant value Epsilon to avoid possiblev infinite values (Nan). *) IMPORT LR4, Triangulation, Fmt, Math, Stdio, Wr, Thread; FROM Triangulation IMPORT Topology, OrgV; FROM Energy IMPORT Coords, Gradient; FROM Stdio IMPORT stderr; CONST Epsilon = 1.0d-10; TYPE BOOLS = ARRAY OF BOOLEAN; LONGS = ARRAY OF LONGREAL; AdjMatrix = ARRAY OF ARRAY OF LONGREAL; VAR inf : LONGREAL := Math.pow(10.0d0,10.0d0); REVEAL T = Public BRANDED OBJECT F: LONGREAL; (* The energy normalization factor *) top: Topology; (* The topology *) termVar: REF BOOLS; (* TRUE if vertex is variable & existing *) m: REF AdjMatrix; (* Matrix of initial distances *) eDdif: REF ARRAY OF LONGS; (* (Work) Gradient of "e" rel. to "dif" *) L: LONGREAL; (* Kamada' constant *) l,k: REF AdjMatrix; (* parameters: lij is the original length of the spring between pi and pj; kij is the strength of the spring pi and pj. *) OVERRIDES init := Init; defTop := DefTop; defVar := DefVar; eval := Eval; name := Name; END; PROCEDURE Init(erg: T): T = BEGIN RETURN erg END Init; PROCEDURE DefTop(erg: T; READONLY top: Topology) = VAR dmax : LONGREAL; BEGIN WITH NV = top.NV, length = FLOAT(erg.length, LONGREAL), strength = FLOAT(erg.strength, LONGREAL) DO erg.m := MakeAdjMatrix(top); ShortestPath(erg.m, NV); IF erg.detail THEN PrintHalfMatrix(erg.m, NV); END; dmax := FindMaxDistance(erg.m, NV); erg.L := length/dmax; erg.F := 0.50d0; erg.top := top; erg.termVar := NEW(REF BOOLS, NV); erg.eDdif := NEW(REF ARRAY OF LONGS, NV, NV); erg.l := CalculateLength (erg.m, NV, erg.L); erg.k := CalculateStrengh(erg.m, NV, strength); IF erg.detail THEN PrintHalfMatrix(erg.k, NV); END; (* Just in case the client forgets to call "defVar": *) FOR i := 0 TO top.NV-1 DO erg.termVar^[i] := FALSE END; END END DefTop; PROCEDURE DefVar(erg: T; READONLY variable: BOOLS) = BEGIN (* Decides which vertices are relevant to kamada energy. A vertex is relevant iff it is variable. *) WITH NV = erg.top.NV, termVar = erg.termVar^ DO (* Find the relevant vertices: *) <* ASSERT NUMBER(variable) = NV *> FOR v := 0 TO NV-1 DO termVar[v] := variable[v]; END END END DefVar; PROCEDURE MakeAdjMatrix( READONLY top : Triangulation.Topology; ) : REF AdjMatrix = VAR m: REF ARRAY OF ARRAY OF LONGREAL; v: REF ARRAY OF INTEGER; BEGIN m := NEW(REF ARRAY OF ARRAY OF LONGREAL, top.NV, top.NV); FOR i := 0 TO top.NV-1 DO FOR j := 0 TO top.NV-1 DO m[i,j] := inf; END END; FOR i := 0 TO top.NV-1 DO WITH a = top.out[i], star = Triangulation.Neighbors(OrgV(a),top), nv = NUMBER(star^) DO m[i,i] := 0.0d0; v := NEW(REF ARRAY OF INTEGER, nv); FOR k := 0 TO nv-1 DO v[k] := star[k].num; m[i,v[k]] := 1.0d0; m[v[k],i] := 1.0d0; END END END; RETURN m; END MakeAdjMatrix; PROCEDURE FindMaxDistance( READONLY m: REF AdjMatrix; n: INTEGER; ) : LONGREAL = VAR max := 0.0d0; BEGIN FOR i := 0 TO n-1 DO FOR j := 0 TO i DO IF m[i,j] > max THEN max := m[i,j]; END END END; RETURN max; END FindMaxDistance; PROCEDURE CalculateStrengh( READONLY m : REF AdjMatrix; n: INTEGER; K: LONGREAL; ) : REF AdjMatrix = VAR k : REF ARRAY OF ARRAY OF LONGREAL; BEGIN k := NEW(REF ARRAY OF ARRAY OF LONGREAL, n, n); FOR i := 0 TO n-1 DO FOR j := 0 TO i DO IF i = j THEN k[i,j] := 0.0d0; ELSE k[i,j] := K / (m[i,j]*m[i,j]); k[j,i] := k[i,j]; END END END; RETURN k END CalculateStrengh; PROCEDURE CalculateLength( READONLY m : REF AdjMatrix; n: INTEGER; L: LONGREAL; ) : REF AdjMatrix = VAR l: REF ARRAY OF ARRAY OF LONGREAL; BEGIN l := NEW(REF ARRAY OF ARRAY OF LONGREAL, n, n); FOR i := 0 TO n-1 DO FOR j := 0 TO i DO l[i,j] := L * m[i,j]; l[j,i] := l[i,j]; END END; RETURN l; END CalculateLength; <* UNUSED *> PROCEDURE PrintAdjMatrix(READONLY m : REF AdjMatrix; n: INTEGER) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN FOR i := 0 TO n-1 DO FOR j := 0 TO n-1 DO IF m[i,j] = inf THEN Wr.PutText(stderr, "# "); ELSE Wr.PutText(stderr, Fmt.LongReal(m[i,j]) & " "); END; END; Wr.PutText(stderr, "\n"); END; END PrintAdjMatrix; PROCEDURE PrintHalfMatrix(READONLY m : REF AdjMatrix; n: INTEGER) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN FOR i := 0 TO n-1 DO FOR j := 0 TO i DO IF m[i,j] = inf THEN Wr.PutText(stderr, "# "); ELSE Wr.PutText(stderr, Fmt.LongReal(m[i,j],Fmt.Style.Fix,prec:=3) & " "); END; END; Wr.PutText(stderr, "\n"); END; END PrintHalfMatrix; PROCEDURE ShortestPath(VAR m : REF AdjMatrix; n : INTEGER) = VAR s : LONGREAL; BEGIN FOR i := 0 TO n-1 DO FOR j := 0 TO n-1 DO IF m[i,j] < inf THEN FOR k := 0 TO n-1 DO IF m[i,k] < inf THEN s := m[j,i] + m[i,k]; IF s < m[j,k] THEN m[j,k] := s END; END END END END END END ShortestPath; PROCEDURE Eval( erg: T; READONLY c: Coords; VAR e: LONGREAL; grad: BOOLEAN; VAR eDc: Gradient; ) = BEGIN WITH NV = erg.top.NV, F = erg.F, eDdif = erg.eDdif^, termVar = erg.termVar, k = erg.k^, l = erg.l^ DO PROCEDURE AccumTerm(READONLY u: CARDINAL) = (* Adds to "e" the energy term corresponding to a vertex "u". Returns also the gradient "eDdif". *) BEGIN WITH cu = c[u] DO FOR i := u+1 TO NV-1 DO WITH cv = c[i], n = LR4.Sub(cu,cv), dif = LR4.Norm(n), luv = l[u,i], kuv = k[u,i], d = dif - luv, d2 = d * d DO e := e + F * kuv * d2; IF grad THEN eDdif[u,i] := 2.0d0 * F * kuv * d; eDdif[i,u] := eDdif[u,i]; ELSE eDdif[u,i] := 0.0d0; eDdif[i,u] := eDdif[u,i]; END END END END END AccumTerm; PROCEDURE Distribute_eDdif(READONLY u: CARDINAL) = (* Distribute eDdif on endpoints "c[u]" and "c[v]" *) BEGIN WITH cu = c[u] DO FOR i := u+1 TO NV-1 DO WITH ci = c[i], n = LR4.Sub(cu,ci), dif = LR4.Norm(n)+Epsilon, eDi = eDc[i], eDu = eDc[u], difDcu = LR4.Scale(1.0d0/dif, n), difDci = LR4.Scale(-1.0d0/dif,n), eDcu = LR4.Scale(eDdif[u,i], difDcu), eDci = LR4.Scale(eDdif[u,i], difDci) DO IF termVar[i] THEN eDi := LR4.Add(eDi, eDci); END; IF termVar[u] THEN eDu := LR4.Add(eDu, eDcu); END END END END END Distribute_eDdif; BEGIN FOR i := 0 TO NV-1 DO eDc[i]:=LR4.T{0.0d0, 0.0d0, 0.0d0, 0.0d0} END; e := 0.0d0; FOR l := 0 TO NV-1 DO IF termVar[l] THEN AccumTerm(l); IF grad THEN Distribute_eDdif(l); END END END END END END Eval; PROCEDURE Name(erg: T): TEXT = BEGIN RETURN "OriKamada(ilenth := " & Fmt.Real(erg.length,Fmt.Style.Fix,prec := 3) & " istrength := " & Fmt.Real(erg.strength,Fmt.Style.Fix,prec:= 3) & ")"; END Name; BEGIN END OriKamSpring. (* Last edited on 2001-05-21 02:29:25 by stolfi *) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/OrientationEnergy.m3 MODULE OrientationEnergy; IMPORT LR4Extras, Triangulation, LR4, Fmt; FROM Octf IMPORT Enext_1, Fnext_1, Enext; FROM Triangulation IMPORT OrgV, Topology, Pair, Pneg; FROM Energy IMPORT Coords, Gradient; TYPE BOOLS = ARRAY OF BOOLEAN; REVEAL T = Public BRANDED OBJECT K: LONGREAL; (* The energy normalization factor *) top: Topology; (* The topology *) vVar: REF BOOLS; (* TRUE if vertex is variable *) polyRelevant: REF BOOLS; (* TRUE if polyhedron is relevant *) tetra : REF ARRAY OF Pair; (* Tetrahedra with consistent orientations *) OVERRIDES init := Init; defTop := DefTop; defVar := DefVar; eval := Eval; name := Name; END; PROCEDURE Init(erg: T): T = BEGIN RETURN erg END Init; PROCEDURE DefTop(erg: T; READONLY top: Topology) = BEGIN erg.K := 1.0d0/FLOAT(top.NP, LONGREAL); erg.top := top; erg.vVar := NEW(REF BOOLS, top.NV); erg.polyRelevant := NEW(REF BOOLS, top.NP); (* Collect polyhedra with consistent orientation *) erg.tetra := Triangulation.CollectTetrahedra(top); (* Just in case the client forgets to call "defVar": *) FOR i := 0 TO top.NV-1 DO erg.vVar[i] := FALSE END; FOR i := 0 TO top.NP-1 DO erg.polyRelevant[i] := FALSE END; END DefTop; PROCEDURE DefVar(erg: T; READONLY variable: BOOLS) = BEGIN (* Decide which polyhedrons are relevant to "Orientation" energy. A polyhedron is relevant iff it has at least one variable corner. *) WITH NV = erg.top.NV, NP = erg.top.NP, vVar = erg.vVar^, t = erg.tetra^, polyRelevant = erg.polyRelevant^ DO <* ASSERT NUMBER(variable) = NV *> vVar := variable; (* Find the relevant polyhedrons: *) FOR i := 0 TO NP-1 DO polyRelevant[i] := FALSE; END; FOR i := 0 TO NP-1 DO <* ASSERT Pneg(t[i]).num = i *> WITH a = t[i], u = OrgV(a), v = OrgV(Enext(a)), w = OrgV(Enext_1(a)), x = OrgV(Enext_1(Fnext_1(a))), f1 = a.facetedge.face, f2 = Fnext_1(a).facetedge.face, f3 = Fnext_1(Enext(a)).facetedge.face, f4 = Fnext_1(Enext_1(a)).facetedge.face DO <* ASSERT (f1 # f2) AND (f2 # f3) AND (f3 # f4) *> polyRelevant[i] := vVar[u.num] OR vVar[v.num] OR vVar[w.num] OR vVar[x.num]; END END END END DefVar; PROCEDURE Eval( erg: T; READONLY c: Coords; VAR e: LONGREAL; grad: BOOLEAN; VAR eDc: Gradient; ) = VAR eterm,etermDdet: LONGREAL; BEGIN WITH NV = erg.top.NV, NP = erg.top.NP, t = erg.tetra^, vVar = erg.vVar^, polyRelevant = erg.polyRelevant^, K = erg.K, minDet = erg.minVol * 6.0d0 DO PROCEDURE ComputeDet(READONLY U, V, W, X: CARDINAL) : LONGREAL = (* Compute the determinat of the tetrahedron "u v w x" in R^{3}. *) BEGIN WITH pu = c[U], pv = c[V], pw = c[W], px = c[X], a = LR4.T{pu[0], pu[1], pu[2], 1.0d0}, b = LR4.T{pv[0], pv[1], pv[2], 1.0d0}, c = LR4.T{pw[0], pw[1], pw[2], 1.0d0}, d = LR4.T{px[0], px[1], px[2], 1.0d0} DO RETURN LR4Extras.Det(a,b,c,d); END END ComputeDet; PROCEDURE Compute_e_from_det(det: LONGREAL; VAR eterm: LONGREAL; VAR etermDdet: LONGREAL) = (* Returns in "eterm" the energy term corresponding to a polyhedron with determinant "det". Also, if "grad" is true, stores in "etermDdet" the derivative of that term. *) BEGIN IF det >= minDet THEN eterm := 0.0d0; etermDdet := 0.0d0 ELSE WITH h = det/minDet-1.0d0, f = h*h DO eterm := K * f; IF grad THEN WITH hDdet = 1.0d0/minDet, fDdet = 2.0d0 * h * hDdet DO etermDdet := K * fDdet; END ELSE etermDdet := 0.0d0; END END END END Compute_e_from_det; PROCEDURE Distribute_eDdet( READONLY iu,iv,iw,ix: CARDINAL; etermDdet: LONGREAL) = (* Accumulates in "eDc" the gradient of "eterm" relative to the corners of the tetrahedron "iu iv iw ix", given the derivative "etermDdet" of "eterm" relative to the tetrahedron's determinant "det". *) BEGIN WITH pu = c[iu], pv = c[iv], pw = c[iw], px = c[ix], pu0 = pu[0], pu1 = pu[1], pu2 = pu[2], pv0 = pv[0], pv1 = pv[1], pv2 = pv[2], pw0 = pw[0], pw1 = pw[1], pw2 = pw[2], px0 = px[0], px1 = px[1], px2 = px[2], detwx23 = pw2 - px2, detwx13 = pw1 - px1, detwx12 = pw1 * px2 - px1 * pw2, detwx03 = pw0 - px0, detwx02 = pw0 * px2 - px0 * pw2, detwx01 = pw0 * px1 - px0 * pw1, detvx23 = pv2 - px2, detvx13 = pv1 - px1, detvx12 = pv1 * px2 - px1 * pv2, detvx03 = pv0 - px0, detvx02 = pv0 * px2 - px0 * pv2, detvx01 = pv0 * px1 - px0 * pv1, detvw23 = pv2 - pw2, detvw13 = pv1 - pw1, detvw12 = pv1 * pw2 - pw1 * pv2, detvw03 = pv0 - pw0, detvw02 = pv0 * pw2 - pw0 * pv2, detvw01 = pv0 * pw1 - pw0 * pv1, detDu0 = + pv1 * detwx23 - pv2 * detwx13 + detwx12, detDu1 = - pv0 * detwx23 + pv2 * detwx03 - detwx02, detDu2 = + pv0 * detwx13 - pv1 * detwx03 + detwx01, detDv0 = - pu1 * detwx23 + pu2 * detwx13 - detwx12, detDv1 = + pu0 * detwx23 - pu2 * detwx03 + detwx02, detDv2 = - pu0 * detwx13 + pu1 * detwx03 - detwx01, detDw0 = + pu1 * detvx23 - pu2 * detvx13 + detvx12, detDw1 = - pu0 * detvx23 + pu2 * detvx03 - detvx02, detDw2 = + pu0 * detvx13 - pu1 * detvx03 + detvx01, detDx0 = - pu1 * detvw23 + pu2 * detvw13 - detvw12, detDx1 = + pu0 * detvw23 - pu2 * detvw03 + detvw02, detDx2 = - pu0 * detvw13 + pu1 * detvw03 - detvw01, eDu0 = etermDdet * detDu0, eDu1 = etermDdet * detDu1, eDu2 = etermDdet * detDu2, eDv0 = etermDdet * detDv0, eDv1 = etermDdet * detDv1, eDv2 = etermDdet * detDv2, eDw0 = etermDdet * detDw0, eDw1 = etermDdet * detDw1, eDw2 = etermDdet * detDw2, eDx0 = etermDdet * detDx0, eDx1 = etermDdet * detDx1, eDx2 = etermDdet * detDx2 DO IF vVar[iu] THEN eDc[iu,0] := eDc[iu,0] + eDu0; eDc[iu,1] := eDc[iu,1] + eDu1; eDc[iu,2] := eDc[iu,2] + eDu2; END; IF vVar[iv] THEN eDc[iv,0] := eDc[iv,0] + eDv0; eDc[iv,1] := eDc[iv,1] + eDv1; eDc[iv,2] := eDc[iv,2] + eDv2; END; IF vVar[iw] THEN eDc[iw,0] := eDc[iw,0] + eDw0; eDc[iw,1] := eDc[iw,1] + eDw1; eDc[iw,2] := eDc[iw,2] + eDw2; END; IF vVar[ix] THEN eDc[ix,0] := eDc[ix,0] + eDx0; eDc[ix,1] := eDc[ix,1] + eDx1; eDc[ix,2] := eDc[ix,2] + eDx2; END END END Distribute_eDdet; BEGIN e := 0.0d0; (* Clear gradient accumulators *) FOR i := 0 TO NV-1 DO eDc[i] := LR4.T{0.0d0, ..} END; (* Enumerate polyhedrons and compute polyhedron determinants: *) FOR j := 0 TO NP-1 DO IF polyRelevant[j] THEN WITH a = t[j], un = OrgV(a).num, vn = OrgV(Enext(a)).num, wn = OrgV(Enext_1(a)).num, xn = OrgV(Enext_1(Fnext_1(a))).num, det= ComputeDet(un, vn, wn, xn) DO Compute_e_from_det(det, eterm, etermDdet); (* Wr.PutText(Stdio.stderr, Fmt.LongReal(det) & " " & Fmt.LongReal(eterm) & " " & Fmt.LongReal(etermDdet) & "\n"); VAR c: TEXT; BEGIN IF det < 0.0d0 THEN c := "-" ELSE c:= "+" END; Wr.PutText(Stdio.stderr, c); END; *) e := e + eterm; IF grad THEN Distribute_eDdet(un, vn, wn, xn, etermDdet) END END END END; (*Wr.PutText(Stdio.stderr, "###\n");*) END END END Eval; PROCEDURE Name(erg: T) : TEXT = BEGIN RETURN "Orient(" & "minVol := " & Fmt.LongReal(erg.minVol,Fmt.Style.Fix,prec := 6) & ")" END Name; BEGIN END OrientationEnergy. (* Last edited on 2001-05-07 10:56:33 by stolfi *) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/OriginalCurvature3D.m3 MODULE Curvature3D; (* Last edited on 2000-05-04 17:23:23 by lplozada *) IMPORT Triangulation, LR4; FROM Triangulation IMPORT Topology, Ppos, Pneg, TetraNegPosVertices; FROM Energy IMPORT Coords, Gradient; FROM LR4 IMPORT Add, Scale, Neg, Dot, Sub; CONST zero = LR4.T{0.0d0,0.0d0,0.0d0,0.0d0}; TYPE BOOLS = ARRAY OF BOOLEAN; REVEAL T = Public BRANDED OBJECT K: LONGREAL; (* The energy normalization factor *) top: Topology; (* The topology *) vVar: REF BOOLS; (* TRUE if vertex is variable *) faceRelevant: REF BOOLS; (* TRUE if face is relevant *) OVERRIDES init := Init; defTop := DefTop; defVar := DefVar; eval := Eval; name := Name; END; PROCEDURE Init(erg: T) : T = BEGIN RETURN erg END Init; PROCEDURE DefTop(erg: T; READONLY top: Topology) = BEGIN erg.K := 1.0d0; erg.top := top; erg.vVar := NEW(REF BOOLS, top.NV); erg.faceRelevant := NEW(REF BOOLS, top.NF); (* Just in case the client forgets to call "defVar": *) FOR i := 0 TO top.NV-1 DO erg.vVar[i] := FALSE END; FOR i := 0 TO top.NF-1 DO erg.faceRelevant[i] := FALSE END; END DefTop; PROCEDURE DefVar(erg: T; READONLY variable: BOOLS) = BEGIN (* Decide which face are relevant to the curvature energy. A face is relevant iff has exactly two polyhedron incident to it. *) WITH NV = erg.top.NV, NF = erg.top.NF, vVar = erg.vVar^, face = erg.top.face^, faceRelevant = erg.faceRelevant^ DO <* ASSERT NUMBER(variable) = NV *> vVar := variable; (* Find the relevant faces: *) FOR i := 0 TO NF-1 DO faceRelevant[i] := FALSE END; FOR i := 0 TO NF-1 DO WITH f = face[i], a = f.pa, p1 = Pneg(a), p2 = Ppos(a) DO IF (p1 # NIL AND p2 # NIL) THEN faceRelevant[i] := TRUE; END END END END END DefVar; PROCEDURE Eval( erg: T; READONLY c: Coords; VAR e: LONGREAL; grad: BOOLEAN; VAR eDc: Gradient; ) = CONST eps = 0.0d0; BEGIN WITH NV = erg.top.NV, NF = erg.top.NF, face = erg.top.face^, faceRelevant = erg.faceRelevant^, K = erg.K, vVar = erg.vVar^ DO PROCEDURE AddTerm(READONLY iu,iv,iw,ix,iy: CARDINAL) = (* Adds one term of the curvature energy to "e" (and its derivative to "eDc, if "grad" is TRUE). The terms correspond to the face "f = u v w" shared by the tetrahedra "u v w x" (Pneg) and "u v w y" (Ppos). _ _ |\ w w /| \ /|\ /|\ / \ / | \ / | \ / / | \ / | \ / | \ / | \ x /____|____\v v/____|____\ y \ | f / \ f | / \ | / \ | / \ | / \ | / \ | / \ | / \|/ \|/ u u Pneg Ppos *) VAR eterm: LONGREAL; eDdu, eDdv, eDdw, eDdx, eDdy: LR4.T; BEGIN WITH u = c[iu], v = c[iv], w = c[iw], x = c[ix], y = c[iy] DO term(u,v,w,x,y, eterm, eDdu, eDdv, eDdw, eDdx, eDdy); e := e + eterm; (*Wr.PutText(Stdio.stderr, Fmt.LongReal(e) & "\n");*) IF grad THEN IF vVar[iu] THEN eDc[iu] := LR4.Add(eDc[iu],eDdu); END; IF vVar[iv] THEN eDc[iv] := LR4.Add(eDc[iv],eDdv); END; IF vVar[iw] THEN eDc[iw] := LR4.Add(eDc[iw],eDdw); END; IF vVar[ix] THEN eDc[ix] := LR4.Add(eDc[ix],eDdx); END; IF vVar[iy] THEN eDc[iy] := LR4.Add(eDc[iy],eDdy); END END END END AddTerm; PROCEDURE term(u,v,w,x,y: LR4.T; VAR eterm: LONGREAL; VAR dedu,dedv,dedw,dedx,dedy: LR4.T; ) = VAR dedDv,dedDw,dedDx,dedDy: LR4.T; BEGIN WITH Dv = LR4.Sub(v,u), (* V *) Dw = LR4.Sub(w,u), (* V *) Dx = LR4.Sub(x,u), (* V *) Dy = LR4.Sub(y,u) (* V *) DO Eangle(Dv,Dw,Dx,Dy, eterm, dedDv,dedDw,dedDx,dedDy); dedv := dedDv; (* V *) dedw := dedDw; (* V *) dedx := dedDx; (* V *) dedy := dedDy; (* V *) dedu := Neg(Add(Add(Add(dedDv,dedDw),dedDx),dedDy)); END END term; PROCEDURE Eangle(r,s,a,b: LR4.T; VAR eterm: LONGREAL; VAR dedr,deds,deda,dedb: LR4.T; ) = (* compute the derivative of the orthogonal vectors "f" and "g" where "f= s - Proj(s,r)" and "g = r". *) VAR dedf,dedg: LR4.T; BEGIN WITH m = Dot(r,r), (* S *) n = Dot(r,s), (* S *) m2 = m * m, (* S *) q = n/m, (* S *) qr = Scale(q,r), (* V *) f = Sub(s,qr), (* V *) g = r (* V *) (* Now, "f" and "g" are orthogonal *) DO EangleAux(f,g,a,b,eterm,dedf,dedg,deda,dedb); WITH dedq = -LR4.Dot(dedf,r), (* S *) dedn = dedq/m, (* S *) dedm = -dedq * (n/m2), (* S *) r2 = LR4.Scale(2.0d0,r), (* V *) v1 = LR4.Scale(dedm, r2), (* V *) v2 = LR4.Scale(dedn, s), (* V *) v3 = LR4.Scale(-q , dedf), (* V *) v4 = dedg, (* V *) v12 = LR4.Add(v1,v2), (* V *) v123 = LR4.Add(v12,v3), (* V *) v1234= LR4.Add(v123,v4), (* V *) dednr = LR4.Scale(dedn, r) (* V *) DO dedr := v1234; deds := Add(dednr, dedf); END END END Eangle; PROCEDURE EangleAux(f,g,a,b: LR4.T; VAR eterm: LONGREAL; VAR dedf,dedg,deda,dedb: LR4.T; ) = (* compute the derivative of the orthogonal vectors "f" and "g" where "f= s - Proj(s,r)" and "g = r". *) VAR dedr,deds: LR4.T; BEGIN WITH m = LR4.Dot(f,f), (* S *) n = LR4.Dot(g,g), (* S *) u = LR4.Dot(f,a), (* S *) v = LR4.Dot(f,b), (* S *) x = LR4.Dot(g,a), (* S *) y = LR4.Dot(g,b), (* S *) U = u/m, (* S *) V = v/m, (* S *) X = x/n, (* S *) Y = y/n, (* S *) Uf = LR4.Scale(U,f), (* V *) Xg = LR4.Scale(X,g), (* V *) Vf = LR4.Scale(V,f), (* V *) Yg = LR4.Scale(Y,g), (* V *) UfXg = LR4.Neg(LR4.Add(Uf,Xg)), (* V *) VfYg = LR4.Neg(LR4.Add(Vf,Yg)), (* V *) R = LR4.Add(a,UfXg), (* V *) S = LR4.Add(b,VfYg) (* V *) DO EangleVec(R,S,eterm,dedr,deds); WITH dedY = - Dot(deds, g), (* S *) dedX = - Dot(dedr, g), (* S *) dedV = - Dot(deds, f), (* S *) dedU = - Dot(dedr, f), (* S *) dedx = dedX/n, (* S *) dedy = dedY/n, (* S *) dedu = dedU/m, (* S *) dedv = dedV/m, (* S *) dedm = (-1.0d0/m) * (dedU*U + dedV*V), (* S *) dedn = (-1.0d0/n) * (dedX*X + dedY*Y), (* S *) dedm2 = LR4.Scale(2.0d0,f), (* S *) dedm2f = LR4.Scale(dedm, dedm2), (* V *) dedua = LR4.Scale(dedu, a), (* V *) dedvb = LR4.Scale(dedv, b), (* V *) dedrU = LR4.Neg(LR4.Scale(U, dedr)), (* V *) dedsV = LR4.Neg(LR4.Scale(V, deds)), (* V *) t1 = LR4.Add(dedm2f,dedua), (* V *) t2 = LR4.Add(t1, dedvb), (* V *) t3 = LR4.Add(t2, dedrU), (* V *) t4 = LR4.Add(t3, dedsV), (* V *) g2 = LR4.Scale(2.0d0,g), (* S *) dedn2g = LR4.Scale(dedn, g2), (* V *) dedxa = LR4.Scale(dedx, a), (* V *) dedyb = LR4.Scale(dedy, b), (* V *) dedrX = LR4.Neg(LR4.Scale(X, dedr)), (* V *) dedsY = LR4.Neg(LR4.Scale(Y, deds)), (* V *) f1 = LR4.Add(dedn2g,dedxa), (* V *) f2 = LR4.Add(f1, dedyb), (* V *) f3 = LR4.Add(f2, dedrX), (* V *) f4 = LR4.Add(f3, dedsY), (* V *) deduf = LR4.Scale(dedu, f), (* V *) dedxg = LR4.Scale(dedx, g), (* V *) dedvf = LR4.Scale(dedv, f), (* V *) dedyg = LR4.Scale(dedy, g), (* V *) c1 = LR4.Add(deduf, dedxg), (* V *) c2 = LR4.Add(c1, dedr), (* V *) d1 = LR4.Add(dedvf, dedyg), (* V *) d2 = LR4.Add(d1, deds) (* V *) DO dedf := t4; dedg := f4; deda := c2; dedb := d2; END END END EangleAux; PROCEDURE EangleVec( READONLY R,S: LR4.T; VAR E: LONGREAL; VAR EDR,EDS: LR4.T; ) = (* Given two vectors "R" and "S" compute the "cos" of the angle between the vectors, the curvature term and the derivatives of energy respect to the two vectors: eeDR and eeDS. *) BEGIN WITH m = LR4.Norm(R) + eps, n = LR4.Norm(S) + eps, o = LR4.Dot(R,S), d = m*n, q = o/d DO IF d # 0.0d0 THEN E := K * (1.0d0 + q); IF grad THEN WITH eDq = 1.0d0 * K, eDo = eDq / d, eDd = - eDq * q / d, eDm = eDd * n, eDn = eDd * m DO EDR := LR4.Mix(eDo, S, eDm/m, R); EDS := LR4.Mix(eDo, R, eDn/n, S); END END END END END EangleVec; BEGIN (* Initialize *) FOR i := 0 TO NV-1 DO eDc[i] := zero END; (* Compute energy "e", and the gradient "eDr": *) e := 0.0d0; FOR i := 0 TO NF-1 DO IF faceRelevant[i] THEN WITH f = face[i], a = f.pa, t = TetraNegPosVertices(a), un = t[0].num, vn = t[1].num, wn = t[2].num, xn = t[3].num, yn = t[4].num DO <* ASSERT xn # yn *> AddTerm(un,vn,wn,xn,yn) END END END END END END Eval; PROCEDURE Name(<* UNUSED *> erg: T): TEXT = BEGIN RETURN "Curv3D()" END Name; BEGIN END Curvature3D. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/PZGeo3.m3 MODULE PZGeo3; (* Last edited on 1999-08-15 09:55:25 by hcgl *) IMPORT Math, Wr, Thread, Fmt; IMPORT LR3; FROM Math IMPORT sqrt; FROM Stdio IMPORT stderr; TYPE LONGS = ARRAY OF LONG; PROCEDURE LinearInterpolate( t: LONG; a: LONG; READONLY pa: Point; b: LONG; READONLY pb: Point; ): Point = VAR Ca, Cb: LONG; BEGIN IF (b - a) # 0.0d0 THEN Ca := (b - t) / (b - a); Cb := 1.00d0 - Ca ELSE Ca := 0.5d0; Cb := 0.5d0 END; RETURN Point{ Ca * pa[0] + Cb * pb[0], Ca * pa[1] + Cb * pb[1], Ca * pa[2] + Cb * pb[2] } END LinearInterpolate; PROCEDURE HermiteInterpolate( t: LONG; a: LONG; READONLY pa: Point; READONLY va: Point; b: LONG; READONLY pb: Point; READONLY vb: Point; VAR p: Point; VAR v: Point; ) = BEGIN <* ASSERT a <= b *> (* Test for degenerate intervals: *) (* If the interval has zero width, return the mean of the positions *) (* (which is an OK result) and the mean of the velocities *) (* (which is almost certainly wrong). *) IF b - a = 0.0d0 THEN (* Interval is degenerate: *) p := LR3.Mix(0.5d0, pa, 0.5d0, pb); v := LR3.Mix(0.5d0, va, 0.5d0, vb) ELSE WITH tab = b - a, tax = t - a, txb = b - t, rax = tax/tab, rxb = txb/tab, Cpa = rxb * rxb * (3.0d0 * rax + rxb), Dpa = - 6.0d0 * rax * rxb / tab, Cva = + rax * rxb * txb, Dva = + rxb * (rxb - 2.0d0 * rax), Cvb = - rax * rxb * tax, Dvb = + rax * (rax - 2.0d0 * rxb), Cpb = rax * rax * (rax + 3.0d0 * rxb), Dpb = + 6.0d0 * rax * rxb / tab DO p := Point{ Cpa*pa[0] + Cva*va[0] + Cvb*vb[0] + Cpb*pb[0], Cpa*pa[1] + Cva*va[1] + Cvb*vb[1] + Cpb*pb[1], Cpa*pa[2] + Cva*va[2] + Cvb*vb[2] + Cpb*pb[2] }; v := Point{ Dpa*pa[0] + Dva*va[0] + Dvb*vb[0] + Dpb*pb[0], Dpa*pa[1] + Dva*va[1] + Dvb*vb[1] + Dpb*pb[1], Dpa*pa[2] + Dva*va[2] + Dvb*vb[2] + Dpb*pb[2] } END END; END HermiteInterpolate; PROCEDURE EstimateVelocityQ( a: LONG; READONLY pa: Point; b: LONG; READONLY pb: Point; c: LONG; READONLY pc: Point; ): Point = BEGIN <* ASSERT a <= b AND b <= c *> (* Test for degenerate intervals. *) (* If intervals are degenerate, use linear interpolation, just to return *) (* something (but it will be almost surely wrong, and discontinuous). *) WITH eps = FLOAT(1.0e-7,LONG)*(c - a) DO IF eps = 0.0d0 THEN (* Whole interval is degenerate: *) RETURN Point{0.0d0, 0.0d0, 0.0d0} ELSIF (b-a) < eps THEN (* Left interval is degenerate; *) RETURN LR3.Scale(1.0d0/(c-b), LR3.Sub(pc, pb)); ELSIF (c-b) < eps THEN (* Right interval is degenerate; *) RETURN LR3.Scale(1.0d0/(b-a), LR3.Sub(pb, pa)); ELSE WITH fac = 1.0d0/(c - a), fab = 1.0d0/(b - a), fbc = 1.0d0/(c - b), Ca = fac - fab, Cb = fab - fbc, Cc = fbc - fac DO RETURN Point{ Ca*pa[0] + Cb*pb[0] + Cc*pc[0], Ca*pa[1] + Cb*pb[1] + Cc*pc[1], Ca*pa[2] + Cb*pb[2] + Cc*pc[2] } END END END; END EstimateVelocityQ; PROCEDURE EstimateVelocityL( a: LONG; READONLY pa: Point; b: LONG; <*UNUSED*> READONLY pb: Point; c: LONG; READONLY pc: Point; ): Point = BEGIN <* ASSERT a <= b AND b <= c *> (* Test for degenerate intervals: *) (* If whole interval is degenerate, return 0 (which is almost surely wrong). *) IF c-a = 0.0d0 THEN RETURN Point{0.0d0, 0.0d0, 0.0d0} ELSE WITH Ca = 1.0d0/(c - a) DO RETURN Point{ Ca*(pc[0] - pa[0]), Ca*(pc[1] - pa[1]), Ca*(pc[2] - pa[2]) } END END END EstimateVelocityL; PROCEDURE EstimateVelocityC( a: LONG; READONLY pa: Point; b: LONG; READONLY pb: Point; c: LONG; READONLY pc: Point; ): Point = BEGIN <* ASSERT a <= b AND b <= c *> (* Test for degenerate intervals: *) (* If whole interval is degenerate, return 0 (which is almost surely wrong). *) IF c - a = 0.0d0 THEN (* Whole interval is degenerate: *) RETURN Point{0.0d0, 0.0d0, 0.0d0} ELSE WITH tab = b - a, tbc = c - b, den = tab*tab + tbc*tbc, Ca = - tab/den, Cb = (tab - tbc)/den, Cc = + tbc/den DO <* ASSERT den > 0.0d0 *> RETURN Point{ Ca*pa[0] + Cb*pb[0] + Cc*pc[0], Ca*pa[1] + Cb*pb[1] + Cc*pc[1], Ca*pa[2] + Cb*pb[2] + Cc*pc[2] } END END END EstimateVelocityC; PROCEDURE HermiteCurveLength( a: LONG; READONLY pa: Point; READONLY va: Point; b: LONG; READONLY pb: Point; READONLY vb: Point; ): LONG = BEGIN (* Shift time axis so that midpoint of "b" and "c" is zero: *) WITH m = 0.5d0*(a+b) DO a := a - m; b := b - m; END; (* In case of degenerate interval, assume straight line: *) <* ASSERT a <= b *> IF b-a = 0.0d0 THEN RETURN LR3.Dist(pa, pb) ELSE WITH ab = b - a, (* Compute the derivative of the Hermite interpolant. *) (* Let the Hermite interpolant be "h(u) = h3*u^3 + ... + h0", where "u = 2*(t - a)/(b-a)-1" ranges from -1 to +1. Note that "dh/du(-1) = va*(b-a)/2", and "dh/du(1) = vb*(b-a)/2". Denoting "b-a" by "ab", the polynomial "h" is then | h(u) = | | + pa*(+u^3 - 3*u + 2)/4 | + pb*(-u^3 + 3*u + 2)/4 | + va*ab*(u^3 - u^2 - u + 1)/8 | + vb*ab*(u^3 + u^2 - u - 1)/8 | = | + (1/4*(pa-pb) + 1/8*(va+vb)*ab)*u^3 | + ((vb-va)*ab/8)*u^2 | + (3/4*(pb-pa) - 1/8*(va+vb)*ab)*u | + (1/2*(pa+pb) + 1/8*(va-vb)*ab Its derivative with respect to "u" is then | dh/du(u) = | + (3/4*(pa-pb)+3/8*(va+vb)*ab) * u^2 | + (1/4*(vb-va)*ab) * u | + (3/4*(pb-pa) - 1/8*(va+vb)*ab) Note that the curve depends only on the products "va*ab" and "vb*ab", not on "va", "vb", or "ab" separately. *) dxdu_2 = 0.750d0*(pa[0]-pb[0]) + 0.375d0*(va[0]+vb[0])*ab, dydu_2 = 0.750d0*(pa[1]-pb[1]) + 0.375d0*(va[1]+vb[1])*ab, dzdu_2 = 0.750d0*(pa[2]-pb[2]) + 0.375d0*(va[2]+vb[2])*ab, dxdu_1 = 0.250d0*(vb[0] - va[0])*ab, dydu_1 = 0.250d0*(vb[1] - va[1])*ab, dzdu_1 = 0.250d0*(vb[2] - va[2])*ab, dxdu_0 = 0.750d0*(pb[0]-pa[0]) - 0.125d0*(va[0]+vb[0])*ab, dydu_0 = 0.750d0*(pb[1]-pa[1]) - 0.125d0*(va[1]+vb[1])*ab, dzdu_0 = 0.750d0*(pb[2]-pa[2]) - 0.125d0*(va[2]+vb[2])*ab, (* Computes the speed squared "|dh/du|^2", as a function of "u". *) (* We only need the even powers: *) s_4 = dxdu_2*dxdu_2 + dydu_2*dydu_2 + dzdu_2*dzdu_2, s_2 = 2.0d0 * (dxdu_2*dxdu_0 + dydu_2*dydu_0 + dzdu_2*dzdu_0) + (dxdu_1*dxdu_1 + dydu_1*dydu_1 + dzdu_1*dzdu_1), s_0 = dxdu_0*dxdu_0 + dydu_0*dydu_0 + dzdu_0*dzdu_0, (* Computes the approximate square root of the polynomial. *) (* Assumes the constant term "s0" dominates, so *) (* "sqrt(U + s_0) ~ sqrt(s_0) + U/sqrt(s_0)/2" *) r_0 = sqrt(s_0 + 1.0d-50), r_2 = 0.5d0 * s_2/r_0, r_4 = 0.5d0 * s_4/r_0, (* Integrates the speed from -1 to +1 to get the length: *) length = 2.0d0*(r_4/5.0d0 + r_2/3.0d0 + r_0) DO RETURN length END END END HermiteCurveLength; <*UNUSED*> PROCEDURE Debug(msg: TEXT; READONLY x: LONGS) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(stderr, msg); FOR i := 0 TO LAST(x) DO Wr.PutText(stderr, " "); Wr.PutText(stderr, Fmt.Pad(Fmt.LongReal(x[i], prec := 8, style := Fmt.Style.Fix), 12) ) END; Wr.PutText(stderr, "\n"); END Debug; PROCEDURE BSplineApproximation( t: LONG; a: LONG; b: LONG; READONLY Pabc: Point; c: LONG; READONLY Pbcd: Point; d: LONG; READONLY Pcde: Point; e: LONG; READONLY Pdef: Point; f: LONG; ): Point = BEGIN WITH Ptbc = LinearInterpolate(t, a, Pabc, d, Pbcd), Ptcd = LinearInterpolate(t, b, Pbcd, e, Pcde), Ptde = LinearInterpolate(t, c, Pcde, f, Pdef), Pttc = LinearInterpolate(t, b, Ptbc, d, Ptcd), Pttd = LinearInterpolate(t, c, Ptcd, e, Ptde), Pttt = LinearInterpolate(t, c, Pttc, d, Pttd) DO RETURN Pttt END END BSplineApproximation; BEGIN END PZGeo3. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/PZGeo4.m3 MODULE PZGeo4; (* Last edited on 03-03-2000 by lozada *) IMPORT LR4; PROCEDURE LinearInterpolate( t: LONG; a: LONG; READONLY pa: Point; b: LONG; READONLY pb: Point; ): Point = VAR Ca, Cb: LONG; BEGIN IF (b - a) # 0.0d0 THEN Ca := (b - t) / (b - a); Cb := 1.00d0 - Ca ELSE Ca := 0.5d0; Cb := 0.5d0 END; RETURN Point{ Ca * pa[0] + Cb * pb[0], Ca * pa[1] + Cb * pb[1], Ca * pa[2] + Cb * pb[2], Ca * pa[3] + Cb * pb[3] } END LinearInterpolate; PROCEDURE HermiteInterpolate( t: LONG; a: LONG; READONLY pa: Point; READONLY va: Point; b: LONG; READONLY pb: Point; READONLY vb: Point; VAR p: Point; VAR v: Point; ) = BEGIN <* ASSERT a <= b *> (* Test for degenerate intervals: *) (* If the interval has zero width, return the mean of the positions *) (* (which is an OK result) and the mean of the velocities *) (* (which is almost certainly wrong). *) IF b - a = 0.0d0 THEN (* Interval is degenerate: *) p := LR4.Mix(0.5d0, pa, 0.5d0, pb); v := LR4.Mix(0.5d0, va, 0.5d0, vb) ELSE WITH tab = b - a, tax = t - a, txb = b - t, rax = tax/tab, rxb = txb/tab, Cpa = rxb * rxb * (3.0d0 * rax + rxb), Dpa = - 6.0d0 * rax * rxb / tab, Cva = + rax * rxb * txb, Dva = + rxb * (rxb - 2.0d0 * rax), Cvb = - rax * rxb * tax, Dvb = + rax * (rax - 2.0d0 * rxb), Cpb = rax * rax * (rax + 3.0d0 * rxb), Dpb = + 6.0d0 * rax * rxb / tab DO p := Point{ Cpa*pa[0] + Cva*va[0] + Cvb*vb[0] + Cpb*pb[0], Cpa*pa[1] + Cva*va[1] + Cvb*vb[1] + Cpb*pb[1], Cpa*pa[2] + Cva*va[2] + Cvb*vb[2] + Cpb*pb[2], Cpa*pa[3] + Cva*va[3] + Cvb*vb[3] + Cpb*pb[3] }; v := Point{ Dpa*pa[0] + Dva*va[0] + Dvb*vb[0] + Dpb*pb[0], Dpa*pa[1] + Dva*va[1] + Dvb*vb[1] + Dpb*pb[1], Dpa*pa[2] + Dva*va[2] + Dvb*vb[2] + Dpb*pb[2], Dpa*pa[3] + Dva*va[3] + Dvb*vb[3] + Dpb*pb[3] } END END; END HermiteInterpolate; PROCEDURE EstimateVelocityQ( a: LONG; READONLY pa: Point; b: LONG; READONLY pb: Point; c: LONG; READONLY pc: Point; ): Point = BEGIN <* ASSERT a <= b AND b <= c *> (* Test for degenerate intervals. *) (* If intervals are degenerate,use linear interpolation,just to return *) (* something (but it will be almost surely wrong, and discontinuous). *) WITH eps = FLOAT(1.0e-7,LONG)*(c - a) DO IF eps = 0.0d0 THEN (* Whole interval is degenerate: *) RETURN Point{0.0d0, 0.0d0, 0.0d0, 0.0d0} ELSIF (b-a) < eps THEN (* Left interval is degenerate; *) RETURN LR4.Scale(1.0d0/(c-b), LR4.Sub(pc, pb)); ELSIF (c-b) < eps THEN (* Right interval is degenerate; *) RETURN LR4.Scale(1.0d0/(b-a), LR4.Sub(pb, pa)); ELSE WITH fac = 1.0d0/(c - a), fab = 1.0d0/(b - a), fbc = 1.0d0/(c - b), Ca = fac - fab, Cb = fab - fbc, Cc = fbc - fac DO RETURN Point{ Ca*pa[0] + Cb*pb[0] + Cc*pc[0], Ca*pa[1] + Cb*pb[1] + Cc*pc[1], Ca*pa[2] + Cb*pb[2] + Cc*pc[2], Ca*pa[3] + Cb*pb[3] + Cc*pc[3] } END END END; END EstimateVelocityQ; PROCEDURE EstimateVelocityL( a: LONG; READONLY pa: Point; b: LONG; <*UNUSED*> READONLY pb: Point; c: LONG; READONLY pc: Point; ): Point = BEGIN <* ASSERT a <= b AND b <= c *> (* Test for degenerate intervals: *) (* If whole interval is degenerate,return 0 (which is almost surely wrong). *) IF c-a = 0.0d0 THEN RETURN Point{0.0d0, 0.0d0, 0.0d0, 0.0d0} ELSE WITH Ca = 1.0d0/(c - a) DO RETURN Point{ Ca*(pc[0] - pa[0]), Ca*(pc[1] - pa[1]), Ca*(pc[2] - pa[2]), Ca*(pc[3] - pa[3]) } END END END EstimateVelocityL; PROCEDURE EstimateVelocityC( a: LONG; READONLY pa: Point; b: LONG; READONLY pb: Point; c: LONG; READONLY pc: Point; ): Point = BEGIN <* ASSERT a <= b AND b <= c *> (* Test for degenerate intervals: *) (* If whole interval is degenerate, return 0 (which is almost surely wrong). *) IF c - a = 0.0d0 THEN (* Whole interval is degenerate: *) RETURN Point{0.0d0, 0.0d0, 0.0d0, 0.0d0} ELSE WITH tab = b - a, tbc = c - b, den = tab*tab + tbc*tbc, Ca = - tab/den, Cb = (tab - tbc)/den, Cc = + tbc/den DO <* ASSERT den > 0.0d0 *> RETURN Point{ Ca*pa[0] + Cb*pb[0] + Cc*pc[0], Ca*pa[1] + Cb*pb[1] + Cc*pc[1], Ca*pa[2] + Cb*pb[2] + Cc*pc[2], Ca*pa[3] + Cb*pb[3] + Cc*pc[3] } END END END EstimateVelocityC; PROCEDURE BSplineApproximation( t: LONG; a: LONG; b: LONG; READONLY Pabc: Point; c: LONG; READONLY Pbcd: Point; d: LONG; READONLY Pcde: Point; e: LONG; READONLY Pdef: Point; f: LONG; ): Point = BEGIN WITH Ptbc = LinearInterpolate(t, a, Pabc, d, Pbcd), Ptcd = LinearInterpolate(t, b, Pbcd, e, Pcde), Ptde = LinearInterpolate(t, c, Pcde, f, Pdef), Pttc = LinearInterpolate(t, b, Ptbc, d, Ptcd), Pttd = LinearInterpolate(t, c, Ptcd, e, Ptde), Pttt = LinearInterpolate(t, c, Pttc, d, Pttd) DO RETURN Pttt END END BSplineApproximation; PROCEDURE CubicBezier( t: LONG; READONLY Pabc: Point; READONLY Pbcd: Point; READONLY Pcde: Point; READONLY Pdef: Point; ): Point = BEGIN WITH Ptbc = LinearInterpolate(t, 1.0d0, Pabc, 1.0d0, Pbcd), Ptcd = LinearInterpolate(t, 1.0d0, Pbcd, 1.0d0, Pcde), Ptde = LinearInterpolate(t, 1.0d0, Pcde, 1.0d0, Pdef), Pttc = LinearInterpolate(t, 1.0d0, Ptbc, 1.0d0, Ptcd), Pttd = LinearInterpolate(t, 1.0d0, Ptcd, 1.0d0, Ptde), Pttt = LinearInterpolate(t, 1.0d0, Pttc, 1.0d0, Pttd) DO RETURN Pttt END END CubicBezier; BEGIN END PZGeo4. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/ParseEnergyParams.m3 MODULE ParseEnergyParams; IMPORT ParseParams, Math; IMPORT MixedEnergy, Energy, ExcenEnergy, ModKamSpring, OriKamSpring, SimpleSpring, Curvature3D, Curvature1D, Curvature2D, OrientationEnergy, VarKamSpring; PROCEDURE Parse(pp: ParseParams.T): MixedEnergy.T RAISES {ParseParams.Error} = CONST MaxTerms = 10; VAR e: ARRAY [0..MaxTerms-1] OF Energy.T; w: ARRAY [0..MaxTerms-1] OF REAL; n: CARDINAL := 0; BEGIN WHILE pp.keywordPresent("-energy") DO w[n] := pp.getNextReal(0.0, 1000000000.0); IF pp.testNext("Excen") THEN e[n] := NEW(ExcenEnergy.T).init(); ELSIF pp.testNext("Curv1D") THEN e[n] := NEW(Curvature1D.T).init(); ELSIF pp.testNext("Curv2D") THEN e[n] := NEW(Curvature2D.T).init(); ELSIF pp.testNext("Curv3D") THEN e[n] := NEW(Curvature3D.T) ELSIF pp.testNext("Spring") THEN IF pp.testNext("OriKamada") THEN VAR length : REAL; strength: REAL; detail : BOOLEAN := FALSE; BEGIN IF pp.testNext("strength") THEN strength := pp.getNextReal(0.0, 100000.0); ELSE strength := 1.0; END; IF pp.testNext("length") THEN length := pp.getNextReal(0.0, 100000.0); ELSE length := 2.0; END; IF pp.testNext("detail") THEN detail := TRUE; ELSE detail := FALSE; END; e[n] := NEW(OriKamSpring.T,strength:=strength, length:=length, detail:=detail); END END; IF pp.testNext("ModKamada") THEN VAR length: REAL; strength: REAL; BEGIN IF pp.testNext("strength") THEN strength := pp.getNextReal(0.0, 10.0); ELSE strength := 1.0; END; IF pp.testNext("length") THEN length := pp.getNextReal(0.0, 10.0); ELSE length := 2.0; END; e[n] := NEW(ModKamSpring.T,strength:=strength, length:=length); END END; IF pp.testNext("VarKamada") THEN VAR length: REAL; strength: REAL; BEGIN IF pp.testNext("strength") THEN strength := pp.getNextReal(0.0, 10.0); ELSE strength := 1.0; END; IF pp.testNext("length") THEN length := pp.getNextReal(0.0, 10.0); ELSE length := 2.0; END; e[n] := NEW(VarKamSpring.T,strength:=strength, length:=length); END END; IF pp.testNext("Simple") THEN VAR length: REAL; BEGIN IF pp.testNext("length") THEN length := pp.getNextReal(0.0, 10.0); ELSE length := 1.0; END; e[n] := NEW(SimpleSpring.T,length := length); END END; ELSIF pp.testNext("Spring") THEN VAR length: REAL; BEGIN IF pp.testNext("length") THEN length := pp.getNextReal(0.0, 10.0); ELSE length := 1.0; END; e[n] := NEW(SimpleSpring.T, length := length) END; ELSIF pp.testNext("Orien") THEN VAR minVol : LONGREAL; BEGIN IF pp.testNext("minVol") THEN minVol := pp.getNextLongReal(); ELSE minVol := 1.0d0/Math.sqrt(72.0d0); END; e[n] := NEW(OrientationEnergy.T) END; ELSE pp.error("Unknown energy: \"" & pp.getNext() & "\"") END; IF w[n] # 0.0 THEN INC(n) END; END; (* Default energy: *) IF n = 0 THEN RETURN NIL ELSE RETURN NEW(MixedEnergy.T).init(SUBARRAY(e, 0, n), SUBARRAY(w, 0, n)) END; END Parse; BEGIN END ParseEnergyParams. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/ParseMinimizerParams.m3 MODULE ParseMinimizerParams; IMPORT ParseParams; IMPORT Minimizer, Integrator, UniMin, GradMinimizer, CoordMinimizer, BrentUniMin, JSUniMin, EulerIntegrator, RKF4Integrator; PROCEDURE Parse(pp: ParseParams.T): Minimizer.T RAISES {ParseParams.Error} = BEGIN IF pp.keywordPresent("-minimizer") THEN IF pp.testNext("Grad") THEN VAR i: Integrator.T; BEGIN IF pp.testNext("RKF4") THEN i := NEW(RKF4Integrator.T) ELSIF pp.testNext("Euler") THEN i := NEW(EulerIntegrator.T) ELSE i := NEW(RKF4Integrator.T) END; RETURN NEW(GradMinimizer.T).setIntegrator(i) END ELSIF pp.testNext("Coord") THEN VAR i: UniMin.T; n: CARDINAL; BEGIN IF pp.testNext("Brent") THEN i := NEW(BrentUniMin.T); ELSIF pp.testNext("JS") THEN i := NEW(JSUniMin.T) ELSE i := NEW(BrentUniMin.T) END; IF pp.testNext("budget") THEN n := pp.getNextInt(5, 100) ELSE n := 7 END; RETURN NEW(CoordMinimizer.T).setUniMin(i).setBudget(n) END (* ELSIF pp.testNext("Waltz") THEN VAR l: LONGREAL; BEGIN IF pp.testNext("gamma") THEN l := pp.getNextLongReal(0.0d0, 100.0d0) ELSE l := 1.0d0; END; RETURN NEW(WaltzMinimizer.T).setGamma(l) END ELSIF pp.testNext("Down") THEN VAR a,b: LONGREAL; BEGIN IF pp.testNext("alpha") THEN a := pp.getNextLongReal(1.00001d0, 99.99999d0) ELSE a := 3.06956450765297882d0; END; IF pp.testNext("beta") THEN b := pp.getNextLongReal(0.00001d0, 0.99999d0) ELSE b := 0.5d0; END; RETURN NEW(DownMinimizer.T).setAlphaBeta(a,b) END *) ELSE pp.error("Unknown optimization method: " & pp.getNext()); <* ASSERT FALSE *> END; ELSE RETURN NIL END; END Parse; BEGIN END ParseMinimizerParams. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/PartialSpring.m3 MODULE PartialSpring; (* Last Version: 18-11-2000 *) IMPORT LR4, Triangulation, Fmt, Stdio, Wr, Thread, Octf; FROM Triangulation IMPORT Topology, OrgV; FROM Energy IMPORT Coords, Gradient; FROM Stdio IMPORT stderr; FROM Octf IMPORT Clock; CONST inf = LAST(CARDINAL); TYPE BOOLS = ARRAY OF BOOLEAN; LONGS = ARRAY OF LONGREAL; AdjacencyMatrix = ARRAY OF ARRAY OF CARDINAL; SpringList = ARRAY OF Spring; Spring = RECORD u,v : CARDINAL; (* extremities of the spring *) END; REVEAL T = Public BRANDED OBJECT top: Topology; (* The topology *) termVar: REF BOOLS; (* TRUE if vertex is variable & existing *) m : REF AdjacencyMatrix; (* Matrix of initial distances *) eDdif: REF ARRAY OF LONGS; (* (Work) Gradient of "e" rel. to "dif" *) L : LONGREAL; (* Kamada' constant *) spr : REF SpringList; (* pointer to the list Spring *) OVERRIDES init := Init; defTop := DefTop; defVar := DefVar; eval := Eval; name := Name; END; PROCEDURE Init(erg: T): T = BEGIN RETURN erg END Init; PROCEDURE DefTop(erg: T; READONLY top: Topology) = VAR dmax : LONGREAL; BEGIN WITH NV = top.NV DO erg.m := MakeAdjacencyMatrix(top); (*PrintHalfMatrix(erg.m, NV);*) ShortestPath(erg.m, NV); erg.spr := ChooseSprings(erg.m); (*PrintHalfMatrix(erg.m, NV);*) dmax := FLOAT(FindMaxDistance(erg.m, NV), LONGREAL); erg.L := FLOAT(erg.length,LONGREAL)/dmax; erg.top := top; erg.termVar := NEW(REF BOOLS, NV); erg.eDdif := NEW(REF ARRAY OF LONGS, NV, NV); (*PrintHalfMatrix(erg.k, NV);*) (* Just in case the client forgets to call "defVar": *) FOR i := 0 TO top.NV-1 DO erg.termVar^[i] := FALSE END; END END DefTop; PROCEDURE ChooseSprings(READOLNY m : AdjacencyMatrix; dmax: CARDINAL) : REF SpringList = VAR ns: CARDINAL := 0; nu,d: CARDINAL; BEGIN WITH NV = NUMBER(m), rs = NEW(REF SpringList, NV*NV), s = rs^, ok = NEW(REF ARRAY OF BOOLEAN, NV) DO (* catch distance less equal to 2 *) FOR i := 0 TO NV-1 DO FOR j := 0 TO NV-1 DO IF m[i,j] <= MIN(2,dmax) THEN s[ns] := Spring{i,j}; INC(ns); END END END; d := 2; WHILE d < dmax DO (* find a certain vertices that are distance >= "d" apart *) FOR i := 0 TO NV-1 DO ok[i] := TRUE END; FOR i := 0 TO NV-1 DO IF ok[i] THEN FOR j := 0 TO NV-1 DO IF m[i,j] <= d-1 THEN ok[j] := FALSE END; END END END; (* Add spring between those vertices that have a distance less equal to 2*d *) FOR i := 0 TO NV-1 DO IF ok[i] THEN FOR j := 0 TO NV-1 DO IF ok[j] AND m[i,j] < 2*d THEN s[ns] := Spring{i,j}; INC(ns) END; END END END; d := 2*d; END; WITH rr = NEW(REF SpringList, ns) DO rr^ := SUBARRAY(s,0,ns); RETURN rr; END END END ChooseSprings; PROCEDURE DefVar(erg: T; READONLY variable: BOOLS) = BEGIN (* Decide which vertices are relevant to kamada energy. A vertex is relevant iff it is variable. *) WITH NV = erg.top.NV, termVar = erg.termVar^ DO (* Find the relevant vertices: *) <* ASSERT NUMBER(variable) = NV *> FOR v := 0 TO NV-1 DO termVar[v] := variable[v]; END END END DefVar; PROCEDURE MakeAdjacencyMatrix( READONLY top : Triangulation.Topology; ) : REF AdjacencyMatrix = VAR m: REF AdjacencyMatrix; BEGIN m := NEW(REF ARRAY OF ARRAY OF CARDINAL, top.NV, top.NV); FOR i := 0 TO top.NV-1 DO FOR j := 0 TO top.NV-1 DO m[i,j] := inf; END; m[i,i] := 0; END; FOR i := 0 TO top.NE-1 DO WITH a = top.edge[i].pa, i = OrgV(a).num, j = OrgV(Clock(a)).num DO m[i,j] := 1; END END; RETURN m; END MakeAdjacencyMatrix; PROCEDURE FindMaxDistance( READONLY m: REF AdjacencyMatrix; n: INTEGER; ) : CARDINAL = VAR max := 0; BEGIN FOR i := 0 TO n-1 DO FOR j := 0 TO i DO IF m[i,j] > max THEN max := m[i,j]; END END END; RETURN max; END FindMaxDistance; PROCEDURE CalculateStrength(dist : CARDINAL) : LONGREAL = BEGIN IF dist = 0 THEN RETURN 0.0d0 ELSE WITH d = FLOAT(dist, LONGREAL) DO RETURN 1.0d0/(d*d); END END END CalculateStrength; PROCEDURE CalculateLength(dist : CARDINAL) : LONGREAL = BEGIN IF dist = 0 THEN RETURN 0.0d0 ELSE WITH d = FLOAT(dist, LONGREAL) DO RETURN d; END END END CalculateLength; <* UNUSED *> PROCEDURE PrintAdjacencyMatrix(READONLY m : REF AdjacencyMatrix; n: INTEGER) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN FOR i := 0 TO n-1 DO FOR j := 0 TO n-1 DO IF m[i,j] = inf THEN Wr.PutText(stderr, "# "); ELSE Wr.PutText(stderr, Fmt.Int(m[i,j]) & " "); END; END; Wr.PutText(stderr, "\n"); END; END PrintAdjacencyMatrix; <* UNUSED *> PROCEDURE PrintHalfMatrix(READONLY m : REF AdjacencyMatrix; n: INTEGER) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN FOR i := 0 TO n-1 DO FOR j := 0 TO i DO IF m[i,j] = inf THEN Wr.PutText(stderr, "# "); ELSE Wr.PutText(stderr, Fmt.Int(m[i,j]) & " "); END; END; Wr.PutText(stderr, "\n"); END; END PrintHalfMatrix; PROCEDURE ShortestPath(VAR m : REF AdjacencyMatrix; n : INTEGER) = VAR s : CARDINAL; BEGIN FOR i := 0 TO n-1 DO FOR j := 0 TO n-1 DO IF m[i,j] < inf THEN FOR k := 0 TO n-1 DO IF m[i,k] < inf THEN s := m[j,i] + m[i,k]; IF s < m[j,k] THEN m[j,k] := s END; END END END END END END ShortestPath; PROCEDURE Eval( erg: T; READONLY c: Coords; VAR e: LONGREAL; grad: BOOLEAN; VAR eDc: Gradient; ) = BEGIN WITH NV = erg.top.NV, eDdif = erg.eDdif^, termVar = erg.termVar, length = erg.L, strength = FLOAT(erg.strength, LONGREAL), m = erg.m^ DO PROCEDURE AccumTerm(READONLY u: CARDINAL) = (* Adds to "e" the energy term corresponding to a vertex "u". Returns also the gradient "eDdif". *) CONST Epsilon = 1.0d-10; BEGIN WITH cu = c[u] DO FOR i := u+1 TO NV-1 DO WITH cv = c[i], n = LR4.Sub(cu,cv), dif = LR4.Norm(n), d2 = dif * dif + Epsilon, duv = m[u,i], luv = length * CalculateLength(duv), kuv = strength * CalculateStrength(duv), l2 = luv * luv + Epsilon, d3 = d2 * dif + Epsilon DO e := e + kuv * ( (d2/l2) + (l2/d2) - 2.0d0 ); IF grad THEN eDdif[u,i] := 2.0d0 * kuv * ( (dif/l2) - (l2/d3) ); eDdif[i,u] := eDdif[u,i]; ELSE eDdif[u,i] := 0.0d0; eDdif[i,u] := eDdif[u,i]; END END END END END AccumTerm; PROCEDURE Distribute_eDdif(READONLY u: CARDINAL) = (* Distribute eDdif on endpoints "c[u]" and "c[v]" *) CONST Epsilon = 1.0d-10; BEGIN WITH cu = c[u] DO FOR i := u+1 TO NV-1 DO WITH ci = c[i], n = LR4.Sub(cu,ci), dif = LR4.Norm(n)+Epsilon, eDi = eDc[i], eDu = eDc[u], difDcu = LR4.Scale(1.0d0/dif, n), difDci = LR4.Scale(-1.0d0/dif,n), eDcu = LR4.Scale(eDdif[u,i], difDcu), eDci = LR4.Scale(eDdif[u,i], difDci) DO IF termVar[i] THEN eDi := LR4.Add(eDi, eDci); END; IF termVar[u] THEN eDu := LR4.Add(eDu, eDcu); END END END END; END Distribute_eDdif; BEGIN FOR i := 0 TO NV-1 DO eDc[i]:=LR4.T{0.0d0, 0.0d0, 0.0d0, 0.0d0} END; e := 0.0d0; FOR l := 0 TO NV-1 DO IF termVar[l] THEN AccumTerm(l); IF grad THEN Distribute_eDdif(l); END END END END END END Eval; PROCEDURE Name(erg: T): TEXT = BEGIN RETURN "PartialSpring(ilenth := " & Fmt.Real(erg.length,Fmt.Style.Fix,prec := 3) & " istrength := " & Fmt.Real(erg.strength,Fmt.Style.Fix,prec:= 3) & ")"; END Name; BEGIN END PartialSpring. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Pov.m3 MODULE Pov; (* This module contains common procedures used with the POVray tracer. Last Modification: 17-05-00 by lozada. *) IMPORT Wr, Thread, Fmt, R3, LR3; <* FATAL Thread.Alerted, Wr.Failure *> PROCEDURE WritePOVCoord(wr: Wr.T; c: LONGREAL) = BEGIN Wr.PutText(wr, Fmt.LongReal(c, Fmt.Style.Fix, prec := 4)) END WritePOVCoord; PROCEDURE WritePOVPoint(wr: Wr.T; READONLY p: LR3.T) = BEGIN Wr.PutText(wr, "<"); WritePOVCoord(wr,p[0]); Wr.PutText(wr, ","); WritePOVCoord(wr,p[1]); Wr.PutText(wr, ","); WritePOVCoord(wr,p[2]); Wr.PutText(wr, ">"); END WritePOVPoint; PROCEDURE WritePOVColor(wr: Wr.T; READONLY cr: R3.T) = BEGIN Wr.PutText(wr, "rgb <"); Wr.PutText(wr, Fmt.Real(cr[0], Fmt.Style.Fix, 4)); Wr.PutText(wr, ","); Wr.PutText(wr, Fmt.Real(cr[1], Fmt.Style.Fix, 4)); Wr.PutText(wr, ","); Wr.PutText(wr, Fmt.Real(cr[2], Fmt.Style.Fix, 4)); Wr.PutText(wr, ">"); END WritePOVColor; PROCEDURE WritePOVColorTransp(wr: Wr.T; READONLY cr: R3.T; tr: REAL; filter: BOOLEAN) = BEGIN IF filter THEN Wr.PutText(wr, "rgbf") ELSE Wr.PutText(wr, "rgbt") END; Wr.PutText(wr, " <"); Wr.PutText(wr, Fmt.Real(cr[0], Fmt.Style.Fix, 4)); Wr.PutText(wr, ","); Wr.PutText(wr, Fmt.Real(cr[1], Fmt.Style.Fix, 4)); Wr.PutText(wr, ","); Wr.PutText(wr, Fmt.Real(cr[2], Fmt.Style.Fix, 4)); Wr.PutText(wr, ","); Wr.PutText(wr, Fmt.Real(tr)); Wr.PutText(wr, ">"); END WritePOVColorTransp; PROCEDURE WritePOVSphere( wr: Wr.T; READONLY p: LR3.T; radius: REAL; READONLY cr: R3.T; tr: REAL; filter: BOOLEAN; tag1, tag2: TEXT := ""; ) = BEGIN Wr.PutText(wr, " sphere {\n"); Wr.PutText(wr, " "); WritePOVPoint(wr,p); Wr.PutText(wr, ", " & Fmt.Real(radius) & "\n"); Wr.PutText(wr, " texture { pigment { color "); WritePOVColorTransp(wr,cr,tr,filter); Wr.PutText(wr, " } } // " & tag1 & " " & tag2 & " \n"); Wr.PutText(wr, " } \n"); Wr.PutText(wr, "\n"); Wr.Flush(wr); END WritePOVSphere; PROCEDURE WritePOVCylinder( wr: Wr.T; READONLY o,d: LR3.T; radius: REAL; READONLY cr: R3.T; tr: REAL; filter: BOOLEAN; tag1, tag2: TEXT := ""; ) = BEGIN Wr.PutText(wr, " cylinder {\n"); Wr.PutText(wr, " "); WritePOVPoint(wr,o); Wr.PutText(wr, ",\n"); Wr.PutText(wr, " "); WritePOVPoint(wr,d); Wr.PutText(wr, ",\n"); Wr.PutText(wr, " " & Fmt.Real(radius) & "\n"); Wr.PutText(wr, " open\n"); Wr.PutText(wr, " texture { pigment { color "); WritePOVColorTransp(wr, cr, tr,filter); Wr.PutText(wr, " } } // " & tag1 & " " & tag2 & " \n"); Wr.PutText(wr, " }\n"); Wr.PutText(wr, "\n"); Wr.Flush(wr); END WritePOVCylinder; PROCEDURE WritePOVTriangle( wr: Wr.T; READONLY a,b,c: LR3.T; READONLY cr: R3.T; tr: REAL; filter: BOOLEAN; tag1, tag2: TEXT := ""; ) = BEGIN Wr.PutText(wr," triangle { \n"); Wr.PutText(wr," "); WritePOVPoint(wr,a); Wr.PutText(wr, ",\n"); Wr.PutText(wr," "); WritePOVPoint(wr,b); Wr.PutText(wr, ",\n"); Wr.PutText(wr," "); WritePOVPoint(wr,c); Wr.PutText(wr, "\n"); Wr.PutText(wr, " texture { pigment { color "); WritePOVColorTransp(wr, cr, tr, filter); Wr.PutText(wr, " } finish { ambient 0.1 diffuse 0.9 } } // " & tag1 & " " & tag2 & " \n"); Wr.PutText(wr," }\n"); Wr.PutText(wr,"\n"); Wr.Flush(wr); END WritePOVTriangle; PROCEDURE WritePOVTriangleTex( wr: Wr.T; READONLY a,b,c: LR3.T; texture: TEXT; ) = BEGIN Wr.PutText(wr," triangle { \n"); Wr.PutText(wr," "); WritePOVPoint(wr,a); Wr.PutText(wr, ",\n"); Wr.PutText(wr," "); WritePOVPoint(wr,b); Wr.PutText(wr, ",\n"); Wr.PutText(wr," "); WritePOVPoint(wr,c); Wr.PutText(wr, "\n"); Wr.PutText(wr, " texture { " & texture & " } \n"); Wr.PutText(wr, " } \n"); Wr.PutText(wr, "\n"); Wr.Flush(wr); END WritePOVTriangleTex; PROCEDURE WritePOVSquare( wr: Wr.T; READONLY a,b,c,d: LR3.T; READONLY cr: R3.T; tr: REAL; filter: BOOLEAN; ) = BEGIN Wr.PutText(wr," union{\n"); Wr.PutText(wr," "); Wr.PutText(wr,"triangle {"); WritePOVPoint(wr,a); Wr.PutText(wr,",\n"); Wr.PutText(wr," ");WritePOVPoint(wr,b); Wr.PutText(wr,",\n"); Wr.PutText(wr," ");WritePOVPoint(wr,c); Wr.PutText(wr,"}\n"); Wr.PutText(wr," "); Wr.PutText(wr,"triangle {"); WritePOVPoint(wr,c); Wr.PutText(wr,",\n"); Wr.PutText(wr," ");WritePOVPoint(wr,d); Wr.PutText(wr,",\n"); Wr.PutText(wr," ");WritePOVPoint(wr,a); Wr.PutText(wr,"}\n"); Wr.PutText(wr,"texture {\n"); Wr.PutText(wr," pigment { color "); WritePOVColorTransp(wr,cr,tr,filter); Wr.PutText(wr, " } finish { ambient 0.1 diffuse 0.9 } }\n"); Wr.PutText(wr, " } \n"); Wr.PutText(wr, "\n"); END WritePOVSquare; PROCEDURE WritePOVTetrahedron( wr: Wr.T; READONLY u,v,w,x: LR3.T; READONLY du,dv,dw,dx: LONGREAL; cr: R3.T; tr: REAL; filter: BOOLEAN; ) = BEGIN Wr.PutText(wr," intersection{\n"); Wr.PutText(wr," plane{"); WritePOVPoint(wr,u); Wr.PutText(wr,", "); WritePOVCoord(wr,du); Wr.PutText(wr," }\n"); Wr.PutText(wr," plane{"); WritePOVPoint(wr,v); Wr.PutText(wr,", "); WritePOVCoord(wr,dv); Wr.PutText(wr," }\n"); Wr.PutText(wr," plane{"); WritePOVPoint(wr,w); Wr.PutText(wr,", "); WritePOVCoord(wr,dw); Wr.PutText(wr," }\n"); Wr.PutText(wr," plane{"); WritePOVPoint(wr,x); Wr.PutText(wr,", "); WritePOVCoord(wr,dx); Wr.PutText(wr," }\n"); Wr.PutText(wr," pigment { color rgbt <1.0000,1.0000,1.0000,0.925> }\n"); Wr.PutText(wr," interior{\n"); Wr.PutText(wr," media { emission "); WritePOVColorTransp(wr,cr,tr,filter); Wr.PutText(wr," }\n"); Wr.PutText(wr," }\n"); Wr.PutText(wr," hollow\n"); Wr.PutText(wr," }\n\n"); END WritePOVTetrahedron; PROCEDURE WritePOVSmoothTriangle( wr: Wr.T; READONLY a, an: LR3.T; READONLY b, bn: LR3.T; READONLY c, cn: LR3.T; READONLY cr: R3.T; tr: REAL; filter: BOOLEAN; ) = BEGIN Wr.PutText(wr, " smooth_triangle {\n"); Wr.PutText(wr, " "); WritePOVPoint(wr,a); Wr.PutText(wr, ", "); WritePOVPoint(wr,an); Wr.PutText(wr, ",\n"); Wr.PutText(wr, " "); WritePOVPoint(wr,b); Wr.PutText(wr, ", "); WritePOVPoint(wr,bn); Wr.PutText(wr, ",\n"); Wr.PutText(wr, " "); WritePOVPoint(wr,c); Wr.PutText(wr, ", "); WritePOVPoint(wr,cn); Wr.PutText(wr, "\n"); (*Wr.PutText(wr, " texture { facetexture } \n");*) Wr.PutText(wr, " pigment { color "); WritePOVColorTransp(wr,cr,tr,filter); Wr.PutText(wr, " }\n"); Wr.PutText(wr, " } \n"); Wr.PutText(wr, "\n"); Wr.Flush(wr); END WritePOVSmoothTriangle; PROCEDURE WritePOVPenta( wr: Wr.T; READONLY a,b,c,d,e: LR3.T; READONLY cr: R3.T; tr: REAL; filter: BOOLEAN; ) = BEGIN Wr.PutText(wr," union{\n"); Wr.PutText(wr," ");Wr.PutText(wr,"triangle {"); WritePOVPoint(wr,a); Wr.PutText(wr,",\n"); Wr.PutText(wr," ");WritePOVPoint(wr,b); Wr.PutText(wr,",\n"); Wr.PutText(wr," ");WritePOVPoint(wr,c); Wr.PutText(wr,"}\n"); Wr.PutText(wr," ");Wr.PutText(wr,"triangle {"); WritePOVPoint(wr,c); Wr.PutText(wr,",\n"); Wr.PutText(wr," ");WritePOVPoint(wr,d); Wr.PutText(wr,",\n"); Wr.PutText(wr," ");WritePOVPoint(wr,a); Wr.PutText(wr,"}\n"); Wr.PutText(wr," ");Wr.PutText(wr,"triangle {"); WritePOVPoint(wr,d); Wr.PutText(wr,",\n"); Wr.PutText(wr," ");WritePOVPoint(wr,e); Wr.PutText(wr,",\n"); Wr.PutText(wr," ");WritePOVPoint(wr,a); Wr.PutText(wr,"}\n"); Wr.PutText(wr," pigment { color "); WritePOVColorTransp(wr,cr,tr,filter); Wr.PutText(wr, " }\n"); Wr.PutText(wr, " } \n"); Wr.PutText(wr, "\n"); END WritePOVPenta; BEGIN END Pov. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/ProxTetraEnergy.m3 (* Last Modification: 19-08-99 *) MODULE ProxTetraEnergy; IMPORT Math, LR4, Fmt, Energy, Triangulation; FROM Triangulation IMPORT Topology, DegreeOfVertex; FROM Energy IMPORT Coords, Gradient; TYPE Quad = RECORD u, v, w, x: CARDINAL END; BOOLS = ARRAY OF BOOLEAN; LONGS = ARRAY OF LONGREAL; REVEAL T = Public BRANDED OBJECT top: Topology; NT: CARDINAL; (* Number of tetrahedrons existing on "triang" *) K: LONGREAL; (* Energy normalization factor *) vVar: REF BOOLS; (* Which vertices are variable *) quad: REF ARRAY OF Quad; (* The existing tetrahedrons *) pVar: REF BOOLS; (* Which tetrahedrons in "quad" are variable *) bar: REF Coords; (* (Work) Barycenters of tetrahedrons in "quad" *) eDbar: REF Coords; (* (Work) Gradient of "e" rel "bar" *) rsq: REF LONGS; (* (Work) Nominal tetrahedron radius, squared *) eDrsq: REF LONGS; (* (Work) Gradient of "e" rel "rsq" *) OVERRIDES init := Init; defTop := DefTop; defVar := DefVar; eval := Eval; name := Name; END; PROCEDURE Init(erg: T): T = BEGIN RETURN erg END Init; PROCEDURE DefTop(erg: T; READONLY top: Topology) = BEGIN erg.top := top; (* Work areas: *) erg.quad := CollectExistingTetrahedrons(top); erg.NT := NUMBER(erg.quad^); erg.K := 1.0d0/FLOAT(erg.NT*erg.NT, LONGREAL); erg.vVar := NEW(REF BOOLS, top.NV); erg.pVar := NEW(REF BOOLS, erg.NT); erg.bar := NEW(REF Coords, erg.NT); erg.eDbar := NEW(REF Coords, erg.NT); erg.rsq := NEW(REF ARRAY OF LONGREAL, erg.NT); erg.eDrsq := NEW(REF ARRAY OF LONGREAL, erg.NT); (* In case the client forgets to call "defVar": *) FOR i := 0 TO erg.NT-1 DO erg.pVar[i] := TRUE END; END DefTop; PROCEDURE CollectExistingTetrahedrons(READONLY top: Topology): REF ARRAY OF Quad = VAR NT: CARDINAL := 0; BEGIN WITH NP = top.NP, t = NEW(REF ARRAY OF Quad, NP)^ DO FOR i := 0 TO NP-1 DO WITH p = top.polyhedron[i], a = top.region[i] DO IF p.exists AND DegreeOfVertex(a) = 4 THEN WITH u = p.vertex[0], un = NARROW(u, Triangulation.Vertex), v = p.vertex[1], vn = NARROW(v, Triangulation.Vertex), w = p.vertex[2], wn = NARROW(w, Triangulation.Vertex), x = p.vertex[3], xn = NARROW(x, Triangulation.Vertex) DO <* ASSERT un.exists AND vn.exists AND wn.exists AND xn.exists *> t[NT] := Quad{u.num, v.num, w.num, x.num} END; INC(NT) END END END; WITH r = NEW(REF ARRAY OF Quad, NT) DO r^ := SUBARRAY(t, 0, NT); RETURN r END END END CollectExistingTetrahedrons; PROCEDURE DefVar(erg: T; READONLY variable: ARRAY OF BOOLEAN) = BEGIN (* Separate the existing tetrahedrons now in "triang" into the variable list "pVar" and the fixed list "tfix". (A tetrhedron is variable if any of its vertices is variable.) *) WITH NT = erg.NT, NV = erg.top.NV, vVar = erg.vVar^, quad = erg.quad^, pVar = erg.pVar^ DO <* ASSERT NUMBER(variable) = NV *> vVar := variable; FOR i := 0 TO NT-1 DO WITH ti = quad[i] DO pVar[i] := vVar[ti.u] OR vVar[ti.v] OR vVar[ti.w] OR vVar[ti.x] END END; END END DefVar; PROCEDURE Eval( erg: T; READONLY c: Coords; VAR e: LONGREAL; grad: BOOLEAN; VAR eDc: Gradient; ) = BEGIN WITH NT = erg.NT, NV = erg.top.NV, vVar = erg.vVar^, quad = erg.quad^, pVar = erg.pVar^, bar = erg.bar^, eDbar = erg.eDbar^, rsq = erg.rsq^, eDrsq = erg.eDrsq^, fuzz = FLOAT(erg.fuzz, LONGREAL), fuzz2 = fuzz*fuzz, K = erg.K DO PROCEDURE Compute_rsq(READONLY t: Quad): LONGREAL = (* Computes the 'radius squared' of "t", actually the mean squared vertex-barycenter distance *) VAR r: LONGREAL := 0.0d0; BEGIN WITH u = c[t.u], v = c[t.v], w = c[t.w], x = c[t.x] DO WITH uv0 = u[0] - v[0], uw0 = u[0] - w[0], ux0 = u[0] - x[0], vw0 = v[0] - w[0], vx0 = v[0] - x[0], wx0 = w[0] - x[0] DO r := r + uv0*uv0 + uw0*uw0 + ux0*ux0 + vw0*vw0 + vx0*vx0 + wx0*wx0 END; WITH uv1 = u[1] - v[1], uw1 = u[1] - w[1], ux1 = u[1] - x[1], vw1 = v[1] - w[1], vx1 = v[1] - x[1], wx1 = w[1] - x[1] DO r := r + uv1*uv1 + uw1*uw1 + ux1*ux1 + vw1*vw1 + vx1*vx1 + wx1*wx1 END; WITH uv2 = u[2] - v[2], uw2 = u[2] - w[2], ux2 = u[2] - x[2], vw2 = v[2] - w[2], vx2 = v[2] - x[2], wx2 = w[2] - x[2] DO r := r + uv2*uv2 + uw2*uw2 + ux2*ux2 + vw2*vw2 + vx2*vx2 + wx2*wx2 END; WITH uv3 = u[3] - v[3], uw3 = u[3] - w[3], ux3 = u[3] - x[3], vw3 = v[3] - w[3], vx3 = v[3] - x[3], wx3 = w[3] - x[3] DO r := r + uv3*uv3 + uw3*uw3 + ux3*ux3 + vw3*vw3 + vx3*vx3 + wx3*wx3 END; RETURN r/16.0d0 END; END Compute_rsq; PROCEDURE Distribute_eDrsq(READONLY t: Quad; READONLY eDr2: LONGREAL) = (* Adds to the gradient "eDc" the component due to the influence "eDr2" of the radius squared of "quad" on the energy. *) BEGIN WITH eDs = 2.0d0/16.0d0*eDr2, u = c[t.u], v = c[t.v], w = c[t.w], x = c[t.x] DO IF vVar[t.u] THEN WITH eDu = eDc[t.u] DO eDu[0] := eDu[0] + eDs * (u[0]-v[0] + u[0]-w[0] + u[0]-x[0]); eDu[1] := eDu[1] + eDs * (u[1]-v[1] + u[1]-w[1] + u[1]-x[1]); eDu[2] := eDu[2] + eDs * (u[2]-v[2] + u[2]-w[2] + u[2]-x[2]); eDu[3] := eDu[3] + eDs * (u[3]-v[3] + u[3]-w[3] + u[3]-x[3]); END END; IF vVar[t.v] THEN WITH eDv = eDc[t.v] DO eDv[0] := eDv[0] + eDs * (v[0]-u[0] + v[0]-w[0] + v[0]-x[0]); eDv[1] := eDv[1] + eDs * (v[1]-u[1] + v[1]-w[1] + v[1]-x[1]); eDv[2] := eDv[2] + eDs * (v[2]-u[2] + v[2]-w[2] + v[2]-x[2]); eDv[3] := eDv[3] + eDs * (v[3]-u[3] + v[3]-w[3] + v[3]-x[3]); END END; IF vVar[t.w] THEN WITH eDw = eDc[t.w] DO eDw[0] := eDw[0] + eDs * (w[0]-v[0] + w[0]-u[0] + w[0]-x[0]); eDw[1] := eDw[1] + eDs * (w[1]-v[1] + w[1]-u[1] + w[1]-x[1]); eDw[2] := eDw[2] + eDs * (w[2]-v[2] + w[2]-u[2] + w[2]-x[2]); eDw[3] := eDw[3] + eDs * (w[3]-v[3] + w[3]-u[3] + w[3]-x[3]); END END; IF vVar[t.x] THEN WITH eDx = eDc[t.x] DO eDx[0] := eDx[0] + eDs * (x[0]-v[0] + x[0]-w[0] + x[0]-u[0]); eDx[1] := eDx[1] + eDs * (x[1]-v[1] + x[1]-w[1] + x[1]-u[1]); eDx[2] := eDx[2] + eDs * (x[2]-v[2] + x[2]-w[2] + x[2]-u[2]); eDx[3] := eDx[3] + eDs * (x[3]-v[3] + x[3]-w[3] + x[3]-u[3]); END END; END; END Distribute_eDrsq; PROCEDURE Compute_bar(READONLY t: Quad): LR4.T = VAR b: LR4.T; BEGIN WITH u = c[t.u], v = c[t.v], w = c[t.w], x = c[t.x] DO b[0]:= (u[0] + v[0] + w[0] + x[0])/4.0d0; b[1]:= (u[1] + v[1] + w[1] + x[1])/4.0d0; b[2]:= (u[2] + v[2] + w[2] + x[2])/4.0d0; b[3]:= (u[3] + v[3] + w[3] + x[3])/4.0d0; RETURN b END; END Compute_bar; PROCEDURE Distribute_eDbar(READONLY t: Quad; READONLY eDb: LR4.T) = (* Adds to the gradient "eDc" the component due to the influence "eDb" of "quad"'s barycenter on the energy. *) BEGIN WITH eDs0 = eDb[0]/4.0d0, eDs1 = eDb[1]/4.0d0, eDs2 = eDb[2]/4.0d0, eDs3 = eDb[3]/4.0d0 DO IF vVar[t.u] THEN WITH eDu = eDc[t.u] DO eDu[0] := eDu[0] + eDs0; eDu[1] := eDu[1] + eDs1; eDu[2] := eDu[2] + eDs2; eDu[3] := eDu[3] + eDs3; END END; IF vVar[t.v] THEN WITH eDv = eDc[t.v] DO eDv[0] := eDv[0] + eDs0; eDv[1] := eDv[1] + eDs1; eDv[2] := eDv[2] + eDs2; eDv[3] := eDv[3] + eDs3; END END; IF vVar[t.w] THEN WITH eDw = eDc[t.w] DO eDw[0] := eDw[0] + eDs0; eDw[1] := eDw[1] + eDs1; eDw[2] := eDw[2] + eDs2; eDw[3] := eDw[3] + eDs3; END END; IF vVar[t.w] THEN WITH eDw = eDc[t.w] DO eDw[0] := eDw[0] + eDs0; eDw[1] := eDw[1] + eDs1; eDw[2] := eDw[2] + eDs2; eDw[3] := eDw[3] + eDs3; END END; IF vVar[t.x] THEN WITH eDx = eDc[t.x] DO eDx[0] := eDx[0] + eDs0; eDx[1] := eDx[1] + eDs1; eDx[2] := eDx[2] + eDs2; eDx[3] := eDx[3] + eDs3; END END; END; END Distribute_eDbar; PROCEDURE AddTetrahedronPairEnergy(i, j: CARDINAL) = (* Adds to "e" the electric potential energy between the tetrahedrons "quad[i]" and "quad[j]", from "bar[i], "bar[j]", "rsq[i]", and "rsq[j]". Assumes "i # j". Also adds to "eDrsq[i]", "eDrsq[j]", "eDbar[i]" and "eDbar[j]" the corresponding derivatives, if the tetrahedrons are variable. *) BEGIN WITH bi = bar[i], bj = bar[j], eDbi = eDbar[i], eDbj = eDbar[j], si = rsq[i], sj = rsq[j], eDsi = eDrsq[i], eDsj = eDrsq[j], vij = LR4.Sub(bj, bi), s = si + sj, r2 = LR4.NormSqr(vij) + fuzz2 * s, r = Math.sqrt(r2), a = K/r DO e := e + a; IF grad THEN WITH aDr = - a/r, aDr2 = aDr * 0.5d0 / r, aDs = aDr2 * fuzz2, aDvij = LR4.Scale(2.0d0 * aDr2, vij) DO IF pVar[i] THEN eDsi := eDsi + aDs; eDbi := LR4.Sub(eDbi, aDvij) END; IF pVar[j] THEN eDsj := eDsj + aDs; eDbj := LR4.Add(eDbj, aDvij) END END END END; END AddTetrahedronPairEnergy; BEGIN (* Compute baricenters and 'radius squared' of quad[i], clear derivatives: *) FOR i := 0 TO NT-1 DO bar[i] := Compute_bar(quad[i]); rsq[i] := Compute_rsq(quad[i]); IF grad THEN eDbar[i] := LR4.T{0.0d0, 0.0d0, 0.0d0, 0.0d0}; eDrsq[i] := 0.0d0; END END; (* Compute energies and the internal derivatives "eDrsq", "eDbar": *) e := 0.0d0; FOR i := 0 TO NT-1 DO IF pVar[i] THEN FOR j := 0 TO NT-1 DO IF i # j AND (NOT pVar[j] OR i < j) THEN AddTetrahedronPairEnergy(i, j) END END END END; (* Distribute "eDrsq", "eDbar" onto "eDc": *) FOR i := 0 TO NV-1 DO eDc[i] := LR4.T{0.0d0, 0.0d0, 0.0d0, 0.0d0} END; IF grad THEN FOR i := 0 TO NT-1 DO IF pVar[i] THEN Distribute_eDbar(quad[i], eDbar[i]); Distribute_eDrsq(quad[i], eDrsq[i]); END END END END END END Eval; PROCEDURE Name(erg: T): TEXT = BEGIN RETURN "Elect(fuzz := " & Fmt.Real(erg.fuzz, prec := 3) & ")" END Name; BEGIN END ProxTetraEnergy. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/QuadEdge.m3 MODULE QuadEdge; IMPORT Octf, Stdio, Wr, Thread; FROM Octf IMPORT Fnext, Spin, Clock, Enext_1, SpliceEdges, SpliceFacets, MakeFacetEdge; (* ================= Function's QuadEdge ========= *) PROCEDURE Flip(s : Arc) : Arc = BEGIN IF s.d = 0 THEN RETURN Arc{pair := Spin(Fnext(s.pair)), d := 0}; ELSE RETURN Arc{pair := Clock(Spin(s.pair)), d := 1}; END; END Flip; PROCEDURE Sym(s : Arc): Arc = BEGIN IF s.d = 0 THEN RETURN Arc{pair := Clock(Fnext(s.pair)), d := 0}; ELSE RETURN Arc{pair := Clock(Fnext(s.pair)), d := 1}; END; END Sym; PROCEDURE Sym_(s : Arc): Arc = BEGIN IF s.d = 0 THEN RETURN Arc{pair := Fnext(s.pair), d := 0}; ELSE RETURN Arc{pair := Fnext(s.pair), d := 1}; END; END Sym_; PROCEDURE Onext(s : Arc): Arc = BEGIN IF s.d = 0 THEN RETURN Arc{pair := Clock(Fnext(Enext_1(s.pair))), d := 0}; ELSE RETURN Arc{pair := Enext_1(s.pair), d := 1}; END; END Onext; PROCEDURE Dual(s : Arc): Arc = BEGIN RETURN Arc{pair := s.pair, d := 1-s.d}; END Dual; PROCEDURE Rot(s : Arc): Arc = BEGIN RETURN Dual(Flip(s)); END Rot; PROCEDURE Oprev(s : Arc): Arc = BEGIN RETURN Rot(Onext(Rot(s))); END Oprev; PROCEDURE Lnext(s : Arc): Arc = BEGIN RETURN Oprev(Sym(s)); END Lnext; PROCEDURE Rprev(s : Arc): Arc = BEGIN RETURN Onext(Sym(s)); END Rprev; (* =================== Operator's QuadEdge ========== *) VAR FacetEdgeCount : CARDINAL := 1; PROCEDURE MakeEdge() : Arc = <* FATAL Wr.Failure, Thread.Alerted *> VAR a,b: Pair; BEGIN a := MakeFacetEdge(); a.facetedge.num := FacetEdgeCount; INC(FacetEdgeCount); (*Octf.PrintPair(Stdio.stdout, a); Wr.PutText(Stdio.stdout, "\n"); *) b := MakeFacetEdge(); (*b.facetedge.num := FacetEdgeCount; INC(FacetEdgeCount); Octf.PrintPair(Stdio.stdout, b); Wr.PutText(Stdio.stdout, "\n"); *) SpliceFacets(a, b); SpliceEdges(a, Clock(b)); RETURN Arc{pair := a, d := 0}; END MakeEdge; PROCEDURE MakeLoop() : Arc = <* FATAL Wr.Failure, Thread.Alerted *> VAR a,b: Pair; BEGIN a := MakeFacetEdge(); a.facetedge.num := FacetEdgeCount; INC(FacetEdgeCount); Octf.PrintPair(Stdio.stdout, a); Wr.PutText(Stdio.stdout, "\n"); b := MakeFacetEdge(); b.facetedge.num := FacetEdgeCount; INC(FacetEdgeCount); Octf.PrintPair(Stdio.stdout, b); Wr.PutText(Stdio.stdout, "\n"); SpliceFacets(a, b); RETURN Arc{pair := a, d := 0}; END MakeLoop; PROCEDURE Splice(s1,s2 : Arc) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN IF (s1.d = 0 AND s2.d = 0) THEN Octf.PrintPair(Stdio.stdout, Spin(Clock(s1.pair)),1); Wr.PutText(Stdio.stdout, "\n"); Octf.PrintPair(Stdio.stdout, Spin(Clock(s2.pair)),1); Wr.PutText(Stdio.stdout, "\n"); SpliceEdges(Spin(Clock(s1.pair)), Spin(Clock(s2.pair))); ELSE SpliceEdges(Enext_1(s1.pair), Enext_1(s2.pair)); END; END Splice; PROCEDURE Splice_(s1,s2 : Arc) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN IF (s1.d = 0 AND s2.d = 0) THEN Octf.PrintPair(Stdio.stdout, Spin(Clock(s1.pair)),10); Wr.PutText(Stdio.stdout, "\n"); Octf.PrintPair(Stdio.stdout, Spin(Clock(s2.pair)),10); Wr.PutText(Stdio.stdout, "\n"); SpliceEdges(Spin(Clock(s1.pair)), Spin(Clock(s2.pair))); ELSE SpliceEdges(Enext_1(s1.pair), Enext_1(s2.pair)); END; END Splice_; BEGIN END QuadEdge. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Refine.m3 MODULE Refine; (* This interface contain essentially procedures for support the programs of refiment of tetrahedra. *) IMPORT Triangulation, Octf, Squared, R3, Wr, Stdio, Thread; FROM Stdio IMPORT stderr; FROM Triangulation IMPORT Pair, Glue, MakeTetraTopo, OrgV, MakeFacetEdge, MakeVertex, SetOrg, Vertex; FROM Octf IMPORT Clock, Enext, Enext_1, Spin, SetEnext, SetFace, SetFnext, SetEdgeAll, Onext, Fnext; PROCEDURE MakeTetra(order: CARDINAL; net: BOOLEAN := FALSE) : Corner = VAR c : Corner; BEGIN CASE order OF | 1 => RETURN MakeTetra1(net); | 2 => RETURN MakeTetra2(net); | 3 => RETURN MakeTetra3(net); | 4 => RETURN MakeTetra4(net); | 5 => RETURN MakeTetra5(net); ELSE RETURN c; END END MakeTetra; PROCEDURE MakeTriang(order: CARDINAL): REF ARRAY OF TRI = VAR t : REF ARRAY OF TRI; BEGIN CASE order OF | 1 => RETURN MakeTriang1(); | 2 => RETURN MakeTriang2(); | 3 => RETURN MakeTriang3(); | 4 => RETURN MakeTriang4(); | 5 => RETURN MakeTriang5(); ELSE RETURN t; END END MakeTriang; PROCEDURE MakeLevTe(order: CARDINAL) : Pack = VAR p : Pack; BEGIN CASE order OF | 1 => RETURN MakeLevTe1(); | 2 => RETURN MakeLevTe2(); | 3 => RETURN MakeLevTe3(); | 4 => RETURN MakeLevTe4(); | 5 => RETURN MakeLevTe5(); ELSE RETURN p; END END MakeLevTe; PROCEDURE MakeRowTe(order: CARDINAL) : Free = VAR f : Free; BEGIN CASE order OF | 1 => RETURN MakeRowTe1(); | 2 => RETURN MakeRowTe2(); | 3 => RETURN MakeRowTe3(); | 4 => RETURN MakeRowTe4(); | 5 => RETURN MakeRowTe5(); ELSE RETURN f; END END MakeRowTe; PROCEDURE MakeRowTriang(order: CARDINAL) : REF ARRAY OF TRI = VAR t : REF ARRAY OF TRI; BEGIN CASE order OF | 1 => RETURN MakeRowTriang1(); | 2 => RETURN MakeRowTriang2(); | 3 => RETURN MakeRowTriang3(); | 4 => RETURN MakeRowTriang4(); | 5 => RETURN MakeRowTriang5(); ELSE RETURN t; END END MakeRowTriang; PROCEDURE MakeGluea(order: CARDINAL) : Pair = BEGIN CASE order OF | 1 => RETURN GlueRefineTetra(0,1,1); | 2 => RETURN GlueRefineTetra(0,1,2); | 3 => RETURN GlueRefineTetra(0,1,3); | 4 => RETURN GlueRefineTetra(0,1,4); | 5 => RETURN GlueRefineTetra(0,1,5); ELSE RETURN Triangulation.MakeFacetEdge(); END END MakeGluea; PROCEDURE MakeGlueb(order: CARDINAL) : Pair = BEGIN CASE order OF | 1 => RETURN GlueRefineTetra(1,0,1); | 2 => RETURN GlueRefineTetra(1,0,2); | 3 => RETURN GlueRefineTetra(1,0,3); | 4 => RETURN GlueRefineTetra(1,0,4); | 5 => RETURN GlueRefineTetra(1,0,5); ELSE RETURN Triangulation.MakeFacetEdge(); END END MakeGlueb; PROCEDURE MakeGluec(order: CARDINAL) : Pair = BEGIN CASE order OF | 1 => RETURN GlueRefineTetra(3,2,1); | 2 => RETURN GlueRefineTetra(3,2,2); | 3 => RETURN GlueRefineTetra(3,2,3); | 4 => RETURN GlueRefineTetra(3,2,4); | 5 => RETURN GlueRefineTetra(3,2,5); ELSE RETURN Triangulation.MakeFacetEdge(); END END MakeGluec; PROCEDURE MakeGlued(order: CARDINAL) : Pair = BEGIN CASE order OF | 1 => RETURN GlueRefineTetra(2,3,1); | 2 => RETURN GlueRefineTetra(2,3,2); | 3 => RETURN GlueRefineTetra(2,3,3); | 4 => RETURN GlueRefineTetra(2,3,4); | 5 => RETURN GlueRefineTetra(2,3,5); ELSE RETURN Triangulation.MakeFacetEdge(); END END MakeGlued; PROCEDURE MakeTetra1(net: BOOLEAN := FALSE) : Corner = VAR c : Corner; BEGIN c.right := NEW(REF PAIR,1); c.left := NEW(REF PAIR,1); c.front := NEW(REF PAIR,1); c.back := NEW(REF PAIR,1); WITH a = MakeLevTe1() DO c.right[0] := a.corner.right[0]; c.left [0] := a.corner.left [0]; c.front[0] := a.corner.front[0]; c.back [0] := a.corner.back [0]; (* new extensions *) SetLackVertices(1,c); IF net THEN SetGrade(1,c) END; RETURN c; END END MakeTetra1; PROCEDURE MakeTetra2(net: BOOLEAN := FALSE) : Corner = VAR c : Corner; BEGIN c.right := NEW(REF PAIR,4); c.left := NEW(REF PAIR,4); c.front := NEW(REF PAIR,4); c.back := NEW(REF PAIR,4); WITH a = MakeTetra1(), b = MakeLevTe2() DO EVAL Glue(Spin(b.side.upper[0]), a.back[0],1); HideFace (b.side.upper[0]); FOR j := 0 TO 3 DO c.back[j] := b.corner.back[j]; END; c.right[0] := a.right[0]; c.left [0] := a.left [0]; c.front[0] := a.front[0]; FOR i := 1 TO 3 DO c.right[i] := b.corner.right[i-1]; c.left [i] := b.corner.left [i-1]; c.front[i] := b.corner.front[i-1]; END; (* new extensions *) SetLackVertices(2,c); IF net THEN SetGrade(2,c) END; RETURN c; END END MakeTetra2; PROCEDURE MakeTetra3(net: BOOLEAN := FALSE) : Corner = VAR d : Corner; BEGIN d.right := NEW(REF PAIR,9); d.left := NEW(REF PAIR,9); d.front := NEW(REF PAIR,9); d.back := NEW(REF PAIR,9); WITH a = MakeTetra2(), c = MakeLevTe3() DO (* Tetra-2 with Level-3: a.back[0]=T with c.upper[0]=O a.back[1]=T with c.upper[1]=O a.back[2]=O with c.upper[2]=T a.back[3]=T with c.upper[3]=O *) <* ASSERT NUMBER(a.back^) = NUMBER(c.side.upper^) *> EVAL Glue(Spin (a.back[0]), c.side.upper[0], 1, TRUE); HideFace (a.back[0]); EVAL Glue(Spin (a.back[1]), c.side.upper[1], 1, TRUE); HideFace (a.back[1]); EVAL Glue(Clock(a.back[2]), c.side.upper[2], 1, TRUE); HideFace (a.back[2]); EVAL Glue(Spin (a.back[3]), c.side.upper[3], 1, TRUE); HideFace (a.back[3]); FOR j := 0 TO 8 DO d.back[j] := c.corner.back[j]; END; FOR i := 0 TO 3 DO d.right[i] := a.right[i]; d.left [i] := a.left [i]; d.front[i] := a.front[i]; END; FOR i := 4 TO 8 DO d.right[i] := c.corner.right[i-4]; d.left [i] := c.corner.left [i-4]; d.front[i] := c.corner.front[i-4]; END; (* new extensions *) SetLackVertices(3,d); IF net THEN SetGrade(3,d) END; RETURN d; END END MakeTetra3; PROCEDURE MakeTetra4(net: BOOLEAN := FALSE) : Corner = VAR e : Corner; BEGIN e.right := NEW(REF PAIR,16); e.left := NEW(REF PAIR,16); e.front := NEW(REF PAIR,16); e.back := NEW(REF PAIR,16); WITH a = MakeTetra3(), d = MakeLevTe4() DO (* gluing Tetra-3 with upper Level-4 *) <* ASSERT NUMBER(a.back^) = NUMBER(d.side.upper^) *> EVAL Glue(Spin (a.back[0]), d.side.upper[0], 1, TRUE); HideFace (a.back[0]); EVAL Glue(Spin (a.back[1]), d.side.upper[1], 1, TRUE); HideFace (a.back[1]); EVAL Glue(Clock(a.back[2]), d.side.upper[2], 1, TRUE); HideFace (a.back[2]); EVAL Glue(Spin (a.back[3]), d.side.upper[3], 1, TRUE); HideFace (a.back[3]); EVAL Glue(Spin (a.back[4]), d.side.upper[4], 1, TRUE); HideFace (a.back[4]); EVAL Glue(Clock(a.back[5]), d.side.upper[5], 1, TRUE); HideFace (a.back[5]); EVAL Glue(Spin (a.back[6]), d.side.upper[6], 1, TRUE); HideFace (a.back[6]); EVAL Glue(Clock(a.back[7]), d.side.upper[7], 1, TRUE); HideFace (a.back[7]); EVAL Glue(Spin (a.back[8]), d.side.upper[8], 1, TRUE); HideFace (a.back[8]); FOR j := 0 TO 15 DO e.back[j] := d.corner.back[j]; END; FOR i := 0 TO 8 DO e.right[i] := a.right[i]; e.left [i] := a.left [i]; e.front[i] := a.front[i]; END; FOR i := 9 TO 15 DO e.right[i] := d.corner.right[i-9]; e.left [i] := d.corner.left [i-9]; e.front[i] := d.corner.front[i-9]; END; (* new extensions *) SetLackVertices(4,e); IF net THEN SetGrade(4,e) END; RETURN e; END END MakeTetra4; PROCEDURE MakeTetra5(net: BOOLEAN := FALSE) : Corner = VAR f : Corner; BEGIN f.right := NEW(REF PAIR,25); f.left := NEW(REF PAIR,25); f.front := NEW(REF PAIR,25); f.back := NEW(REF PAIR,25); WITH a = MakeTetra4(), e = MakeLevTe5() DO (* gluing Tetra-4 with upper Level-5 *) <* ASSERT NUMBER(a.back^) = NUMBER(e.side.upper^) *> (* sixteen glues *) (* upper s.upper[0 ] := r2.octah[0,5]; s.upper[1 ] := r3.octah[0,5]; s.upper[2 ] := r3.tetra[3,2]; s.upper[3 ] := r3.octah[1,5]; s.upper[4 ] := r4.octah[0,5]; s.upper[5 ] := r4.tetra[5,2]; s.upper[6 ] := r4.octah[1,5]; s.upper[7 ] := r4.tetra[4,2]; s.upper[8 ] := r4.octah[2,5]; s.upper[9 ] := r5.octah[0,5]; s.upper[10] := r5.tetra[7,2]; s.upper[11] := r5.octah[1,5]; s.upper[12] := r5.tetra[5,2]; s.upper[13] := r5.octah[2,5]; s.upper[14] := r5.tetra[6,2]; s.upper[15] := r5.octah[3,5]; *) (* lower s.lower[0 ] := r1.tetra[0,2]; s.lower[1 ] := r2.tetra[0,2]; s.lower[2 ] := r2.octah[3,3]; s.lower[3 ] := r2.tetra[1,2]; s.lower[4 ] := r3.tetra[0,2]; s.lower[5 ] := r3.octah[5,3]; s.lower[6 ] := r3.tetra[1,2]; s.lower[7 ] := r3.octah[4,3]; s.lower[8 ] := r3.tetra[2,2]; s.lower[9 ] := r4.tetra[0,2]; s.lower[10] := r4.octah[0,3]; s.lower[11] := r4.tetra[1,2]; s.lower[12] := r4.octah[1,3]; s.lower[13] := r4.tetra[2,2]; s.lower[14] := r4.octah[2,3]; s.lower[15] := r4.tetra[3,2]; *) EVAL Glue(Spin(a.back[0]), e.side.upper[0], 1, TRUE); HideFace (a.back[0]); EVAL Glue(Spin(a.back[1]), e.side.upper[1], 1, TRUE); HideFace (a.back[1]); EVAL Glue(Clock(a.back[2]), e.side.upper[2], 1, TRUE); HideFace (a.back[2]); EVAL Glue(Spin(a.back[3]), e.side.upper[3], 1, TRUE); HideFace (a.back[3]); EVAL Glue(Spin(a.back[4]), e.side.upper[4], 1, TRUE); HideFace (a.back[4]); EVAL Glue(Clock(a.back[5]), e.side.upper[5], 1, TRUE); HideFace (a.back[5]); EVAL Glue(Spin(a.back[6]), e.side.upper[6], 1, TRUE); HideFace (a.back[6]); EVAL Glue(Clock(a.back[7]), e.side.upper[7], 1, TRUE); HideFace (a.back[7]); EVAL Glue(Spin(a.back[8]), e.side.upper[8], 1, TRUE); HideFace (a.back[8]); EVAL Glue(Spin(a.back[9]), e.side.upper[9], 1, TRUE); HideFace (a.back[9]); EVAL Glue(Clock(a.back[10]), e.side.upper[10], 1, TRUE); HideFace (a.back[10]); EVAL Glue(Spin(a.back[11]), e.side.upper[11], 1, TRUE); HideFace (a.back[11]); EVAL Glue(Clock(a.back[12]), e.side.upper[12], 1, TRUE); HideFace (a.back[12]); EVAL Glue(Spin(a.back[13]), e.side.upper[13], 1, TRUE); HideFace (a.back[13]); EVAL Glue(Clock(a.back[14]), e.side.upper[14], 1, TRUE); HideFace (a.back[14]); EVAL Glue(Spin(a.back[15]), e.side.upper[15], 1, TRUE); HideFace (a.back[15]); FOR j := 0 TO 24 DO f.back[j] := e.corner.back[j]; END; FOR i := 0 TO 15 DO f.right[i] := a.right[i]; f.left [i] := a.left [i]; f.front[i] := a.front[i]; END; FOR i := 16 TO 24 DO f.right[i] := e.corner.right[i-16]; f.left [i] := e.corner.left [i-16]; f.front[i] := e.corner.front[i-16]; END; (* new extensions *) SetLackVertices(5,f); IF net THEN SetGrade(5,f) END; RETURN f; END END MakeTetra5; (* Procedure for builds triangles *) PROCEDURE MakeTriang1() : REF ARRAY OF TRI = VAR r := NEW(REF ARRAY OF TRI, 1); BEGIN WITH t = MakeTriangle() DO r[0] := t; RETURN r; END END MakeTriang1; PROCEDURE MakeTriang2() : REF ARRAY OF TRI = VAR r := NEW(REF ARRAY OF TRI, 4); BEGIN WITH t = MakeTriang1(), p = MakeRowTriang2() DO SetFnext (t[0][0], Clock(p[1][0])); SetEdgeAll(t[0][0], t[0][0].facetedge.edge); SetOrgCycle(t[0][0], OrgV(t[0][0])); SetOrgCycle(Clock(t[0][0]), OrgV(Clock(t[0][0]))); FOR j := 0 TO 2 DO r[0][j] := t[0][j]; END; FOR k := 1 TO 3 DO FOR i := 0 TO 2 DO r[k][i] := p[k-1][i]; END END END; RETURN r; END MakeTriang2; PROCEDURE MakeTriang3() : REF ARRAY OF TRI = VAR r := NEW(REF ARRAY OF TRI, 9); BEGIN WITH t = MakeTriang2(), p = MakeRowTriang3() DO SetFnext (t[1][0], Clock(p[1][0])); SetFnext (t[3][0], Clock(p[3][0])); SetEdgeAll(t[1][0], t[1][0].facetedge.edge); SetEdgeAll(t[3][0], t[3][0].facetedge.edge); SetOrgCycle(t[1][0], OrgV(t[1][0])); SetOrgCycle(t[3][0], OrgV(t[3][0])); SetOrgCycle(Clock(t[3][0]), OrgV(Clock(t[3][0]))); FOR l := 0 TO 3 DO FOR j := 0 TO 2 DO r[l][j] := t[l][j]; END END; FOR k := 4 TO 8 DO FOR i := 0 TO 2 DO r[k][i] := p[k-4][i]; END END END; RETURN r; END MakeTriang3; PROCEDURE MakeTriang4() : REF ARRAY OF TRI = VAR r := NEW(REF ARRAY OF TRI, 16); BEGIN WITH t = MakeTriang3(), p = MakeRowTriang4() DO SetFnext (t[4][0], Clock(p[1][0])); SetFnext (t[6][0], Clock(p[3][0])); SetFnext (t[8][0], Clock(p[5][0])); SetEdgeAll(t[4][0], t[4][0].facetedge.edge); SetEdgeAll(t[6][0], t[6][0].facetedge.edge); SetEdgeAll(t[8][0], t[8][0].facetedge.edge); SetOrgCycle(t[4][0], OrgV(t[4][0])); SetOrgCycle(t[6][0], OrgV(t[6][0])); SetOrgCycle(t[8][0], OrgV(t[8][0])); SetOrgCycle(Clock(t[8][0]), OrgV(Clock(t[8][0]))); FOR l := 0 TO 8 DO FOR j := 0 TO 2 DO r[l][j] := t[l][j]; END END; FOR k := 9 TO 15 DO FOR i := 0 TO 2 DO r[k][i] := p[k-9][i]; END END END; RETURN r; END MakeTriang4; PROCEDURE MakeTriang5() : REF ARRAY OF TRI = VAR r := NEW(REF ARRAY OF TRI, 25); BEGIN WITH t = MakeTriang4(), p = MakeRowTriang5() DO SetFnext (t[9 ][0], Clock(p[1][0])); SetFnext (t[11][0], Clock(p[3][0])); SetFnext (t[13][0], Clock(p[5][0])); SetFnext (t[15][0], Clock(p[7][0])); SetEdgeAll(t[9 ][0], t[9 ][0].facetedge.edge); SetEdgeAll(t[11][0], t[11][0].facetedge.edge); SetEdgeAll(t[13][0], t[13][0].facetedge.edge); SetEdgeAll(t[15][0], t[15][0].facetedge.edge); SetOrgCycle(t[9 ][0], OrgV(t[9 ][0])); SetOrgCycle(t[11][0], OrgV(t[11][0])); SetOrgCycle(t[13][0], OrgV(t[13][0])); SetOrgCycle(t[15][0], OrgV(t[15][0])); SetOrgCycle(Clock(t[15][0]), OrgV(Clock(t[15][0]))); FOR l := 0 TO 15 DO FOR j := 0 TO 2 DO r[l][j] := t[l][j]; END END; FOR k := 16 TO 24 DO FOR i := 0 TO 2 DO r[k][i] := p[k-16][i]; END END END; RETURN r; END MakeTriang5; PROCEDURE MakeLevTe1() : Pack = VAR s : Side; c : Corner; BEGIN (* allocating memory *) s.lower := NEW(REF PAIR,1); c.right := NEW(REF PAIR,1); c.left := NEW(REF PAIR,1); c.front := NEW(REF PAIR,1); c.back := NEW(REF PAIR,1); WITH r1 = MakeRowTe1() DO (* computing side information *) s.lower[0] := r1.tetra[0,2]; (* computing corner information *) c.right[0] := r1.tetra[0,0]; c.left [0] := r1.tetra[0,1]; c.front[0] := r1.tetra[0,3]; FOR i := 0 TO 0 DO c.back [i] := s.lower[i]; END; RETURN Pack{s,c}; (* return the base of one tetrahedron /\ / \ /____\ *) END END MakeLevTe1; PROCEDURE MakeLevTe2() : Pack = VAR s : Side; c : Corner; BEGIN (* side *) s.upper := NEW(REF PAIR,1); s.lower := NEW(REF PAIR,4); (* corner *) c.right := NEW(REF PAIR,3); c.left := NEW(REF PAIR,3); c.front := NEW(REF PAIR,3); c.back := NEW(REF PAIR,4); WITH r1 = MakeRowTe1(), r2 = MakeRowTe2() DO EVAL Glue(Spin(r2.octah[0,7]), Clock(Spin(r1.tetra[0,3])),1); HideFace(r2.octah[0,7]); (* computing side information *) s.upper[0] := r2.octah[0,5]; s.lower[0] := r1.tetra[0,2]; s.lower[1] := r2.tetra[0,2]; s.lower[2] := r2.octah[0,3]; s.lower[3] := r2.tetra[1,2]; (* computing corner information *) c.right[0] := r1.tetra[0,0]; c.right[1] := r2.octah[0,6]; c.right[2] := r2.tetra[1,0]; c.left [0] := r1.tetra[0,1]; c.left [1] := r2.octah[0,4]; c.left [2] := r2.tetra[0,1]; c.front[0] := r2.tetra[0,3]; c.front[1] := r2.octah[0,1]; c.front[2] := r2.tetra[1,3]; FOR i := 0 TO 3 DO c.back [i] := s.lower[i]; END; RETURN Pack{s,c}; (* return a single upper triangular face of the level-2 that will be glue with the single lower triangular face of the level-1. /\ /\ / \ / \ / 0 \ / 0 \ /------\ ------ / \ 2 / \ / 1 \ / 3 \ /_____\/_____\ s.lower s.upper *) END END MakeLevTe2; PROCEDURE MakeLevTe3() : Pack = VAR s: Side; c: Corner; BEGIN (* side *) s.upper := NEW(REF PAIR,4); s.lower := NEW(REF PAIR,9); (* corner *) c.right := NEW(REF PAIR,5); c.left := NEW(REF PAIR,5); c.front := NEW(REF PAIR,5); c.back := NEW(REF PAIR,9); WITH r1 = MakeRowTe1(), r2 = MakeRowTe2(), r3 = MakeRowTe3() DO (* free pairs r3.tetra[3,3] => r2.octah[0,1] r3.octah[0,7] => r2.tetra[0,3] r3.octah[1,7] => r2.tetra[1,3] r2.octah[0,7] => r1.tetra[0,3] *) EVAL Glue(Spin (r3.tetra[3,3]), r2.octah[0,1], 1); HideFace (r3.tetra[3,3]); EVAL Glue(Clock(r3.octah[0,7]), r2.tetra[0,3], 1); HideFace (r3.octah[0,7]); EVAL Glue(Clock(r3.octah[1,7]), r2.tetra[1,3], 1); HideFace (r3.octah[1,7]); EVAL Glue(Clock(r2.octah[0,7]), r1.tetra[0,3], 1); HideFace (r2.octah[0,7]); (* computing side information *) (* upper *) s.upper[0] := r2.octah[0,5]; s.upper[1] := r3.octah[0,5]; s.upper[2] := r3.tetra[3,2]; s.upper[3] := r3.octah[1,5]; (* lower *) s.lower[0] := r1.tetra[0,2]; s.lower[1] := r2.tetra[0,2]; s.lower[2] := r2.octah[0,3]; s.lower[3] := r2.tetra[1,2]; s.lower[4] := r3.tetra[0,2]; s.lower[5] := r3.octah[0,3]; s.lower[6] := r3.tetra[1,2]; s.lower[7] := r3.octah[1,3]; s.lower[8] := r3.tetra[2,2]; (* computing corner information *) c.right[0] := r1.tetra[0,0]; c.right[1] := r2.octah[0,6]; c.right[2] := r2.tetra[1,0]; c.right[3] := r3.octah[1,6]; c.right[4] := r3.tetra[2,0]; c.left [0] := r1.tetra[0,1]; c.left [1] := r2.octah[0,4]; c.left [2] := r2.tetra[0,1]; c.left [3] := r3.octah[0,4]; c.left [4] := r3.tetra[0,1]; c.front[0] := r3.tetra[0,3]; c.front[1] := r3.octah[0,1]; c.front[2] := r3.tetra[1,3]; c.front[3] := r3.octah[1,1]; c.front[4] := r3.tetra[2,3]; FOR i := 0 TO 8 DO c.back [i] := s.lower[i]; END; RETURN Pack{s,c}; (* return an array of (four) upper triangular faces of the level three that will be glue with the (four) lower triangular faces of the level two. /\ /\ / \ / \ / 0 \ / 0 \ /------\ /------\ / \ 2 / \ / \ 2 / \ / 1 \ / 3 \ / 1 \ / 3 \ /_____\/_____\ /_____\/_____\ / 5 / \ 7 / \ / \ / \ / \ / 4 \/ 6 \/ 8 \ -------------------- s.upper s.lower *) END END MakeLevTe3; PROCEDURE MakeLevTe4() : Pack = VAR s: Side; c: Corner; BEGIN (* side *) s.upper := NEW(REF PAIR,9); s.lower := NEW(REF PAIR,16); (* corner *) c.right := NEW(REF PAIR,7); c.left := NEW(REF PAIR,7); c.front := NEW(REF PAIR,7); c.back := NEW(REF PAIR,16); WITH r1 = MakeRowTe1(), r2 = MakeRowTe2(), r3 = MakeRowTe3(), r4 = MakeRowTe4() DO (* r1 with r2 *) EVAL Glue(Clock(r2.octah[0,7]), r1.tetra[0,3], 1); HideFace (r2.octah[0,7]); (* free pairs r2 with r3 r3.tetra[3,3] => r2.octah[0,1] r3.octah[0,7] => r2.tetra[0,3] r3.octah[1,7] => r2.tetra[1,3] free pairs r2 with r1 r2.octah[0,7] => r1.tetra[0,3] *) (* r3 with r2 *) EVAL Glue(Spin (r3.tetra[3,3]), r2.octah[0,1], 1); HideFace (r3.tetra[3,3]); EVAL Glue(Clock(r3.octah[0,7]), r2.tetra[0,3], 1); HideFace (r3.octah[0,7]); EVAL Glue(Clock(r3.octah[1,7]), r2.tetra[1,3], 1); HideFace (r3.octah[1,7]); (* r4 with r3 *) (* free pairs r3 with r2 r4.octah[0,7] => r3.tetra[0,3] r4.tetra[5,3] => r3.octah[0,1] r4.octah[1,7] => r3.tetra[1,3] r4.tetra[1,3] => r3.octah[1,1] r4.octah[2,7] => r3.tetra[2,3] *) EVAL Glue(Spin (r4.tetra[5,3]), r3.octah[0,1], 1, TRUE); HideFace (r4.tetra[5,3]); EVAL Glue(Clock(r4.octah[0,7]), r3.tetra[0,3], 1, TRUE); HideFace (r4.octah[0,7]); EVAL Glue(Clock(r4.octah[1,7]), r3.tetra[1,3], 1, TRUE); HideFace (r4.octah[1,7]); EVAL Glue(Spin (r4.tetra[4,3]), r3.octah[1,1], 1, TRUE); HideFace (r4.tetra[4,3]); EVAL Glue(Clock(r4.octah[2,7]), r3.tetra[2,3], 1, TRUE); HideFace (r4.octah[2,7]); (* upper *) s.upper[0] := r2.octah[0,5]; s.upper[1] := r3.octah[0,5]; s.upper[2] := r3.tetra[3,2]; s.upper[3] := r3.octah[1,5]; s.upper[4] := r4.octah[0,5]; s.upper[5] := r4.tetra[5,2]; s.upper[6] := r4.octah[1,5]; s.upper[7] := r4.tetra[4,2]; s.upper[8] := r4.octah[2,5]; (* lower *) s.lower[0 ] := r1.tetra[0,2]; s.lower[1 ] := r2.tetra[0,2]; s.lower[2 ] := r2.octah[0,3]; s.lower[3 ] := r2.tetra[1,2]; s.lower[4 ] := r3.tetra[0,2]; s.lower[5 ] := r3.octah[0,3]; s.lower[6 ] := r3.tetra[1,2]; s.lower[7 ] := r3.octah[1,3]; s.lower[8 ] := r3.tetra[2,2]; s.lower[9 ] := r4.tetra[0,2]; s.lower[10] := r4.octah[0,3]; s.lower[11] := r4.tetra[1,2]; s.lower[12] := r4.octah[1,3]; s.lower[13] := r4.tetra[2,2]; s.lower[14] := r4.octah[2,3]; s.lower[15] := r4.tetra[3,2]; (* computing corner information *) c.right[0] := r1.tetra[0,0]; c.right[1] := r2.octah[0,6]; c.right[2] := r2.tetra[1,0]; c.right[3] := r3.octah[1,6]; c.right[4] := r3.tetra[2,0]; c.right[5] := r4.octah[2,6]; c.right[6] := r4.tetra[3,0]; c.left [0] := r1.tetra[0,1]; c.left [1] := r2.octah[0,4]; c.left [2] := r2.tetra[0,1]; c.left [3] := r3.octah[0,4]; c.left [4] := r3.tetra[0,1]; c.left [5] := r4.octah[0,4]; c.left [6] := r4.tetra[0,1]; c.front[0] := r4.tetra[0,3]; c.front[1] := r4.octah[0,1]; c.front[2] := r4.tetra[1,3]; c.front[3] := r4.octah[1,1]; c.front[4] := r4.tetra[2,3]; c.front[5] := r4.octah[2,1]; c.front[6] := r4.tetra[3,3]; FOR i := 0 TO 15 DO c.back [i] := s.lower[i]; END; RETURN Pack{s,c}; (* return an array of (nine) upper triangular faces of the level three that will be glue with the (nine) lower triangular faces of the level three. /\ /\ / \ / \ / 0 \ / 0 \ /------\ /------\ / \ 2 / \ / \ 2 / \ / 1 \ / 3 \ / 1 \ / 3 \ /_____\/_____\ /_____\/_____\ /\ 5 / \ 7 / \ / 5 / \ 7 / \ / \ / \ / \ / \ / \ / \ / 4 \/ 6 \/ 8 \ / 4 \/ 6 \/ 8 \ /--------------------\ --------------------- / \ 10 /\ 12 /\ 14 / \ / \ / \ / \ / \ / 9 \/ 11 \ / 13 \/ 15 \ ---------------------------- s.lower s.upper *) END END MakeLevTe4; PROCEDURE MakeLevTe5() : Pack = VAR s: Side; c: Corner; BEGIN (* side *) s.upper := NEW(REF PAIR,16); s.lower := NEW(REF PAIR,25); (* corner *) c.right := NEW(REF PAIR,9); c.left := NEW(REF PAIR,9); c.front := NEW(REF PAIR,9); c.back := NEW(REF PAIR,25); WITH r1 = MakeRowTe1(), r2 = MakeRowTe2(), r3 = MakeRowTe3(), r4 = MakeRowTe4(), r5 = MakeRowTe5() DO (* r1 with r2 *) EVAL Glue(Clock(r2.octah[0,7]), r1.tetra[0,3], 1); HideFace (r2.octah[0,7]); (* free pairs r2 with r3 r3.tetra[3,3] => r2.octah[0,1] r3.octah[0,7] => r2.tetra[0,3] r3.octah[1,7] => r2.tetra[1,3] free pairs r2 with r1 r2.octah[0,7] => r1.tetra[0,3] *) (* r3 with r2 *) EVAL Glue(Spin (r3.tetra[3,3]), r2.octah[0,1], 1); HideFace (r3.tetra[3,3]); EVAL Glue(Clock(r3.octah[0,7]), r2.tetra[0,3], 1); HideFace (r3.octah[0,7]); EVAL Glue(Clock(r3.octah[1,7]), r2.tetra[1,3], 1); HideFace (r3.octah[1,7]); (* r4 with r3 *) (* free pairs r3 with r2 r4.octah[0,7] => r3.tetra[0,3] r4.tetra[5,3] => r3.octah[0,1] r4.octah[1,7] => r3.tetra[1,3] r4.tetra[1,3] => r3.octah[1,1] r4.octah[2,7] => r3.tetra[2,3] *) EVAL Glue(Spin (r4.tetra[5,3]), r3.octah[0,1], 1, TRUE); HideFace (r4.tetra[5,3]); EVAL Glue(Clock(r4.octah[0,7]), r3.tetra[0,3], 1, TRUE); HideFace (r4.octah[0,7]); EVAL Glue(Clock(r4.octah[1,7]), r3.tetra[1,3], 1, TRUE); HideFace (r4.octah[1,7]); EVAL Glue(Spin (r4.tetra[4,3]), r3.octah[1,1], 1, TRUE); HideFace (r4.tetra[4,3]); EVAL Glue(Clock(r4.octah[2,7]), r3.tetra[2,3], 1, TRUE); HideFace (r4.octah[2,7]); (* r4 with r5 *) EVAL Glue(Spin (r5.tetra[7,3]), r4.octah[0,1], 1, TRUE); HideFace (r5.tetra[7,3]); EVAL Glue(Spin (r5.tetra[5,3]), r4.octah[1,1], 1, TRUE); HideFace (r5.tetra[5,3]); EVAL Glue(Clock(r5.octah[0,7]), r4.tetra[0,3], 1, TRUE); HideFace (r5.octah[0,7]); EVAL Glue(Clock(r5.octah[1,7]), r4.tetra[1,3], 1, TRUE); HideFace (r5.octah[1,7]); EVAL Glue(Spin (r5.tetra[6,3]), r4.octah[2,1], 1, TRUE); HideFace (r5.tetra[6,3]); EVAL Glue(Clock(r5.octah[2,7]), r4.tetra[2,3], 1, TRUE); HideFace (r5.octah[2,7]); EVAL Glue(Clock(r5.octah[3,7]), r4.tetra[3,3], 1, TRUE); HideFace (r5.octah[3,7]); (* computing corner information *) (* upper *) s.upper[0 ] := r2.octah[0,5]; s.upper[1 ] := r3.octah[0,5]; s.upper[2 ] := r3.tetra[3,2]; s.upper[3 ] := r3.octah[1,5]; s.upper[4 ] := r4.octah[0,5]; s.upper[5 ] := r4.tetra[5,2]; s.upper[6 ] := r4.octah[1,5]; s.upper[7 ] := r4.tetra[4,2]; s.upper[8 ] := r4.octah[2,5]; s.upper[9 ] := r5.octah[0,5]; s.upper[10] := r5.tetra[7,2]; s.upper[11] := r5.octah[1,5]; s.upper[12] := r5.tetra[5,2]; s.upper[13] := r5.octah[2,5]; s.upper[14] := r5.tetra[6,2]; s.upper[15] := r5.octah[3,5]; (* lower *) s.lower[0 ] := r1.tetra[0,2]; s.lower[1 ] := r2.tetra[0,2]; s.lower[2 ] := r2.octah[0,3]; s.lower[3 ] := r2.tetra[1,2]; s.lower[4 ] := r3.tetra[0,2]; s.lower[5 ] := r3.octah[0,3]; s.lower[6 ] := r3.tetra[1,2]; s.lower[7 ] := r3.octah[1,3]; s.lower[8 ] := r3.tetra[2,2]; s.lower[9 ] := r4.tetra[0,2]; s.lower[10] := r4.octah[0,3]; s.lower[11] := r4.tetra[1,2]; s.lower[12] := r4.octah[1,3]; s.lower[13] := r4.tetra[2,2]; s.lower[14] := r4.octah[2,3]; s.lower[15] := r4.tetra[3,2]; s.lower[16] := r5.tetra[0,2]; s.lower[17] := r5.octah[0,3]; s.lower[18] := r5.tetra[1,2]; s.lower[19] := r5.octah[1,3]; s.lower[20] := r5.tetra[2,2]; s.lower[21] := r5.octah[2,3]; s.lower[22] := r5.tetra[3,2]; s.lower[23] := r5.octah[3,3]; s.lower[24] := r5.tetra[4,2]; (* computing corner information *) c.right[0] := r1.tetra[0,0]; c.right[1] := r2.octah[0,6]; c.right[2] := r2.tetra[1,0]; c.right[3] := r3.octah[1,6]; c.right[4] := r3.tetra[2,0]; c.right[5] := r4.octah[2,6]; c.right[6] := r4.tetra[3,0]; c.right[7] := r5.octah[3,6]; c.right[8] := r5.tetra[4,0]; c.left [0] := r1.tetra[0,1]; c.left [1] := r2.octah[0,4]; c.left [2] := r2.tetra[0,1]; c.left [3] := r3.octah[0,4]; c.left [4] := r3.tetra[0,1]; c.left [5] := r4.octah[0,4]; c.left [6] := r4.tetra[0,1]; c.left [7] := r5.octah[0,4]; c.left [8] := r5.tetra[0,1]; c.front[0] := r5.tetra[0,3]; c.front[1] := r5.octah[0,1]; c.front[2] := r5.tetra[1,3]; c.front[3] := r5.octah[1,1]; c.front[4] := r5.tetra[2,3]; c.front[5] := r5.octah[2,1]; c.front[6] := r5.tetra[3,3]; c.front[7] := r5.octah[3,1]; c.front[8] := r5.tetra[4,3]; FOR i := 0 TO 24 DO c.back [i] := s.lower[i]; END; RETURN Pack{s,c}; (* return an array of (sixteen) upper triangular faces of the level three that will be glue with the (sixteen) lower triangular faces of the level four. /\ /\ / \ / \ / 0 \ / 0 \ /------\ /------\ / \ 2 / \ / \ 2 / \ / 1 \ / 3 \ / 1 \ / 3 \ /_____\/_____\ /_____\/_____\ /\ 5 / \ 7 / \ / 5 / \ 7 / \ / \ / \ / \ / \ / \ / \ / 4 \/ 6 \/ 8 \ / 4 \/ 6 \/ 8 \ --------------------\ --------------------- / \ 10 /\ 12 /\ 14 / \ / \ / \ / \ / \ / 9 \/ 11 \ / 13 \/ 15 \ ---------------------------- s.upper s.upper *) END END MakeLevTe5; PROCEDURE MakeRowTe1() : Free = VAR f : Free; BEGIN f.tetra := NEW(REF ARRAY OF PAIR,1,4); WITH t = MakeTetraTopo(1,1) DO FOR i := 0 TO 3 DO f.tetra[0,i] := t[i]; END; RETURN f; (* return one triangular *) END END MakeRowTe1; PROCEDURE MakeRowTe2() : Free = VAR f : Free; BEGIN f.tetra := NEW(REF ARRAY OF PAIR,2,4); f.octah := NEW(REF ARRAY OF PAIR,1,8); WITH p = GlueTetraOctah(), t = MakeTetraTopo(1,1) DO EVAL Glue(Clock(p.octah[0,2]), t[1], 1); HideFace(p.octah[0,2]); FOR i := 0 TO 3 DO f.tetra[0,i] := p.tetra[0,i]; END; FOR i := 0 TO 3 DO f.tetra[1,i] := t[i]; END; FOR i := 0 TO 7 DO f.octah[0,i] := p.octah[0,i]; END; RETURN f; END END MakeRowTe2; PROCEDURE GlueTetraOctah() : Free = VAR f : Free ; BEGIN f.tetra := NEW(REF ARRAY OF PAIR,1,4); f.octah := NEW(REF ARRAY OF PAIR,1,8); WITH t = MakeTetraTopo(1,1), o = Squared.MakeOctahedronTriang(TRUE) DO EVAL Glue(Spin(o[0]), t[0], 1); HideFace(o[0]); FOR i := 0 TO 3 DO f.tetra[0,i] := t[i]; END; FOR j := 0 TO 7 DO f.octah[0,j] := o[j]; END; RETURN f; END; END GlueTetraOctah; PROCEDURE MakeRowTe3() : Free = VAR f : Free; BEGIN f.tetra := NEW(REF ARRAY OF PAIR,4,4); f.octah := NEW(REF ARRAY OF PAIR,2,8); WITH r2 = MakeRowTe2(), r1 = GlueTetraOctah(), t = MakeTetraTopo(1,1) DO (* free pairs: r1.octah [0,2] and t[0] r2.tetra[0,1] and r2.octah[0,4] *) EVAL Glue(Spin(r2.octah[0,4]) , Clock(Spin(t[0])), 1); HideFace(r2.octah[0,4]); EVAL Glue(Spin(t[1]) , r1.octah[0,6], 1); HideFace(t[1]); EVAL Glue(Clock(r1.octah[0,2]), r2.tetra[0,1], 1); HideFace(r1.octah[0,2]); FOR i := 0 TO 3 DO f.tetra[0,i] := r1.tetra[0,i]; f.tetra[1,i] := r2.tetra[0,i]; f.tetra[2,i] := r2.tetra[1,i]; f.tetra[3,i] := t[i]; END; FOR i := 0 TO 7 DO f.octah[0,i] := r1.octah[0,i]; f.octah[1,i] := r2.octah[0,i]; END; RETURN f; END END MakeRowTe3; PROCEDURE MakeRowTe4() : Free = VAR f : Free; BEGIN f.tetra := NEW(REF ARRAY OF PAIR,6,4); f.octah := NEW(REF ARRAY OF PAIR,3,8); WITH r3 = MakeRowTe3(), r1 = GlueTetraOctah(), t = MakeTetraTopo(1,1) DO (* free pairs: r1.octah[0,2] and t[0] r3.tetra[0,1] and r3.octah[0,4] *) EVAL Glue(Spin(r3.octah[0,4]) , Spin(Clock(t[0])), 1); HideFace (r3.octah[0,4]); EVAL Glue(Spin(t[1]) , r1.octah[0,6], 1); HideFace (t[1]); EVAL Glue(Clock(r1.octah[0,2]), r3.tetra[0,1], 1); HideFace (r1.octah[0,2]); FOR i := 0 TO 3 DO f.tetra[0,i] := r1.tetra[0,i]; f.tetra[1,i] := r3.tetra[0,i]; f.tetra[2,i] := r3.tetra[1,i]; f.tetra[3,i] := r3.tetra[2,i]; f.tetra[4,i] := r3.tetra[3,i]; f.tetra[5,i] := t[i]; END; FOR i := 0 TO 7 DO f.octah[0,i] := r1.octah[0,i]; f.octah[1,i] := r3.octah[0,i]; f.octah[2,i] := r3.octah[1,i]; END; RETURN f; END END MakeRowTe4; PROCEDURE MakeRowTe5() : Free = VAR f : Free; BEGIN f.tetra := NEW(REF ARRAY OF PAIR,8,4); f.octah := NEW(REF ARRAY OF PAIR,5,8); WITH r3 = MakeRowTe4(), r1 = GlueTetraOctah(), t = MakeTetraTopo(1,1) DO (* free pairs: r1.octah[0,2] and t[0] r3.tetra[0,1] and r3.octah[0,4] *) EVAL Glue(Spin(r3.octah[0,4]) , Spin(Clock(t[0])),1); HideFace (r3.octah[0,4]); EVAL Glue(Spin(t[1]) , r1.octah[0,6], 1); HideFace (t[1]); EVAL Glue(Clock(r1.octah[0,2]), r3.tetra[0,1], 1); HideFace (r1.octah[0,2]); FOR i := 0 TO 3 DO f.tetra[0,i] := r1.tetra[0,i]; f.tetra[1,i] := r3.tetra[0,i]; f.tetra[2,i] := r3.tetra[1,i]; f.tetra[3,i] := r3.tetra[2,i]; f.tetra[4,i] := r3.tetra[3,i]; f.tetra[5,i] := r3.tetra[5,i]; f.tetra[6,i] := r3.tetra[4,i]; f.tetra[7,i] := t[i]; END; FOR i := 0 TO 7 DO f.octah[0,i] := r1.octah[0,i]; f.octah[1,i] := r3.octah[0,i]; f.octah[2,i] := r3.octah[1,i]; f.octah[3,i] := r3.octah[2,i]; END; RETURN f; END END MakeRowTe5; PROCEDURE MakeRowTriang1() : REF ARRAY OF TRI = VAR r := NEW(REF ARRAY OF TRI, 1); BEGIN WITH t = MakeTriangle() DO r[0] := t; RETURN r; END END MakeRowTriang1; PROCEDURE MakeRowTriang2() : REF ARRAY OF TRI = VAR r := NEW(REF ARRAY OF TRI, 3); BEGIN WITH p = GlueTwoTriang(), t = MakeRowTriang1() DO SetFnext (p[1][2], Clock(t[0][2])); SetEdgeAll(p[1][2], p[1][2].facetedge.edge); SetOrg(t[0][2], OrgV(Clock(p[1][2]))); SetOrg(Clock(t[0][2]), OrgV(p[1][2])); SetOrg(Clock(t[0][1]), OrgV(t[0][2])); SetOrg( t[0][0] , OrgV(Clock(t[0][2]))); FOR k := 0 TO 1 DO FOR i := 0 TO 2 DO r[k][i] := p[k][i]; END END; FOR j := 0 TO 2 DO r[2][j] := t[0][j]; END END; RETURN r; END MakeRowTriang2; PROCEDURE MakeRowTriang3() : REF ARRAY OF TRI = VAR r := NEW(REF ARRAY OF TRI, 5); BEGIN WITH p = GlueTwoTriang(), t = MakeRowTriang2() DO SetFnext (p[1][2], Clock(t[0][2])); SetEdgeAll(p[1][2], p[1][2].facetedge.edge); SetOrg(t[0][2], OrgV(Clock(p[1][2]))); SetOrg(Clock(t[0][2]), OrgV(p[1][2])); SetOrg( t[0][0] , OrgV(Clock(t[0][2]))); SetOrgCycle(Clock(t[0][1]), OrgV(t[0][2])); FOR k := 0 TO 1 DO FOR i := 0 TO 2 DO r[k][i] := p[k][i]; END END; FOR k := 2 TO 4 DO FOR j := 0 TO 2 DO r[k][j] := t[k-2][j]; END END END; RETURN r; END MakeRowTriang3; PROCEDURE MakeRowTriang4() : REF ARRAY OF TRI = VAR r := NEW(REF ARRAY OF TRI, 7); BEGIN WITH p = GlueTwoTriang(), t = MakeRowTriang3() DO SetFnext (p[1][2], Clock(t[0][2])); SetEdgeAll(p[1][2], p[1][2].facetedge.edge); SetOrg(t[0][2], OrgV(Clock(p[1][2]))); SetOrg(Clock(t[0][2]), OrgV(p[1][2])); SetOrg( t[0][0] , OrgV(Clock(t[0][2]))); SetOrgCycle(Clock(t[0][1]), OrgV(t[0][2])); FOR k := 0 TO 1 DO FOR i := 0 TO 2 DO r[k][i] := p[k][i]; END END; FOR k := 2 TO 6 DO FOR j := 0 TO 2 DO r[k][j] := t[k-2][j]; END END END; RETURN r; END MakeRowTriang4; PROCEDURE MakeRowTriang5() : REF ARRAY OF TRI = VAR r := NEW(REF ARRAY OF TRI, 9); BEGIN WITH p = GlueTwoTriang(), t = MakeRowTriang4() DO SetFnext (p[1][2], Clock(t[0][2])); SetEdgeAll(p[1][2], p[1][2].facetedge.edge); SetOrg(t[0][2], OrgV(Clock(p[1][2]))); SetOrg(Clock(t[0][2]), OrgV(p[1][2])); SetOrg( t[0][0] , OrgV(Clock(t[0][2]))); SetOrgCycle(Clock(t[0][1]), OrgV(t[0][2])); FOR k := 0 TO 1 DO FOR i := 0 TO 2 DO r[k][i] := p[k][i]; END END; FOR k := 2 TO 8 DO FOR j := 0 TO 2 DO r[k][j] := t[k-2][j]; END END END; RETURN r; END MakeRowTriang5; PROCEDURE GlueTwoTriang() : ARRAY [0..1] OF TRI = VAR p : ARRAY [0..1] OF TRI; BEGIN WITH t1 = MakeTriangle(), t2 = MakeTriangle() DO SetFnext(t1[1], Clock(t2[1])); SetEdgeAll(t1[1], t1[1].facetedge.edge); SetOrg(t2[1], OrgV(Clock(t1[1]))); SetOrg(Clock(t2[1]), OrgV(t1[1])); SetOrg(Clock(t2[0]), OrgV(t2[1])); SetOrg( t2[2], OrgV(Clock(t2[1]))); FOR i := 0 TO 2 DO p[0][i] := t1[i]; p[1][i] := t2[i]; END END; RETURN p; END GlueTwoTriang; PROCEDURE GlueRefineTetra( fa, fb: CARDINAL; order : CARDINAL; ) : Pair = BEGIN IF order = 1 THEN WITH ca = MakeTetra1(), cb = MakeTetra1() DO IF fa = 0 AND fb = 1 THEN (* must be glue ca.right <--> cb.left *) EVAL Glue(Spin(cb.left[0]), ca.right[0], 1); RETURN cb.left[0]; ELSIF fa = 1 AND fb = 0 THEN (* must be glue ca.left <--> cb.right *) EVAL Glue(Spin(ca.left[0]), cb.right[0], 1); RETURN ca.left[0]; ELSIF fa = 3 AND fb = 2 THEN (* must be glue ca.front <--> cb.back *) EVAL Glue(Spin(cb.back[0]), ca.front[0], 1); RETURN cb.back[0]; ELSIF fa = 2 AND fb = 3 THEN (* must be glue ca.back <--> cb.front *) EVAL Glue(Spin(cb.front[0]), ca.back[0], 1); RETURN cb.front[0]; END END; ELSIF order = 2 THEN WITH ca = MakeTetra2(), cb = MakeTetra2() DO IF fa = 0 AND fb = 1 THEN (* must be glue ca.right <--> cb.left *) EVAL Glue(Spin(cb.left[0]), ca.right[0], 1); FOR i := 1 TO 3 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (cb.left[i]), ca.right[i], 1); ELSE EVAL Glue(Spin (cb.left[i]), Spin(Clock(ca.right[i])), 1); END END; RETURN cb.left[0]; ELSIF fa = 1 AND fb = 0 THEN (* must be glue ca.left <--> cb.right *) EVAL Glue(Spin(ca.left[0]), cb.right[0], 1); FOR i := 1 TO 3 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (ca.left[i]), cb.right[i], 1); ELSE EVAL Glue(Spin (ca.left[i]), Spin(Clock(cb.right[i])), 1); END END; RETURN ca.left[0]; ELSIF fa = 3 AND fb = 2 THEN (* must be glue ca.front <--> cb.back *) EVAL Glue(Spin(cb.back[0]), ca.front[0], 1); FOR i := 1 TO 3 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (cb.back[i]), ca.front[i], 1); ELSE EVAL Glue(Clock(cb.back[i]), ca.front[i], 1); END END; RETURN cb.back[0]; ELSIF fa = 2 AND fb = 3 THEN (* must be glue ca.front <--> cb.back *) EVAL Glue(Spin(ca.back[0]), cb.front[0], 1); FOR i := 1 TO 3 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (ca.back[i]), cb.front[i], 1); ELSE EVAL Glue(Clock(ca.back[i]), cb.front[i], 1); END END; RETURN ca.back[0]; END END ELSIF order = 3 THEN WITH ca = MakeTetra3(), cb = MakeTetra3() DO IF fa = 0 AND fb = 1 THEN (* must be glue ca.right <--> cb.left *) EVAL Glue(Spin(cb.left[0]), ca.right[0], 1); FOR i := 1 TO 3 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (cb.left[i]), ca.right[i], 1); ELSE EVAL Glue(Spin (cb.left[i]), Spin(Clock(ca.right[i])), 1); END END; FOR i := 4 TO 8 DO IF i MOD 2 = 0 THEN EVAL Glue(Spin (cb.left[i]), ca.right[i], 1); ELSE EVAL Glue(Spin (cb.left[i]), Spin(Clock(ca.right[i])), 1); END END; RETURN cb.left[0]; ELSIF fa = 1 AND fb = 0 THEN (* must be glue ca.lef <--> cb.right *) EVAL Glue(Spin(ca.left[0]), cb.right[0], 1); FOR i := 1 TO 3 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (ca.left[i]), cb.right[i], 1); ELSE EVAL Glue(Spin (ca.left[i]), Spin(Clock(cb.right[i])), 1); END END; FOR i := 4 TO 8 DO IF i MOD 2 = 0 THEN EVAL Glue(Spin (ca.left[i]), cb.right[i], 1); ELSE EVAL Glue(Spin (ca.left[i]), Spin(Clock(cb.right[i])), 1); END END; RETURN ca.left[0]; ELSIF fa = 3 AND fb = 2 THEN (* must be glue ca.front <--> cb.back *) EVAL Glue(Spin (cb.back[0]), ca.front[0], 1); FOR i := 1 TO 3 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (cb.back[i]), ca.front[i], 1); ELSE EVAL Glue(Clock(cb.back[i]), ca.front[i], 1); END END; FOR i := 4 TO 8 DO IF i MOD 2 = 0 THEN EVAL Glue(Spin (cb.back[i]), ca.front[i], 1); ELSE EVAL Glue(Clock(cb.back[i]), ca.front[i], 1); END END; RETURN cb.back[0]; ELSIF fa = 2 AND fb = 3 THEN (* must be glue ca.back <--> cb.front *) EVAL Glue(Spin (ca.back[0]), cb.front[0], 1); FOR i := 1 TO 3 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (ca.back[i]), cb.front[i], 1); ELSE EVAL Glue(Clock(ca.back[i]), cb.front[i], 1); END END; FOR i := 4 TO 8 DO IF i MOD 2 = 0 THEN EVAL Glue(Spin (ca.back[i]), cb.front[i], 1); ELSE EVAL Glue(Clock(ca.back[i]), cb.front[i], 1); END END; RETURN ca.back[0]; END END ELSIF order = 4 THEN WITH ca = MakeTetra4(), cb = MakeTetra4() DO IF fa = 0 AND fb = 1 THEN (* must be glue ca.right <--> cb.left *) EVAL Glue(Spin(cb.left[0]), ca.right[0], 1); FOR i := 1 TO 3 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (cb.left[i]), ca.right[i], 1); ELSE EVAL Glue(Spin (cb.left[i]), Spin(Clock(ca.right[i])), 1); END END; FOR i := 4 TO 8 DO IF i MOD 2 = 0 THEN EVAL Glue(Spin (cb.left[i]), ca.right[i], 1); ELSE EVAL Glue(Spin (cb.left[i]), Spin(Clock(ca.right[i])), 1); END END; FOR i := 9 TO 15 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (cb.left[i]), ca.right[i], 1); ELSE EVAL Glue(Spin (cb.left[i]), Spin(Clock(ca.right[i])), 1); END END; RETURN cb.left[0]; ELSIF fa = 1 AND fb = 0 THEN (* must be glue cb.right <--> ca.left *) EVAL Glue(Spin(ca.left[0]), cb.right[0], 1); FOR i := 1 TO 3 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (ca.left[i]), cb.right[i], 1); ELSE EVAL Glue(Spin (ca.left[i]), Spin(Clock(cb.right[i])), 1); END END; FOR i := 4 TO 8 DO IF i MOD 2 = 0 THEN EVAL Glue(Spin (ca.left[i]), cb.right[i], 1); ELSE EVAL Glue(Spin (ca.left[i]), Spin(Clock(cb.right[i])), 1); END END; FOR i := 9 TO 15 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (ca.left[i]), cb.right[i], 1); ELSE EVAL Glue(Spin (ca.left[i]), Spin(Clock(cb.right[i])), 1); END END; RETURN ca.left[0]; ELSIF fa = 3 AND fb = 2 THEN (* must be glue ca.front <--> cb.back *) EVAL Glue(Spin (cb.back[0]), ca.front[0], 1); FOR i := 1 TO 3 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (cb.back[i]), ca.front[i], 1); ELSE EVAL Glue(Clock(cb.back[i]), ca.front[i], 1); END END; FOR i := 4 TO 8 DO IF i MOD 2 = 0 THEN EVAL Glue(Spin (cb.back[i]), ca.front[i], 1); ELSE EVAL Glue(Clock(cb.back[i]), ca.front[i], 1); END END; FOR i := 9 TO 15 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (cb.back[i]), ca.front[i], 1); ELSE EVAL Glue(Clock(cb.back[i]), ca.front[i], 1); END END; RETURN cb.back[0]; ELSIF fa = 2 AND fb = 3 THEN (* must be glue ca.back <--> cb.front *) EVAL Glue(Spin (ca.back[0]), cb.front[0], 1); FOR i := 1 TO 3 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (ca.back[i]), cb.front[i], 1); ELSE EVAL Glue(Clock(ca.back[i]), cb.front[i], 1); END END; FOR i := 4 TO 8 DO IF i MOD 2 = 0 THEN EVAL Glue(Spin (ca.back[i]), cb.front[i], 1); ELSE EVAL Glue(Clock(ca.back[i]), cb.front[i], 1); END END; FOR i := 9 TO 15 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (ca.back[i]), cb.front[i], 1); ELSE EVAL Glue(Clock(ca.back[i]), cb.front[i], 1); END END; RETURN ca.back[0]; END END ELSIF order = 5 THEN WITH ca = MakeTetra5(), cb = MakeTetra5() DO IF fa = 0 AND fb = 1 THEN (* must be glue ca.right <--> cb.left *) EVAL Glue(Spin(cb.left[0]), ca.right[0], 1); FOR i := 1 TO 3 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (cb.left[i]), ca.right[i], 1); ELSE EVAL Glue(Spin (cb.left[i]), Spin(Clock(ca.right[i])), 1); END END; FOR i := 4 TO 8 DO IF i MOD 2 = 0 THEN EVAL Glue(Spin (cb.left[i]), ca.right[i], 1); ELSE EVAL Glue(Spin (cb.left[i]), Spin(Clock(ca.right[i])), 1); END END; FOR i := 9 TO 15 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (cb.left[i]), ca.right[i], 1); ELSE EVAL Glue(Spin (cb.left[i]), Spin(Clock(ca.right[i])), 1); END END; FOR i := 16 TO 24 DO IF i MOD 2 = 0 THEN EVAL Glue(Spin (cb.left[i]), ca.right[i], 1); ELSE EVAL Glue(Spin (cb.left[i]), Spin(Clock(ca.right[i])), 1); END END; RETURN cb.left[0]; ELSIF fa = 1 AND fb = 0 THEN (* must be glue cb.right <--> ca.left *) EVAL Glue(Spin(ca.left[0]), cb.right[0], 1); FOR i := 1 TO 3 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (ca.left[i]), cb.right[i], 1); ELSE EVAL Glue(Spin (ca.left[i]), Spin(Clock(cb.right[i])), 1); END END; FOR i := 4 TO 8 DO IF i MOD 2 = 0 THEN EVAL Glue(Spin (ca.left[i]), cb.right[i], 1); ELSE EVAL Glue(Spin (ca.left[i]), Spin(Clock(cb.right[i])), 1); END END; FOR i := 9 TO 15 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (ca.left[i]), cb.right[i], 1); ELSE EVAL Glue(Spin (ca.left[i]), Spin(Clock(cb.right[i])), 1); END END; FOR i := 16 TO 24 DO IF i MOD 2 = 0 THEN EVAL Glue(Spin (ca.left[i]), cb.right[i], 1); ELSE EVAL Glue(Spin (ca.left[i]), Spin(Clock(cb.right[i])), 1); END END; RETURN ca.left[0]; ELSIF fa = 3 AND fb = 2 THEN (* must be glue ca.front <--> cb.back *) EVAL Glue(Spin (cb.back[0]), ca.front[0], 1); FOR i := 1 TO 3 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (cb.back[i]), ca.front[i], 1); ELSE EVAL Glue(Clock(cb.back[i]), ca.front[i], 1); END END; FOR i := 4 TO 8 DO IF i MOD 2 = 0 THEN EVAL Glue(Spin (cb.back[i]), ca.front[i], 1); ELSE EVAL Glue(Clock(cb.back[i]), ca.front[i], 1); END END; FOR i := 9 TO 15 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (cb.back[i]), ca.front[i], 1); ELSE EVAL Glue(Clock(cb.back[i]), ca.front[i], 1); END END; FOR i := 16 TO 24 DO IF i MOD 2 = 0 THEN EVAL Glue(Spin (cb.back[i]), ca.front[i], 1); ELSE EVAL Glue(Clock(cb.back[i]), ca.front[i], 1); END END; RETURN cb.back[0]; ELSIF fa = 2 AND fb = 3 THEN (* must be glue ca.back <--> cb.front *) EVAL Glue(Spin (ca.back[0]), cb.front[0], 1); FOR i := 1 TO 3 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (ca.back[i]), cb.front[i], 1); ELSE EVAL Glue(Clock(ca.back[i]), cb.front[i], 1); END END; FOR i := 4 TO 8 DO IF i MOD 2 = 0 THEN EVAL Glue(Spin (ca.back[i]), cb.front[i], 1); ELSE EVAL Glue(Clock(ca.back[i]), cb.front[i], 1); END END; FOR i := 9 TO 15 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (ca.back[i]), cb.front[i], 1); ELSE EVAL Glue(Clock(ca.back[i]), cb.front[i], 1); END END; FOR i := 16 TO 24 DO IF i MOD 2 = 0 THEN EVAL Glue(Spin (ca.back[i]), cb.front[i], 1); ELSE EVAL Glue(Clock(ca.back[i]), cb.front[i], 1); END END; RETURN ca.back[0]; END END END; RETURN Triangulation.MakeFacetEdge(); END GlueRefineTetra; PROCEDURE MakeMaximalGlue(order : CARDINAL) : Pair = BEGIN IF order = 1 THEN WITH ca = MakeTetra1(), cb = MakeTetra1() DO EVAL Glue(Spin(cb.left[0]), ca.right[0], 1); EVAL Glue(Spin(cb.front[0]), ca.back[0], 1); RETURN cb.front[0]; END; ELSIF order = 2 THEN WITH ca = MakeTetra2(), cb = MakeTetra2() DO EVAL Glue(Spin(cb.left[0]), ca.right[0], 1); FOR i := 1 TO 3 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (cb.left[i]), ca.right[i], 1); ELSE EVAL Glue(Spin (cb.left[i]), Spin(Clock(ca.right[i])), 1); END END; EVAL Glue(Spin(ca.back[0]), cb.front[0], 1); FOR i := 1 TO 3 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (ca.back[i]), cb.front[i], 1); ELSE EVAL Glue(Clock(ca.back[i]), cb.front[i], 1); END END; RETURN ca.back[0]; END ELSIF order = 3 THEN WITH ca = MakeTetra3(), cb = MakeTetra3() DO EVAL Glue(Spin(cb.left[0]), ca.right[0], 1); FOR i := 1 TO 3 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (cb.left[i]), ca.right[i], 1); ELSE EVAL Glue(Spin (cb.left[i]), Spin(Clock(ca.right[i])), 1); END END; FOR i := 4 TO 8 DO IF i MOD 2 = 0 THEN EVAL Glue(Spin (cb.left[i]), ca.right[i], 1); ELSE EVAL Glue(Spin (cb.left[i]), Spin(Clock(ca.right[i])), 1); END END; EVAL Glue(Spin (ca.back[0]), cb.front[0], 1); FOR i := 1 TO 3 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (ca.back[i]), cb.front[i], 1); ELSE EVAL Glue(Clock(ca.back[i]), cb.front[i], 1); END END; FOR i := 4 TO 8 DO IF i MOD 2 = 0 THEN EVAL Glue(Spin (ca.back[i]), cb.front[i], 1); ELSE EVAL Glue(Clock(ca.back[i]), cb.front[i], 1); END END; RETURN ca.back[0]; END; ELSIF order = 4 THEN WITH ca = MakeTetra4(), cb = MakeTetra4() DO EVAL Glue(Spin(cb.left[0]), ca.right[0], 1); FOR i := 1 TO 3 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (cb.left[i]), ca.right[i], 1); ELSE EVAL Glue(Spin (cb.left[i]), Spin(Clock(ca.right[i])), 1); END END; FOR i := 4 TO 8 DO IF i MOD 2 = 0 THEN EVAL Glue(Spin (cb.left[i]), ca.right[i], 1); ELSE EVAL Glue(Spin (cb.left[i]), Spin(Clock(ca.right[i])), 1); END END; FOR i := 9 TO 15 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (cb.left[i]), ca.right[i], 1); ELSE EVAL Glue(Spin (cb.left[i]), Spin(Clock(ca.right[i])), 1); END END; EVAL Glue(Spin (ca.back[0]), cb.front[0], 1); FOR i := 1 TO 3 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (ca.back[i]), cb.front[i], 1); ELSE EVAL Glue(Clock(ca.back[i]), cb.front[i], 1); END END; FOR i := 4 TO 8 DO IF i MOD 2 = 0 THEN EVAL Glue(Spin (ca.back[i]), cb.front[i], 1); ELSE EVAL Glue(Clock(ca.back[i]), cb.front[i], 1); END END; FOR i := 9 TO 15 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (ca.back[i]), cb.front[i], 1); ELSE EVAL Glue(Clock(ca.back[i]), cb.front[i], 1); END END; RETURN ca.back[0]; END; ELSIF order = 5 THEN WITH ca = MakeTetra5(), cb = MakeTetra5() DO EVAL Glue(Spin(cb.left[0]), ca.right[0], 1); FOR i := 1 TO 3 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (cb.left[i]), ca.right[i], 1); ELSE EVAL Glue(Spin (cb.left[i]), Spin(Clock(ca.right[i])), 1); END END; FOR i := 4 TO 8 DO IF i MOD 2 = 0 THEN EVAL Glue(Spin (cb.left[i]), ca.right[i], 1); ELSE EVAL Glue(Spin (cb.left[i]), Spin(Clock(ca.right[i])), 1); END END; FOR i := 9 TO 15 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (cb.left[i]), ca.right[i], 1); ELSE EVAL Glue(Spin (cb.left[i]), Spin(Clock(ca.right[i])), 1); END END; FOR i := 16 TO 24 DO IF i MOD 2 = 0 THEN EVAL Glue(Spin (cb.left[i]), ca.right[i], 1); ELSE EVAL Glue(Spin (cb.left[i]), Spin(Clock(ca.right[i])), 1); END END; EVAL Glue(Spin (ca.back[0]), cb.front[0], 1); FOR i := 1 TO 3 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (ca.back[i]), cb.front[i], 1); ELSE EVAL Glue(Clock(ca.back[i]), cb.front[i], 1); END END; FOR i := 4 TO 8 DO IF i MOD 2 = 0 THEN EVAL Glue(Spin (ca.back[i]), cb.front[i], 1); ELSE EVAL Glue(Clock(ca.back[i]), cb.front[i], 1); END END; FOR i := 9 TO 15 DO IF i MOD 2 # 0 THEN EVAL Glue(Spin (ca.back[i]), cb.front[i], 1); ELSE EVAL Glue(Clock(ca.back[i]), cb.front[i], 1); END END; FOR i := 16 TO 24 DO IF i MOD 2 = 0 THEN EVAL Glue(Spin (ca.back[i]), cb.front[i], 1); ELSE EVAL Glue(Clock(ca.back[i]), cb.front[i], 1); END END; RETURN ca.back[0]; END END; RETURN Triangulation.MakeFacetEdge(); END MakeMaximalGlue; PROCEDURE HideFace(a: Pair) = (* This procedure do the following sets: Faces : a.facetedge.face := FALSE Edges: a.facetedge.edge := FALSE Enext(a).facetedge.edge := FALSE Enext_1(a).facetedge.edge := FALSE Vertices: OrgV(a) = FALSE OrgV(Enext(a)) = FALSE OrgV(Enext_1(a)) = FALSE *) BEGIN WITH b = Enext(a), c = Enext_1(a) DO (* setting face *) a.facetedge.face.exists := FALSE; (* setting edges *) a.facetedge.edge.exists := FALSE; b.facetedge.edge.exists := FALSE; c.facetedge.edge.exists := FALSE; (* setting vertices *) OrgV(a).exists := FALSE; OrgV(a).label := "VF"; OrgV(b).exists := FALSE; OrgV(c).exists := FALSE; END END HideFace; PROCEDURE SetLackVertices(ord: CARDINAL; co: Corner) = (* Set the lack vertices as existing on the boundary of a refined tetrahedron of order "ord". *) PROCEDURE SetVerticesOnEdge(a: Pair) = BEGIN WITH r = co.right[0].facetedge.edge.radius, v = OrgV(a) DO v.exists := TRUE; v.radius := r; v.label := "VE"; END END SetVerticesOnEdge; BEGIN IF ord = 2 THEN SetVerticesOnEdge(co.right[0]); SetVerticesOnEdge(co.right[2]); SetVerticesOnEdge(co.right[3]); (* *) SetVerticesOnEdge(Clock(co.left[2])); (* *) SetVerticesOnEdge(co.left[3]); (* *) SetVerticesOnEdge(co.front[3]); ELSIF ord = 3 THEN SetVerticesOnEdge(co.right[0]); SetVerticesOnEdge(co.right[1]); SetVerticesOnEdge(co.right[2]); SetVerticesOnEdge(co.right[7]); SetVerticesOnEdge(co.right[8]); SetVerticesOnEdge(co.right[6]); (* *) SetVerticesOnEdge(Clock(co.left[2])); SetVerticesOnEdge(Clock(co.left[7])); (* *) SetVerticesOnEdge(co.left[5]); SetVerticesOnEdge(co.left[7]); (* *) SetVerticesOnEdge(co.front[6]); SetVerticesOnEdge(co.front[8]); ELSIF ord = 4 THEN SetVerticesOnEdge(co.right[0 ]); SetVerticesOnEdge(co.right[1 ]); SetVerticesOnEdge(co.right[4 ]); SetVerticesOnEdge(co.right[2 ]); SetVerticesOnEdge(co.right[7 ]); SetVerticesOnEdge(co.right[14]); SetVerticesOnEdge(co.right[15]); SetVerticesOnEdge(co.right[13]); SetVerticesOnEdge(co.right[11]); (* *) SetVerticesOnEdge(Clock(co.left[ 2])); SetVerticesOnEdge(Clock(co.left[ 7])); SetVerticesOnEdge(Clock(co.left[14])); (* *) SetVerticesOnEdge(co.left[10]); SetVerticesOnEdge(co.left[12]); SetVerticesOnEdge(co.left[14]); (* *) SetVerticesOnEdge(co.front[11]); SetVerticesOnEdge(co.front[13]); SetVerticesOnEdge(co.front[15]); (* setting vertex label on face *) ELSIF ord = 5 THEN SetVerticesOnEdge(co.right[ 0]); SetVerticesOnEdge(co.right[ 1]); SetVerticesOnEdge(co.right[ 4]); SetVerticesOnEdge(co.right[ 9]); SetVerticesOnEdge(co.right[ 2]); SetVerticesOnEdge(co.right[ 7]); SetVerticesOnEdge(co.right[14]); SetVerticesOnEdge(co.right[23]); SetVerticesOnEdge(co.right[24]); SetVerticesOnEdge(co.right[22]); SetVerticesOnEdge(co.right[20]); SetVerticesOnEdge(co.right[18]); (* *) SetVerticesOnEdge(Clock(co.left[ 2])); SetVerticesOnEdge(Clock(co.left[ 7])); SetVerticesOnEdge(Clock(co.left[14])); SetVerticesOnEdge(Clock(co.left[23])); (* *) SetVerticesOnEdge(co.left[17]); SetVerticesOnEdge(co.left[19]); SetVerticesOnEdge(co.left[21]); SetVerticesOnEdge(co.left[23]); (* *) SetVerticesOnEdge(co.front[18]); SetVerticesOnEdge(co.front[20]); SetVerticesOnEdge(co.front[22]); SetVerticesOnEdge(co.front[24]); END; END SetLackVertices; PROCEDURE SetGrade(ord: CARDINAL; co: Corner) = (* Set edges and spheres underling on the boundary of a tetrahedron as thin cylinders and small spheres. *) PROCEDURE SetVertexOnNet(a: Pair) = BEGIN WITH vn = OrgV(a) DO vn.exists := TRUE; vn.radius := 0.025; vn.color := R3.T{1.00,1.00,0.50}; END END SetVertexOnNet; PROCEDURE SetEdgeOnNet(a: Pair) = BEGIN WITH en = a.facetedge.edge DO en.exists := TRUE; en.radius := 0.0025; en.color := R3.T{1.00,1.00,0.5}; END END SetEdgeOnNet; PROCEDURE SetGrade1() = BEGIN (* nothing *) END SetGrade1; PROCEDURE SetGrade2() = BEGIN (* 3 edges and 0 vertices for each face of the refined tetrahedron. *) (* On the right side. *) SetEdgeOnNet(Enext_1(co.right[0])); SetEdgeOnNet( co.right[3] ); SetEdgeOnNet(Enext (co.right[2])); (* On the left side. *) SetEdgeOnNet(Enext_1(co.left[0])); SetEdgeOnNet( co.left[2] ); SetEdgeOnNet(Enext (co.left[1])); (* On the front side. *) SetEdgeOnNet( co.front[0] ); SetEdgeOnNet(Enext (co.front[1])); SetEdgeOnNet(Enext (co.front[2])); (* On the back side. *) SetEdgeOnNet( co.back [0] ); SetEdgeOnNet(Enext (co.back [1])); SetEdgeOnNet(Enext_1(co.back [2])); END SetGrade2; PROCEDURE SetGrade3() = BEGIN (* 9 edges and 1 vertices for each face of the refined tetrahedron. *) SetGrade2(); (* On the right side. *) SetEdgeOnNet(Enext_1(co.right[3])); SetEdgeOnNet(Enext_1(co.right[1])); SetEdgeOnNet( co.right[8] ); SetEdgeOnNet(Enext (co.right[7])); SetEdgeOnNet( co.right[6] ); SetEdgeOnNet(Enext (co.right[5])); SetVertexOnNet(co.right[3]); (* On the left side. *) SetEdgeOnNet(Enext_1(co.left[1])); SetEdgeOnNet(Enext_1(co.left[3])); SetEdgeOnNet(Enext (co.left[4])); SetEdgeOnNet( co.left[5] ); SetEdgeOnNet(Enext (co.left[6])); SetEdgeOnNet( co.left[7] ); SetVertexOnNet(co.left[3]); (* On the front side. *) SetEdgeOnNet( co.front[1] ); SetEdgeOnNet( co.front[3] ); SetEdgeOnNet(Enext (co.front[4])); SetEdgeOnNet(Enext (co.front[5])); SetEdgeOnNet(Enext (co.front[6])); SetEdgeOnNet(Enext (co.front[7])); SetVertexOnNet(co.front[3]); (* On the back side. *) SetEdgeOnNet( co.back [1] ); SetEdgeOnNet( co.back [3] ); SetEdgeOnNet(Enext (co.back [4])); SetEdgeOnNet(Enext_1(co.back [5])); SetEdgeOnNet(Enext (co.back [6])); SetEdgeOnNet(Enext_1(co.back [7])); SetVertexOnNet(co.back[3]); END SetGrade3; PROCEDURE SetGrade4() = BEGIN (* 18 edges and 3 vertices for each face of the refined tetrahedron. *) SetGrade3(); (* On the right side. *) SetEdgeOnNet(Enext_1(co.right[8])); SetEdgeOnNet(Enext_1(co.right[6])); SetEdgeOnNet(Enext_1(co.right[4])); SetEdgeOnNet( co.right[15] ); SetEdgeOnNet(Enext (co.right[14])); SetEdgeOnNet( co.right[13] ); SetEdgeOnNet(Enext (co.right[12])); SetEdgeOnNet( co.right[11] ); SetEdgeOnNet(Enext (co.right[10])); SetVertexOnNet(co.right[8]); SetVertexOnNet(co.right[6]); (* On the left side. *) SetEdgeOnNet(Enext_1(co.left[4])); SetEdgeOnNet(Enext_1(co.left[6])); SetEdgeOnNet(Enext_1(co.left[8])); SetEdgeOnNet(Enext (co.left[9 ])); SetEdgeOnNet( co.left[10] ); SetEdgeOnNet(Enext (co.left[11])); SetEdgeOnNet( co.left[12] ); SetEdgeOnNet(Enext (co.left[13])); SetEdgeOnNet( co.left[14] ); SetVertexOnNet(co.left[8]); SetVertexOnNet(co.left[6]); (* On the front side. *) SetEdgeOnNet( co.front[4] ); SetEdgeOnNet( co.front[6] ); SetEdgeOnNet( co.front[8] ); SetEdgeOnNet(Enext (co.front[ 9])); SetEdgeOnNet(Enext (co.front[10])); SetEdgeOnNet(Enext (co.front[11])); SetEdgeOnNet(Enext (co.front[12])); SetEdgeOnNet(Enext (co.front[13])); SetEdgeOnNet(Enext (co.front[14])); SetVertexOnNet(co.front[8]); SetVertexOnNet(co.front[6]); (* On the back side. *) SetEdgeOnNet( co.back [4] ); SetEdgeOnNet( co.back [6] ); SetEdgeOnNet( co.back [8] ); SetEdgeOnNet(Enext (co.back [ 9])); SetEdgeOnNet(Enext_1(co.back [10])); SetEdgeOnNet(Enext (co.back [11])); SetEdgeOnNet(Enext_1(co.back [12])); SetEdgeOnNet(Enext (co.back [13])); SetEdgeOnNet(Enext_1(co.back [14])); SetVertexOnNet(co.back[8]); SetVertexOnNet(co.back[6]); END SetGrade4; PROCEDURE SetGrade5() = BEGIN (* 10 edges and 6 vertices for each face of the refined tetrahedron. *) SetGrade4(); (* On the right side. *) SetEdgeOnNet(Enext_1(co.right[15])); SetEdgeOnNet(Enext_1(co.right[13])); SetEdgeOnNet(Enext_1(co.right[11])); SetEdgeOnNet(Enext_1(co.right[ 9])); SetEdgeOnNet( co.right[24] ); SetEdgeOnNet(Enext (co.right[23])); SetEdgeOnNet( co.right[22] ); SetEdgeOnNet(Enext (co.right[21])); SetEdgeOnNet( co.right[20] ); SetEdgeOnNet(Enext (co.right[19])); SetEdgeOnNet( co.right[18] ); SetEdgeOnNet(Enext (co.right[17])); SetVertexOnNet(co.right[15]); SetVertexOnNet(co.right[13]); SetVertexOnNet(co.right[11]); (* On the left side. *) SetEdgeOnNet(Enext_1(co.left[ 9])); SetEdgeOnNet(Enext_1(co.left[11])); SetEdgeOnNet(Enext_1(co.left[13])); SetEdgeOnNet(Enext_1(co.left[15])); SetEdgeOnNet(Enext (co.left[16])); SetEdgeOnNet( co.left[17] ); SetEdgeOnNet(Enext (co.left[18])); SetEdgeOnNet( co.left[19] ); SetEdgeOnNet(Enext (co.left[20])); SetEdgeOnNet( co.left[21] ); SetEdgeOnNet(Enext (co.left[22])); SetEdgeOnNet( co.left[23] ); SetVertexOnNet(co.left[15]); SetVertexOnNet(co.left[13]); SetVertexOnNet(co.left[11]); (* On the front side. *) SetEdgeOnNet( co.front[ 9] ); SetEdgeOnNet( co.front[11] ); SetEdgeOnNet( co.front[13] ); SetEdgeOnNet( co.front[15] ); SetEdgeOnNet(Enext (co.front[16])); SetEdgeOnNet(Enext (co.front[17])); SetEdgeOnNet(Enext (co.front[18])); SetEdgeOnNet(Enext (co.front[19])); SetEdgeOnNet(Enext (co.front[20])); SetEdgeOnNet(Enext (co.front[21])); SetEdgeOnNet(Enext (co.front[22])); SetEdgeOnNet(Enext (co.front[23])); SetVertexOnNet(co.front[15]); SetVertexOnNet(co.front[13]); SetVertexOnNet(co.front[11]); (* On the back side. *) SetEdgeOnNet( co.back [ 9] ); SetEdgeOnNet( co.back [11] ); SetEdgeOnNet( co.back [13] ); SetEdgeOnNet( co.back [15] ); SetEdgeOnNet(Enext (co.back [16])); SetEdgeOnNet(Enext_1(co.back [17])); SetEdgeOnNet(Enext (co.back [18])); SetEdgeOnNet(Enext_1(co.back [19])); SetEdgeOnNet(Enext (co.back [20])); SetEdgeOnNet(Enext_1(co.back [21])); SetEdgeOnNet(Enext (co.back [22])); SetEdgeOnNet(Enext_1(co.back [23])); SetVertexOnNet(co.back[15]); SetVertexOnNet(co.back[13]); SetVertexOnNet(co.back[11]); END SetGrade5; <* FATAL Thread.Alerted, Wr.Failure *> BEGIN IF ord = 1 THEN SetGrade1(); ELSIF ord = 2 THEN SetGrade2(); ELSIF ord = 3 THEN SetGrade3(); ELSIF ord = 4 THEN SetGrade4(); ELSIF ord = 5 THEN SetGrade5(); ELSE Wr.PutText(stderr,"Order must be less equal to 5\n"); <* ASSERT ord <= 5 *> END; END SetGrade; PROCEDURE MakeTriangle() : ARRAY [0..2] OF Pair = (* Builds a triangular face and set the three pairs facetedges with the same face component. *) VAR t : ARRAY [0..2] OF Pair; BEGIN WITH a = MakeFacetEdge(), b = MakeFacetEdge(), c = MakeFacetEdge(), f = a.facetedge.face, u = MakeVertex(), v = MakeVertex(), w = MakeVertex() DO SetOrg(a, u); SetOrg(Clock(a),v); SetEnext(a,b); SetFace(b,f); SetOrg(b,v); SetOrg(Clock(b),w); SetEnext(b,c); SetFace(c,f); SetOrg(c, w); SetOrg(Clock(c), OrgV(a)); <* ASSERT Enext(c) = a *> t[0] := a; t[1] := b; t[2] := c; RETURN t; END END MakeTriangle; PROCEDURE SetOrgCycle(a: Pair; n: Vertex) = (* Set all pairs adjacent to "a" and underling on the 2D star of the vertex "n" with this vertex. *) PROCEDURE SetOrgFace(b: Pair) = (* Set all pairs adjacent to "a" on the Fnext's ring with the vertex "n".*) VAR bn: Pair := b; BEGIN REPEAT SetOrg(bn,n); bn := Fnext(bn); UNTIL bn = b; END SetOrgFace; VAR an: Pair := a; BEGIN REPEAT SetOrgFace(an); an := Onext(an); UNTIL an = a; END SetOrgCycle; PROCEDURE Enext0(a: Pair) : Pair = BEGIN RETURN a END Enext0; PROCEDURE Enext1(a: Pair) : Pair = BEGIN RETURN Enext(a); END Enext1; PROCEDURE Enext2(a: Pair) : Pair = BEGIN RETURN Enext(Enext(a)); END Enext2; PROCEDURE ClockSpinEnext0(a: Pair) : Pair = BEGIN RETURN Clock(Spin(Enext0(a))) END ClockSpinEnext0; PROCEDURE ClockSpinEnext1(a: Pair) : Pair = BEGIN RETURN Clock(Spin(Enext1(a))) END ClockSpinEnext1; PROCEDURE ClockSpinEnext2(a: Pair) : Pair = BEGIN RETURN Clock(Spin(Enext2(a))) END ClockSpinEnext2; PROCEDURE FnextEnext(a: Pair) : Pair = BEGIN RETURN Fnext(Enext(a)) END FnextEnext; PROCEDURE PairsOnFrontier( READONLY co: Corner; cnum, order : CARDINAL; ) : REF PAIR = VAR nc : REF PAIR; BEGIN nc := NEW(REF PAIR, order*order); IF cnum = 0 THEN IF order = 1 THEN nc[ 0] := Enext0(co.right[ 0]); ELSIF order = 2 THEN nc[ 0] := Enext0(co.right[ 1]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := Enext0(co.right[ 0]); (* *) nc[ 3] := Enext0(co.right[ 3]); ELSIF order = 3 THEN nc[ 0] := Enext0(co.right[ 4]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := Enext0(co.right[ 1]); nc[ 3] := FnextEnext(nc[2]); nc[ 4] := Enext0(co.right[ 0]); (* *) nc[ 5] := Enext0(co.right[ 6]); nc[ 6] := FnextEnext(nc[5]); nc[ 7] := Enext0(co.right[ 3]); (* *) nc[ 8] := Enext0(co.right[ 8]); ELSIF order = 4 THEN nc[ 0] := Enext0(co.right[ 9]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := Enext0(co.right[ 4]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := Enext0(co.right[ 1]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := Enext0(co.right[ 0]); (* *) nc[ 7] := Enext0(co.right[11]); nc[ 8] := FnextEnext(nc[ 7]); nc[ 9] := Enext0(co.right[ 6]); nc[10] := FnextEnext(nc[ 9]); nc[11] := Enext0(co.right[ 3]); (* *) nc[12] := Enext0(co.right[13]); nc[13] := FnextEnext(nc[12]); nc[14] := Enext0(co.right[ 8]); (* *) nc[15] := Enext0(co.right[15]); ELSIF order = 5 THEN nc[ 0] := Enext0(co.right[16]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := Enext0(co.right[ 9]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := Enext0(co.right[ 4]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := Enext0(co.right[ 1]); nc[ 7] := FnextEnext(nc[ 6]); nc[ 8] := Enext0(co.right[ 0]); (* *) nc[ 9] := Enext0(co.right[18]); nc[10] := FnextEnext(nc[ 9]); nc[11] := Enext0(co.right[11]); nc[12] := FnextEnext(nc[11]); nc[13] := Enext0(co.right[ 6]); nc[14] := FnextEnext(nc[13]); nc[15] := Enext0(co.right[ 3]); (* *) nc[16] := Enext0(co.right[20]); nc[17] := FnextEnext(nc[16]); nc[18] := Enext0(co.right[13]); nc[19] := FnextEnext(nc[18]); nc[20] := Enext0(co.right[ 8]); (* *) nc[21] := Enext0(co.right[22]); nc[22] := FnextEnext(nc[21]); nc[23] := Enext0(co.right[15]); (* *) nc[24] := Enext0(co.right[24]); END END; IF cnum = 1 THEN IF order = 1 THEN nc[ 0] := Enext1(co.right[ 0]); ELSIF order = 2 THEN nc[ 0] := Enext1(co.right[ 0]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := Enext1(co.right[ 3]); (* *) nc[ 3] := Enext1(co.right[ 1]); ELSIF order = 3 THEN nc[ 0] := Enext1(co.right[ 0]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := Enext1(co.right[ 3]); nc[ 3] := FnextEnext(nc[2]); nc[ 4] := Enext1(co.right[ 8]); (* *) nc[ 5] := Enext1(co.right[ 1]); nc[ 6] := FnextEnext(nc[5]); nc[ 7] := Enext1(co.right[ 6]); (* *) nc[ 8] := Enext1(co.right[ 4]); ELSIF order = 4 THEN nc[ 0] := Enext1(co.right[ 0]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := Enext1(co.right[ 3]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := Enext1(co.right[ 8]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := Enext1(co.right[15]); (* *) nc[ 7] := Enext1(co.right[ 1]); nc[ 8] := FnextEnext(nc[ 7]); nc[ 9] := Enext1(co.right[ 6]); nc[10] := FnextEnext(nc[ 9]); nc[11] := Enext1(co.right[13]); (* *) nc[12] := Enext1(co.right[ 4]); nc[13] := FnextEnext(nc[12]); nc[14] := Enext1(co.right[11]); (* *) nc[15] := Enext1(co.right[ 9]); ELSIF order = 5 THEN nc[ 0] := Enext1(co.right[ 0]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := Enext1(co.right[ 3]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := Enext1(co.right[ 8]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := Enext1(co.right[15]); nc[ 7] := FnextEnext(nc[ 6]); nc[ 8] := Enext1(co.right[24]); (* *) nc[ 9] := Enext1(co.right[ 1]); nc[10] := FnextEnext(nc[ 9]); nc[11] := Enext1(co.right[ 6]); nc[12] := FnextEnext(nc[11]); nc[13] := Enext1(co.right[13]); nc[14] := FnextEnext(nc[13]); nc[15] := Enext1(co.right[22]); (* *) nc[16] := Enext1(co.right[ 4]); nc[17] := FnextEnext(nc[16]); nc[18] := Enext1(co.right[11]); nc[19] := FnextEnext(nc[18]); nc[20] := Enext1(co.right[20]); (* *) nc[21] := Enext1(co.right[ 9]); nc[22] := FnextEnext(nc[21]); nc[23] := Enext1(co.right[18]); (* *) nc[24] := Enext1(co.right[16]); END END; IF cnum = 2 THEN IF order = 1 THEN nc[ 0] := Enext2(co.right[ 0]); ELSIF order = 2 THEN nc[ 0] := Enext2(co.right[ 3]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := Enext2(co.right[ 1]); (* *) nc[ 3] := Enext2(co.right[ 0]); ELSIF order = 3 THEN nc[ 0] := Enext2(co.right[ 8]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := Enext2(co.right[ 6]); nc[ 3] := FnextEnext(nc[2]); nc[ 4] := Enext2(co.right[ 4]); (* *) nc[ 5] := Enext2(co.right[ 3]); nc[ 6] := FnextEnext(nc[5]); nc[ 7] := Enext2(co.right[ 1]); (* *) nc[ 8] := Enext2(co.right[ 0]); ELSIF order = 4 THEN nc[ 0] := Enext2(co.right[15]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := Enext2(co.right[13]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := Enext2(co.right[11]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := Enext2(co.right[ 9]); (* *) nc[ 7] := Enext2(co.right[ 8]); nc[ 8] := FnextEnext(nc[ 7]); nc[ 9] := Enext2(co.right[ 6]); nc[10] := FnextEnext(nc[ 9]); nc[11] := Enext2(co.right[ 4]); (* *) nc[12] := Enext2(co.right[ 3]); nc[13] := FnextEnext(nc[12]); nc[14] := Enext2(co.right[ 1]); (* *) nc[15] := Enext2(co.right[ 0]); ELSIF order = 5 THEN nc[ 0] := Enext2(co.right[24]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := Enext2(co.right[22]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := Enext2(co.right[20]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := Enext2(co.right[18]); nc[ 7] := FnextEnext(nc[ 6]); nc[ 8] := Enext2(co.right[16]); (* *) nc[ 9] := Enext2(co.right[15]); nc[10] := FnextEnext(nc[ 9]); nc[11] := Enext2(co.right[13]); nc[12] := FnextEnext(nc[11]); nc[13] := Enext2(co.right[11]); nc[14] := FnextEnext(nc[13]); nc[15] := Enext2(co.right[ 9]); (* *) nc[16] := Enext2(co.right[ 8]); nc[17] := FnextEnext(nc[16]); nc[18] := Enext2(co.right[ 6]); nc[19] := FnextEnext(nc[18]); nc[20] := Enext2(co.right[ 4]); (* *) nc[21] := Enext2(co.right[ 3]); nc[22] := FnextEnext(nc[21]); nc[23] := Enext2(co.right[ 1]); (* *) nc[24] := Enext2(co.right[ 0]); END END; IF cnum = 3 THEN IF order = 1 THEN nc[ 0] := Enext0(co.left[ 0]); ELSIF order = 2 THEN nc[ 0] := Enext0(co.left[ 1]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := Enext0(co.left[ 0]); (* *) nc[ 3] := Enext0(co.left[ 3]); ELSIF order = 3 THEN nc[ 0] := Enext0(co.left[ 4]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := Enext0(co.left[ 1]); nc[ 3] := FnextEnext(nc[2]); nc[ 4] := Enext0(co.left[ 0]); (* *) nc[ 5] := Enext0(co.left[ 6]); nc[ 6] := FnextEnext(nc[5]); nc[ 7] := Enext0(co.left[ 3]); (* *) nc[ 8] := Enext0(co.left[ 8]); ELSIF order = 4 THEN nc[ 0] := Enext0(co.left[ 9]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := Enext0(co.left[ 4]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := Enext0(co.left[ 1]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := Enext0(co.left[ 0]); (* *) nc[ 7] := Enext0(co.left[11]); nc[ 8] := FnextEnext(nc[ 7]); nc[ 9] := Enext0(co.left[ 6]); nc[10] := FnextEnext(nc[ 9]); nc[11] := Enext0(co.left[ 3]); (* *) nc[12] := Enext0(co.left[13]); nc[13] := FnextEnext(nc[12]); nc[14] := Enext0(co.left[ 8]); (* *) nc[15] := Enext0(co.left[15]); ELSIF order = 5 THEN nc[ 0] := Enext0(co.left[16]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := Enext0(co.left[ 9]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := Enext0(co.left[ 4]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := Enext0(co.left[ 1]); nc[ 7] := FnextEnext(nc[ 6]); nc[ 8] := Enext0(co.left[ 0]); (* *) nc[ 9] := Enext0(co.left[18]); nc[10] := FnextEnext(nc[ 9]); nc[11] := Enext0(co.left[11]); nc[12] := FnextEnext(nc[11]); nc[13] := Enext0(co.left[ 6]); nc[14] := FnextEnext(nc[13]); nc[15] := Enext0(co.left[ 3]); (* *) nc[16] := Enext0(co.left[20]); nc[17] := FnextEnext(nc[16]); nc[18] := Enext0(co.left[13]); nc[19] := FnextEnext(nc[18]); nc[20] := Enext0(co.left[ 8]); (* *) nc[21] := Enext0(co.left[22]); nc[22] := FnextEnext(nc[21]); nc[23] := Enext0(co.left[15]); (* *) nc[24] := Enext0(co.left[24]); END END; IF cnum = 4 THEN IF order = 1 THEN nc[ 0] := Enext1(co.left[ 0]); ELSIF order = 2 THEN nc[ 0] := Enext1(co.left[ 0]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := Enext1(co.left[ 3]); (* *) nc[ 3] := Enext1(co.left[ 1]); ELSIF order = 3 THEN nc[ 0] := Enext1(co.left[ 0]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := Enext1(co.left[ 3]); nc[ 3] := FnextEnext(nc[2]); nc[ 4] := Enext1(co.left[ 8]); (* *) nc[ 5] := Enext1(co.left[ 1]); nc[ 6] := FnextEnext(nc[5]); nc[ 7] := Enext1(co.left[ 6]); (* *) nc[ 8] := Enext1(co.left[ 4]); ELSIF order = 4 THEN nc[ 0] := Enext1(co.left[ 0]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := Enext1(co.left[ 3]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := Enext1(co.left[ 8]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := Enext1(co.left[15]); (* *) nc[ 7] := Enext1(co.left[ 1]); nc[ 8] := FnextEnext(nc[ 7]); nc[ 9] := Enext1(co.left[ 6]); nc[10] := FnextEnext(nc[ 9]); nc[11] := Enext1(co.left[13]); (* *) nc[12] := Enext1(co.left[ 4]); nc[13] := FnextEnext(nc[12]); nc[14] := Enext1(co.left[11]); (* *) nc[15] := Enext1(co.left[ 9]); ELSIF order = 5 THEN nc[ 0] := Enext1(co.left[ 0]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := Enext1(co.left[ 3]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := Enext1(co.left[ 8]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := Enext1(co.left[15]); nc[ 7] := FnextEnext(nc[ 6]); nc[ 8] := Enext1(co.left[24]); (* *) nc[ 9] := Enext1(co.left[ 1]); nc[10] := FnextEnext(nc[ 9]); nc[11] := Enext1(co.left[ 6]); nc[12] := FnextEnext(nc[11]); nc[13] := Enext1(co.left[13]); nc[14] := FnextEnext(nc[13]); nc[15] := Enext1(co.left[22]); (* *) nc[16] := Enext1(co.left[ 4]); nc[17] := FnextEnext(nc[16]); nc[18] := Enext1(co.left[11]); nc[19] := FnextEnext(nc[18]); nc[20] := Enext1(co.left[20]); (* *) nc[21] := Enext1(co.left[ 9]); nc[22] := FnextEnext(nc[21]); nc[23] := Enext1(co.left[18]); (* *) nc[24] := Enext1(co.left[16]); END END; IF cnum = 5 THEN IF order = 1 THEN nc[ 0] := Enext2(co.left[ 0]); ELSIF order = 2 THEN nc[ 0] := Enext2(co.left[ 3]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := Enext2(co.left[ 1]); (* *) nc[ 3] := Enext2(co.left[ 0]); ELSIF order = 3 THEN nc[ 0] := Enext2(co.left[ 8]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := Enext2(co.left[ 6]); nc[ 3] := FnextEnext(nc[2]); nc[ 4] := Enext2(co.left[ 4]); (* *) nc[ 5] := Enext2(co.left[ 3]); nc[ 6] := FnextEnext(nc[5]); nc[ 7] := Enext2(co.left[ 1]); (* *) nc[ 8] := Enext2(co.left[ 0]); ELSIF order = 4 THEN nc[ 0] := Enext2(co.left[15]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := Enext2(co.left[13]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := Enext2(co.left[11]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := Enext2(co.left[ 9]); (* *) nc[ 7] := Enext2(co.left[ 8]); nc[ 8] := FnextEnext(nc[ 7]); nc[ 9] := Enext2(co.left[ 6]); nc[10] := FnextEnext(nc[ 9]); nc[11] := Enext2(co.left[ 4]); (* *) nc[12] := Enext2(co.left[ 3]); nc[13] := FnextEnext(nc[12]); nc[14] := Enext2(co.left[ 1]); (* *) nc[15] := Enext2(co.left[ 0]); ELSIF order = 5 THEN nc[ 0] := Enext2(co.left[24]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := Enext2(co.left[22]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := Enext2(co.left[20]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := Enext2(co.left[18]); nc[ 7] := FnextEnext(nc[ 6]); nc[ 8] := Enext2(co.left[16]); (* *) nc[ 9] := Enext2(co.left[15]); nc[10] := FnextEnext(nc[ 9]); nc[11] := Enext2(co.left[13]); nc[12] := FnextEnext(nc[11]); nc[13] := Enext2(co.left[11]); nc[14] := FnextEnext(nc[13]); nc[15] := Enext2(co.left[ 9]); (* *) nc[16] := Enext2(co.left[ 8]); nc[17] := FnextEnext(nc[16]); nc[18] := Enext2(co.left[ 6]); nc[19] := FnextEnext(nc[18]); nc[20] := Enext2(co.left[ 4]); (* *) nc[21] := Enext2(co.left[ 3]); nc[22] := FnextEnext(nc[21]); nc[23] := Enext2(co.left[ 1]); (* *) nc[24] := Enext2(co.left[ 0]); END END; IF cnum = 6 THEN IF order = 1 THEN nc[ 0] := ClockSpinEnext1(co.front[ 0]); ELSIF order = 2 THEN nc[ 0] := ClockSpinEnext1(co.front[ 0]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := ClockSpinEnext1(co.front[ 3]); (* *) nc[ 3] := ClockSpinEnext1(co.front[ 1]); ELSIF order = 3 THEN nc[ 0] := ClockSpinEnext1(co.front[ 0]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := ClockSpinEnext1(co.front[ 3]); nc[ 3] := FnextEnext(nc[2]); nc[ 4] := ClockSpinEnext1(co.front[ 8]); (* *) nc[ 5] := ClockSpinEnext1(co.front[ 1]); nc[ 6] := FnextEnext(nc[5]); nc[ 7] := ClockSpinEnext1(co.front[ 6]); (* *) nc[ 8] := ClockSpinEnext1(co.front[ 4]); ELSIF order = 4 THEN nc[ 0] := ClockSpinEnext1(co.front[ 0]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := ClockSpinEnext1(co.front[ 3]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := ClockSpinEnext1(co.front[ 8]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := ClockSpinEnext1(co.front[15]); (* *) nc[ 7] := ClockSpinEnext1(co.front[ 1]); nc[ 8] := FnextEnext(nc[ 7]); nc[ 9] := ClockSpinEnext1(co.front[ 6]); nc[10] := FnextEnext(nc[ 9]); nc[11] := ClockSpinEnext1(co.front[13]); (* *) nc[12] := ClockSpinEnext1(co.front[ 4]); nc[13] := FnextEnext(nc[12]); nc[14] := ClockSpinEnext1(co.front[11]); (* *) nc[15] := ClockSpinEnext1(co.front[ 9]); ELSIF order = 5 THEN nc[ 0] := ClockSpinEnext1(co.front[ 0]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := ClockSpinEnext1(co.front[ 3]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := ClockSpinEnext1(co.front[ 8]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := ClockSpinEnext1(co.front[15]); nc[ 7] := FnextEnext(nc[ 6]); nc[ 8] := ClockSpinEnext1(co.front[24]); (* *) nc[ 9] := ClockSpinEnext1(co.front[ 1]); nc[10] := FnextEnext(nc[ 9]); nc[11] := ClockSpinEnext1(co.front[ 6]); nc[12] := FnextEnext(nc[11]); nc[13] := ClockSpinEnext1(co.front[13]); nc[14] := FnextEnext(nc[13]); nc[15] := ClockSpinEnext1(co.front[22]); (* *) nc[16] := ClockSpinEnext1(co.front[ 4]); nc[17] := FnextEnext(nc[16]); nc[18] := ClockSpinEnext1(co.front[11]); nc[19] := FnextEnext(nc[18]); nc[20] := ClockSpinEnext1(co.front[20]); (* *) nc[21] := ClockSpinEnext1(co.front[ 9]); nc[22] := FnextEnext(nc[21]); nc[23] := ClockSpinEnext1(co.front[18]); (* *) nc[24] := ClockSpinEnext1(co.front[16]); END END; IF cnum = 7 THEN IF order = 1 THEN nc[ 0] := ClockSpinEnext0(co.front[ 0]); ELSIF order = 2 THEN nc[ 0] := ClockSpinEnext0(co.front[ 3]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := ClockSpinEnext0(co.front[ 1]); (* *) nc[ 3] := ClockSpinEnext0(co.front[ 0]); ELSIF order = 3 THEN nc[ 0] := ClockSpinEnext0(co.front[ 8]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := ClockSpinEnext0(co.front[ 6]); nc[ 3] := FnextEnext(nc[2]); nc[ 4] := ClockSpinEnext0(co.front[ 4]); (* *) nc[ 5] := ClockSpinEnext0(co.front[ 3]); nc[ 6] := FnextEnext(nc[5]); nc[ 7] := ClockSpinEnext0(co.front[ 1]); (* *) nc[ 8] := ClockSpinEnext0(co.front[ 0]); ELSIF order = 4 THEN nc[ 0] := ClockSpinEnext0(co.front[15]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := ClockSpinEnext0(co.front[13]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := ClockSpinEnext0(co.front[11]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := ClockSpinEnext0(co.front[ 9]); (* *) nc[ 7] := ClockSpinEnext0(co.front[ 8]); nc[ 8] := FnextEnext(nc[ 7]); nc[ 9] := ClockSpinEnext0(co.front[ 6]); nc[10] := FnextEnext(nc[ 9]); nc[11] := ClockSpinEnext0(co.front[ 4]); (* *) nc[12] := ClockSpinEnext0(co.front[ 3]); nc[13] := FnextEnext(nc[12]); nc[14] := ClockSpinEnext0(co.front[ 1]); (* *) nc[15] := ClockSpinEnext0(co.front[ 0]); ELSIF order = 5 THEN nc[ 0] := ClockSpinEnext0(co.front[24]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := ClockSpinEnext0(co.front[22]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := ClockSpinEnext0(co.front[20]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := ClockSpinEnext0(co.front[18]); nc[ 7] := FnextEnext(nc[ 6]); nc[ 8] := ClockSpinEnext0(co.front[16]); (* *) nc[ 9] := ClockSpinEnext0(co.front[15]); nc[10] := FnextEnext(nc[ 9]); nc[11] := ClockSpinEnext0(co.front[13]); nc[12] := FnextEnext(nc[11]); nc[13] := ClockSpinEnext0(co.front[11]); nc[14] := FnextEnext(nc[13]); nc[15] := ClockSpinEnext0(co.front[ 9]); (* *) nc[16] := ClockSpinEnext0(co.front[ 8]); nc[17] := FnextEnext(nc[16]); nc[18] := ClockSpinEnext0(co.front[ 6]); nc[19] := FnextEnext(nc[18]); nc[20] := ClockSpinEnext0(co.front[ 4]); (* *) nc[21] := ClockSpinEnext0(co.front[ 3]); nc[22] := FnextEnext(nc[21]); nc[23] := ClockSpinEnext0(co.front[ 1]); (* *) nc[24] := ClockSpinEnext0(co.front[ 0]); END END; IF cnum = 8 THEN IF order = 1 THEN nc[ 0] := ClockSpinEnext2(co.front[ 0]); ELSIF order = 2 THEN nc[ 0] := ClockSpinEnext2(co.front[ 1]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := ClockSpinEnext2(co.front[ 0]); (* *) nc[ 3] := ClockSpinEnext2(co.front[ 3]); ELSIF order = 3 THEN nc[ 0] := ClockSpinEnext2(co.front[ 4]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := ClockSpinEnext2(co.front[ 1]); nc[ 3] := FnextEnext(nc[2]); nc[ 4] := ClockSpinEnext2(co.front[ 0]); (* *) nc[ 5] := ClockSpinEnext2(co.front[ 6]); nc[ 6] := FnextEnext(nc[5]); nc[ 7] := ClockSpinEnext2(co.front[ 3]); (* *) nc[ 8] := ClockSpinEnext2(co.front[ 8]); ELSIF order = 4 THEN nc[ 0] := ClockSpinEnext2(co.front[ 9]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := ClockSpinEnext2(co.front[ 4]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := ClockSpinEnext2(co.front[ 1]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := ClockSpinEnext2(co.front[ 0]); (* *) nc[ 7] := ClockSpinEnext2(co.front[11]); nc[ 8] := FnextEnext(nc[ 7]); nc[ 9] := ClockSpinEnext2(co.front[ 6]); nc[10] := FnextEnext(nc[ 9]); nc[11] := ClockSpinEnext2(co.front[ 3]); (* *) nc[12] := ClockSpinEnext2(co.front[13]); nc[13] := FnextEnext(nc[12]); nc[14] := ClockSpinEnext2(co.front[ 8]); (* *) nc[15] := ClockSpinEnext2(co.front[15]); ELSIF order = 5 THEN nc[ 0] := ClockSpinEnext2(co.front[16]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := ClockSpinEnext2(co.front[ 9]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := ClockSpinEnext2(co.front[ 4]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := ClockSpinEnext2(co.front[ 1]); nc[ 7] := FnextEnext(nc[ 6]); nc[ 8] := ClockSpinEnext2(co.front[ 0]); (* *) nc[ 9] := ClockSpinEnext2(co.front[18]); nc[10] := FnextEnext(nc[ 9]); nc[11] := ClockSpinEnext2(co.front[11]); nc[12] := FnextEnext(nc[11]); nc[13] := ClockSpinEnext2(co.front[ 6]); nc[14] := FnextEnext(nc[13]); nc[15] := ClockSpinEnext2(co.front[ 3]); (* *) nc[16] := ClockSpinEnext2(co.front[20]); nc[17] := FnextEnext(nc[16]); nc[18] := ClockSpinEnext2(co.front[13]); nc[19] := FnextEnext(nc[18]); nc[20] := ClockSpinEnext2(co.front[ 8]); (* *) nc[21] := ClockSpinEnext2(co.front[22]); nc[22] := FnextEnext(nc[21]); nc[23] := ClockSpinEnext2(co.front[15]); (* *) nc[24] := ClockSpinEnext2(co.front[24]); END END; IF cnum = 9 THEN IF order = 1 THEN nc[ 0] := Enext1(co.back[ 0]); ELSIF order = 2 THEN nc[ 0] := Enext1(co.back[ 3]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := Enext1(co.back[ 0]); (* *) nc[ 3] := Enext1(co.back[ 1]); ELSIF order = 3 THEN nc[ 0] := Enext1(co.back[ 8]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := Enext1(co.back[ 3]); nc[ 3] := FnextEnext(nc[2]); nc[ 4] := Enext1(co.back[ 0]); (* *) nc[ 5] := Enext1(co.back[ 6]); nc[ 6] := FnextEnext(nc[5]); nc[ 7] := Enext1(co.back[ 1]); (* *) nc[ 8] := Enext1(co.back[ 4]); ELSIF order = 4 THEN nc[ 0] := Enext1(co.back[15]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := Enext1(co.back[ 8]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := Enext1(co.back[ 3]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := Enext1(co.back[ 0]); (* *) nc[ 7] := Enext1(co.back[13]); nc[ 8] := FnextEnext(nc[ 7]); nc[ 9] := Enext1(co.back[ 6]); nc[10] := FnextEnext(nc[ 9]); nc[11] := Enext1(co.back[ 1]); (* *) nc[12] := Enext1(co.back[11]); nc[13] := FnextEnext(nc[12]); nc[14] := Enext1(co.back[ 4]); (* *) nc[15] := Enext1(co.back[ 9]); ELSIF order = 5 THEN nc[ 0] := Enext1(co.back[24]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := Enext1(co.back[15]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := Enext1(co.back[ 8]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := Enext1(co.back[ 3]); nc[ 7] := FnextEnext(nc[ 6]); nc[ 8] := Enext1(co.back[ 0]); (* *) nc[ 9] := Enext1(co.back[22]); nc[10] := FnextEnext(nc[ 9]); nc[11] := Enext1(co.back[13]); nc[12] := FnextEnext(nc[11]); nc[13] := Enext1(co.back[ 6]); nc[14] := FnextEnext(nc[13]); nc[15] := Enext1(co.back[ 1]); (* *) nc[16] := Enext1(co.back[20]); nc[17] := FnextEnext(nc[16]); nc[18] := Enext1(co.back[11]); nc[19] := FnextEnext(nc[18]); nc[20] := Enext1(co.back[ 4]); (* *) nc[21] := Enext1(co.back[18]); nc[22] := FnextEnext(nc[21]); nc[23] := Enext1(co.back[ 9]); (* *) nc[24] := Enext1(co.back[16]); END END; IF cnum = 10 THEN IF order = 1 THEN nc[ 0] := Enext2(co.back[ 0]); ELSIF order = 2 THEN nc[ 0] := Enext2(co.back[ 0]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := Enext2(co.back[ 1]); (* *) nc[ 3] := Enext2(co.back[ 3]); ELSIF order = 3 THEN nc[ 0] := Enext2(co.back[ 0]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := Enext2(co.back[ 1]); nc[ 3] := FnextEnext(nc[2]); nc[ 4] := Enext2(co.back[ 4]); (* *) nc[ 5] := Enext2(co.back[ 3]); nc[ 6] := FnextEnext(nc[5]); nc[ 7] := Enext2(co.back[ 6]); (* *) nc[ 8] := Enext2(co.back[ 8]); ELSIF order = 4 THEN nc[ 0] := Enext2(co.back[ 0]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := Enext2(co.back[ 1]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := Enext2(co.back[ 4]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := Enext2(co.back[ 9]); (* *) nc[ 7] := Enext2(co.back[ 3]); nc[ 8] := FnextEnext(nc[ 7]); nc[ 9] := Enext2(co.back[ 6]); nc[10] := FnextEnext(nc[ 9]); nc[11] := Enext2(co.back[11]); (* *) nc[12] := Enext2(co.back[ 8]); nc[13] := FnextEnext(nc[12]); nc[14] := Enext2(co.back[13]); (* *) nc[15] := Enext2(co.back[15]); ELSIF order = 5 THEN nc[ 0] := Enext2(co.back[ 0]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := Enext2(co.back[ 1]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := Enext2(co.back[ 4]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := Enext2(co.back[ 9]); nc[ 7] := FnextEnext(nc[ 6]); nc[ 8] := Enext2(co.back[16]); (* *) nc[ 9] := Enext2(co.back[ 3]); nc[10] := FnextEnext(nc[ 9]); nc[11] := Enext2(co.back[ 6]); nc[12] := FnextEnext(nc[11]); nc[13] := Enext2(co.back[11]); nc[14] := FnextEnext(nc[13]); nc[15] := Enext2(co.back[18]); (* *) nc[16] := Enext2(co.back[ 8]); nc[17] := FnextEnext(nc[16]); nc[18] := Enext2(co.back[13]); nc[19] := FnextEnext(nc[18]); nc[20] := Enext2(co.back[20]); (* *) nc[21] := Enext2(co.back[15]); nc[22] := FnextEnext(nc[21]); nc[23] := Enext2(co.back[22]); (* *) nc[24] := Enext2(co.back[24]); END END; IF cnum = 11 THEN IF order = 1 THEN nc[ 0] := Enext0(co.back[ 0]); ELSIF order = 2 THEN nc[ 0] := Enext0(co.back[ 1]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := Enext0(co.back[ 3]); (* *) nc[ 3] := Enext0(co.back[ 0]); ELSIF order = 3 THEN nc[ 0] := Enext0(co.back[ 4]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := Enext0(co.back[ 6]); nc[ 3] := FnextEnext(nc[2]); nc[ 4] := Enext0(co.back[ 8]); (* *) nc[ 5] := Enext0(co.back[ 1]); nc[ 6] := FnextEnext(nc[5]); nc[ 7] := Enext0(co.back[ 3]); (* *) nc[ 8] := Enext0(co.back[ 0]); ELSIF order = 4 THEN nc[ 0] := Enext0(co.back[ 9]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := Enext0(co.back[11]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := Enext0(co.back[13]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := Enext0(co.back[15]); (* *) nc[ 7] := Enext0(co.back[ 4]); nc[ 8] := FnextEnext(nc[ 7]); nc[ 9] := Enext0(co.back[ 6]); nc[10] := FnextEnext(nc[ 9]); nc[11] := Enext0(co.back[ 8]); (* *) nc[12] := Enext0(co.back[ 1]); nc[13] := FnextEnext(nc[12]); nc[14] := Enext0(co.back[ 3]); (* *) nc[15] := Enext0(co.back[ 0]); ELSIF order = 5 THEN nc[ 0] := Enext0(co.back[16]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := Enext0(co.back[18]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := Enext0(co.back[20]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := Enext0(co.back[22]); nc[ 7] := FnextEnext(nc[ 6]); nc[ 8] := Enext0(co.back[24]); (* *) nc[ 9] := Enext0(co.back[ 9]); nc[10] := FnextEnext(nc[ 9]); nc[11] := Enext0(co.back[11]); nc[12] := FnextEnext(nc[11]); nc[13] := Enext0(co.back[13]); nc[14] := FnextEnext(nc[13]); nc[15] := Enext0(co.back[15]); (* *) nc[16] := Enext0(co.back[ 4]); nc[17] := FnextEnext(nc[16]); nc[18] := Enext0(co.back[ 6]); nc[19] := FnextEnext(nc[18]); nc[20] := Enext0(co.back[ 8]); (* *) nc[21] := Enext0(co.back[ 1]); nc[22] := FnextEnext(nc[21]); nc[23] := Enext0(co.back[ 3]); (* *) nc[24] := Enext0(co.back[ 0]); END END; IF cnum = 12 THEN IF order = 1 THEN nc[ 0] := ClockSpinEnext0(co.right[ 0]); ELSIF order = 2 THEN nc[ 0] := ClockSpinEnext0(co.right[ 0]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := ClockSpinEnext0(co.right[ 1]); (* *) nc[ 3] := ClockSpinEnext0(co.right[ 3]); ELSIF order = 3 THEN nc[ 0] := ClockSpinEnext0(co.right[ 0]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := ClockSpinEnext0(co.right[ 1]); nc[ 3] := FnextEnext(nc[2]); nc[ 4] := ClockSpinEnext0(co.right[ 4]); (* *) nc[ 5] := ClockSpinEnext0(co.right[ 3]); nc[ 6] := FnextEnext(nc[5]); nc[ 7] := ClockSpinEnext0(co.right[ 6]); (* *) nc[ 8] := ClockSpinEnext0(co.right[ 8]); ELSIF order = 4 THEN nc[ 0] := ClockSpinEnext0(co.right[ 0]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := ClockSpinEnext0(co.right[ 1]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := ClockSpinEnext0(co.right[ 4]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := ClockSpinEnext0(co.right[ 9]); (* *) nc[ 7] := ClockSpinEnext0(co.right[ 3]); nc[ 8] := FnextEnext(nc[ 7]); nc[ 9] := ClockSpinEnext0(co.right[ 6]); nc[10] := FnextEnext(nc[ 9]); nc[11] := ClockSpinEnext0(co.right[11]); (* *) nc[12] := ClockSpinEnext0(co.right[ 8]); nc[13] := FnextEnext(nc[12]); nc[14] := ClockSpinEnext0(co.right[13]); (* *) nc[15] := ClockSpinEnext0(co.right[15]); ELSIF order = 5 THEN nc[ 0] := ClockSpinEnext0(co.right[ 0]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := ClockSpinEnext0(co.right[ 1]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := ClockSpinEnext0(co.right[ 4]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := ClockSpinEnext0(co.right[ 9]); nc[ 7] := FnextEnext(nc[ 6]); nc[ 8] := ClockSpinEnext0(co.right[16]); (* *) nc[ 9] := ClockSpinEnext0(co.right[ 3]); nc[10] := FnextEnext(nc[ 9]); nc[11] := ClockSpinEnext0(co.right[ 6]); nc[12] := FnextEnext(nc[11]); nc[13] := ClockSpinEnext0(co.right[11]); nc[14] := FnextEnext(nc[13]); nc[15] := ClockSpinEnext0(co.right[18]); (* *) nc[16] := ClockSpinEnext0(co.right[ 8]); nc[17] := FnextEnext(nc[16]); nc[18] := ClockSpinEnext0(co.right[13]); nc[19] := FnextEnext(nc[18]); nc[20] := ClockSpinEnext0(co.right[20]); (* *) nc[21] := ClockSpinEnext0(co.right[15]); nc[22] := FnextEnext(nc[21]); nc[23] := ClockSpinEnext0(co.right[22]); (* *) nc[24] := ClockSpinEnext0(co.right[24]); END END; IF cnum = 13 THEN IF order = 1 THEN nc[ 0] := ClockSpinEnext1(co.right[ 0]); ELSIF order = 2 THEN nc[ 0] := ClockSpinEnext1(co.right[ 3]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := ClockSpinEnext1(co.right[ 0]); (* *) nc[ 3] := ClockSpinEnext1(co.right[ 1]); ELSIF order = 3 THEN nc[ 0] := ClockSpinEnext1(co.right[ 8]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := ClockSpinEnext1(co.right[ 3]); nc[ 3] := FnextEnext(nc[2]); nc[ 4] := ClockSpinEnext1(co.right[ 0]); (* *) nc[ 5] := ClockSpinEnext1(co.right[ 6]); nc[ 6] := FnextEnext(nc[5]); nc[ 7] := ClockSpinEnext1(co.right[ 1]); (* *) nc[ 8] := ClockSpinEnext1(co.right[ 4]); ELSIF order = 4 THEN nc[ 0] := ClockSpinEnext1(co.right[15]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := ClockSpinEnext1(co.right[ 8]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := ClockSpinEnext1(co.right[ 3]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := ClockSpinEnext1(co.right[ 0]); (* *) nc[ 7] := ClockSpinEnext1(co.right[13]); nc[ 8] := FnextEnext(nc[ 7]); nc[ 9] := ClockSpinEnext1(co.right[ 6]); nc[10] := FnextEnext(nc[ 9]); nc[11] := ClockSpinEnext1(co.right[ 1]); (* *) nc[12] := ClockSpinEnext1(co.right[11]); nc[13] := FnextEnext(nc[12]); nc[14] := ClockSpinEnext1(co.right[ 4]); (* *) nc[15] := ClockSpinEnext1(co.right[ 9]); ELSIF order = 5 THEN nc[ 0] := ClockSpinEnext1(co.right[24]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := ClockSpinEnext1(co.right[15]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := ClockSpinEnext1(co.right[ 8]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := ClockSpinEnext1(co.right[ 3]); nc[ 7] := FnextEnext(nc[ 6]); nc[ 8] := ClockSpinEnext1(co.right[ 0]); (* *) nc[ 9] := ClockSpinEnext1(co.right[22]); nc[10] := FnextEnext(nc[ 9]); nc[11] := ClockSpinEnext1(co.right[13]); nc[12] := FnextEnext(nc[11]); nc[13] := ClockSpinEnext1(co.right[ 6]); nc[14] := FnextEnext(nc[13]); nc[15] := ClockSpinEnext1(co.right[ 1]); (* *) nc[16] := ClockSpinEnext1(co.right[20]); nc[17] := FnextEnext(nc[16]); nc[18] := ClockSpinEnext1(co.right[11]); nc[19] := FnextEnext(nc[18]); nc[20] := ClockSpinEnext1(co.right[ 4]); (* *) nc[21] := ClockSpinEnext1(co.right[18]); nc[22] := FnextEnext(nc[21]); nc[23] := ClockSpinEnext1(co.right[ 9]); (* *) nc[24] := ClockSpinEnext1(co.right[16]); END END; IF cnum = 14 THEN IF order = 1 THEN nc[ 0] := ClockSpinEnext2(co.right[ 0]); ELSIF order = 2 THEN nc[ 0] := ClockSpinEnext2(co.right[ 1]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := ClockSpinEnext2(co.right[ 3]); (* *) nc[ 3] := ClockSpinEnext2(co.right[ 0]); ELSIF order = 3 THEN nc[ 0] := ClockSpinEnext2(co.right[ 4]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := ClockSpinEnext2(co.right[ 6]); nc[ 3] := FnextEnext(nc[2]); nc[ 4] := ClockSpinEnext2(co.right[ 8]); (* *) nc[ 5] := ClockSpinEnext2(co.right[ 1]); nc[ 6] := FnextEnext(nc[5]); nc[ 7] := ClockSpinEnext2(co.right[ 3]); (* *) nc[ 8] := ClockSpinEnext2(co.right[ 0]); ELSIF order = 4 THEN nc[ 0] := ClockSpinEnext2(co.right[ 9]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := ClockSpinEnext2(co.right[11]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := ClockSpinEnext2(co.right[13]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := ClockSpinEnext2(co.right[15]); (* *) nc[ 7] := ClockSpinEnext2(co.right[ 4]); nc[ 8] := FnextEnext(nc[ 7]); nc[ 9] := ClockSpinEnext2(co.right[ 6]); nc[10] := FnextEnext(nc[ 9]); nc[11] := ClockSpinEnext2(co.right[ 8]); (* *) nc[12] := ClockSpinEnext2(co.right[ 1]); nc[13] := FnextEnext(nc[12]); nc[14] := ClockSpinEnext2(co.right[ 3]); (* *) nc[15] := ClockSpinEnext2(co.right[ 0]); ELSIF order = 5 THEN nc[ 0] := ClockSpinEnext2(co.right[16]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := ClockSpinEnext2(co.right[18]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := ClockSpinEnext2(co.right[20]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := ClockSpinEnext2(co.right[22]); nc[ 7] := FnextEnext(nc[ 6]); nc[ 8] := ClockSpinEnext2(co.right[24]); (* *) nc[ 9] := ClockSpinEnext2(co.right[ 9]); nc[10] := FnextEnext(nc[ 9]); nc[11] := ClockSpinEnext2(co.right[11]); nc[12] := FnextEnext(nc[11]); nc[13] := ClockSpinEnext2(co.right[13]); nc[14] := FnextEnext(nc[13]); nc[15] := ClockSpinEnext2(co.right[15]); (* *) nc[16] := ClockSpinEnext2(co.right[ 4]); nc[17] := FnextEnext(nc[16]); nc[18] := ClockSpinEnext2(co.right[ 6]); nc[19] := FnextEnext(nc[18]); nc[20] := ClockSpinEnext2(co.right[ 8]); (* *) nc[21] := ClockSpinEnext2(co.right[ 1]); nc[22] := FnextEnext(nc[21]); nc[23] := ClockSpinEnext2(co.right[ 3]); (* *) nc[24] := ClockSpinEnext2(co.right[ 0]); END END; IF cnum = 15 THEN IF order = 1 THEN nc[ 0] := ClockSpinEnext0(co.left[ 0]); ELSIF order = 2 THEN nc[ 0] := ClockSpinEnext0(co.left[ 0]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := ClockSpinEnext0(co.left[ 1]); (* *) nc[ 3] := ClockSpinEnext0(co.left[ 3]); ELSIF order = 3 THEN nc[ 0] := ClockSpinEnext0(co.left[ 0]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := ClockSpinEnext0(co.left[ 1]); nc[ 3] := FnextEnext(nc[2]); nc[ 4] := ClockSpinEnext0(co.left[ 4]); (* *) nc[ 5] := ClockSpinEnext0(co.left[ 3]); nc[ 6] := FnextEnext(nc[5]); nc[ 7] := ClockSpinEnext0(co.left[ 6]); (* *) nc[ 8] := ClockSpinEnext0(co.left[ 8]); ELSIF order = 4 THEN nc[ 0] := ClockSpinEnext0(co.left[ 0]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := ClockSpinEnext0(co.left[ 1]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := ClockSpinEnext0(co.left[ 4]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := ClockSpinEnext0(co.left[ 9]); (* *) nc[ 7] := ClockSpinEnext0(co.left[ 3]); nc[ 8] := FnextEnext(nc[ 7]); nc[ 9] := ClockSpinEnext0(co.left[ 6]); nc[10] := FnextEnext(nc[ 9]); nc[11] := ClockSpinEnext0(co.left[11]); (* *) nc[12] := ClockSpinEnext0(co.left[ 8]); nc[13] := FnextEnext(nc[12]); nc[14] := ClockSpinEnext0(co.left[13]); (* *) nc[15] := ClockSpinEnext0(co.left[15]); ELSIF order = 5 THEN nc[ 0] := ClockSpinEnext0(co.left[ 0]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := ClockSpinEnext0(co.left[ 1]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := ClockSpinEnext0(co.left[ 4]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := ClockSpinEnext0(co.left[ 9]); nc[ 7] := FnextEnext(nc[ 6]); nc[ 8] := ClockSpinEnext0(co.left[16]); (* *) nc[ 9] := ClockSpinEnext0(co.left[ 3]); nc[10] := FnextEnext(nc[ 9]); nc[11] := ClockSpinEnext0(co.left[ 6]); nc[12] := FnextEnext(nc[11]); nc[13] := ClockSpinEnext0(co.left[11]); nc[14] := FnextEnext(nc[13]); nc[15] := ClockSpinEnext0(co.left[18]); (* *) nc[16] := ClockSpinEnext0(co.left[ 8]); nc[17] := FnextEnext(nc[16]); nc[18] := ClockSpinEnext0(co.left[13]); nc[19] := FnextEnext(nc[18]); nc[20] := ClockSpinEnext0(co.left[20]); (* *) nc[21] := ClockSpinEnext0(co.left[15]); nc[22] := FnextEnext(nc[21]); nc[23] := ClockSpinEnext0(co.left[22]); (* *) nc[24] := ClockSpinEnext0(co.left[24]); END END; IF cnum = 16 THEN IF order = 1 THEN nc[ 0] := ClockSpinEnext1(co.left[ 0]); ELSIF order = 2 THEN nc[ 0] := ClockSpinEnext1(co.left[ 3]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := ClockSpinEnext1(co.left[ 0]); (* *) nc[ 3] := ClockSpinEnext1(co.left[ 1]); ELSIF order = 3 THEN nc[ 0] := ClockSpinEnext1(co.left[ 8]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := ClockSpinEnext1(co.left[ 3]); nc[ 3] := FnextEnext(nc[2]); nc[ 4] := ClockSpinEnext1(co.left[ 0]); (* *) nc[ 5] := ClockSpinEnext1(co.left[ 6]); nc[ 6] := FnextEnext(nc[5]); nc[ 7] := ClockSpinEnext1(co.left[ 1]); (* *) nc[ 8] := ClockSpinEnext1(co.left[ 4]); ELSIF order = 4 THEN nc[ 0] := ClockSpinEnext1(co.left[15]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := ClockSpinEnext1(co.left[ 8]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := ClockSpinEnext1(co.left[ 3]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := ClockSpinEnext1(co.left[ 0]); (* *) nc[ 7] := ClockSpinEnext1(co.left[13]); nc[ 8] := FnextEnext(nc[ 7]); nc[ 9] := ClockSpinEnext1(co.left[ 6]); nc[10] := FnextEnext(nc[ 9]); nc[11] := ClockSpinEnext1(co.left[ 1]); (* *) nc[12] := ClockSpinEnext1(co.left[11]); nc[13] := FnextEnext(nc[12]); nc[14] := ClockSpinEnext1(co.left[ 4]); (* *) nc[15] := ClockSpinEnext1(co.left[ 9]); ELSIF order = 5 THEN nc[ 0] := ClockSpinEnext1(co.left[24]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := ClockSpinEnext1(co.left[15]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := ClockSpinEnext1(co.left[ 8]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := ClockSpinEnext1(co.left[ 3]); nc[ 7] := FnextEnext(nc[ 6]); nc[ 8] := ClockSpinEnext1(co.left[ 0]); (* *) nc[ 9] := ClockSpinEnext1(co.left[22]); nc[10] := FnextEnext(nc[ 9]); nc[11] := ClockSpinEnext1(co.left[13]); nc[12] := FnextEnext(nc[11]); nc[13] := ClockSpinEnext1(co.left[ 6]); nc[14] := FnextEnext(nc[13]); nc[15] := ClockSpinEnext1(co.left[ 1]); (* *) nc[16] := ClockSpinEnext1(co.left[20]); nc[17] := FnextEnext(nc[16]); nc[18] := ClockSpinEnext1(co.left[11]); nc[19] := FnextEnext(nc[18]); nc[20] := ClockSpinEnext1(co.left[ 4]); (* *) nc[21] := ClockSpinEnext1(co.left[18]); nc[22] := FnextEnext(nc[21]); nc[23] := ClockSpinEnext1(co.left[ 9]); (* *) nc[24] := ClockSpinEnext1(co.left[16]); END END; IF cnum = 17 THEN IF order = 1 THEN nc[ 0] := ClockSpinEnext2(co.left[ 0]); ELSIF order = 2 THEN nc[ 0] := ClockSpinEnext2(co.left[ 1]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := ClockSpinEnext2(co.left[ 3]); (* *) nc[ 3] := ClockSpinEnext2(co.left[ 0]); ELSIF order = 3 THEN nc[ 0] := ClockSpinEnext2(co.left[ 4]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := ClockSpinEnext2(co.left[ 6]); nc[ 3] := FnextEnext(nc[2]); nc[ 4] := ClockSpinEnext2(co.left[ 8]); (* *) nc[ 5] := ClockSpinEnext2(co.left[ 1]); nc[ 6] := FnextEnext(nc[5]); nc[ 7] := ClockSpinEnext2(co.left[ 3]); (* *) nc[ 8] := ClockSpinEnext2(co.left[ 0]); ELSIF order = 4 THEN nc[ 0] := ClockSpinEnext2(co.left[ 9]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := ClockSpinEnext2(co.left[11]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := ClockSpinEnext2(co.left[13]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := ClockSpinEnext2(co.left[15]); (* *) nc[ 7] := ClockSpinEnext2(co.left[ 4]); nc[ 8] := FnextEnext(nc[ 7]); nc[ 9] := ClockSpinEnext2(co.left[ 6]); nc[10] := FnextEnext(nc[ 9]); nc[11] := ClockSpinEnext2(co.left[ 8]); (* *) nc[12] := ClockSpinEnext2(co.left[ 1]); nc[13] := FnextEnext(nc[12]); nc[14] := ClockSpinEnext2(co.left[ 3]); (* *) nc[15] := ClockSpinEnext2(co.left[ 0]); ELSIF order = 5 THEN nc[ 0] := ClockSpinEnext2(co.left[16]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := ClockSpinEnext2(co.left[18]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := ClockSpinEnext2(co.left[20]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := ClockSpinEnext2(co.left[22]); nc[ 7] := FnextEnext(nc[ 6]); nc[ 8] := ClockSpinEnext2(co.left[24]); (* *) nc[ 9] := ClockSpinEnext2(co.left[ 9]); nc[10] := FnextEnext(nc[ 9]); nc[11] := ClockSpinEnext2(co.left[11]); nc[12] := FnextEnext(nc[11]); nc[13] := ClockSpinEnext2(co.left[13]); nc[14] := FnextEnext(nc[13]); nc[15] := ClockSpinEnext2(co.left[15]); (* *) nc[16] := ClockSpinEnext2(co.left[ 4]); nc[17] := FnextEnext(nc[16]); nc[18] := ClockSpinEnext2(co.left[ 6]); nc[19] := FnextEnext(nc[18]); nc[20] := ClockSpinEnext2(co.left[ 8]); (* *) nc[21] := ClockSpinEnext2(co.left[ 1]); nc[22] := FnextEnext(nc[21]); nc[23] := ClockSpinEnext2(co.left[ 3]); (* *) nc[24] := ClockSpinEnext2(co.left[ 0]); END END; IF cnum = 18 THEN IF order = 1 THEN nc[ 0] := Enext1(co.front[ 0]); ELSIF order = 2 THEN nc[ 0] := Enext1(co.front[ 3]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := Enext1(co.front[ 0]); (* *) nc[ 3] := Enext1(co.front[ 1]); ELSIF order = 3 THEN nc[ 0] := Enext1(co.front[ 8]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := Enext1(co.front[ 3]); nc[ 3] := FnextEnext(nc[2]); nc[ 4] := Enext1(co.front[ 0]); (* *) nc[ 5] := Enext1(co.front[ 6]); nc[ 6] := FnextEnext(nc[5]); nc[ 7] := Enext1(co.front[ 1]); (* *) nc[ 8] := Enext1(co.front[ 4]); ELSIF order = 4 THEN nc[ 0] := Enext1(co.front[15]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := Enext1(co.front[ 8]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := Enext1(co.front[ 3]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := Enext1(co.front[ 0]); (* *) nc[ 7] := Enext1(co.front[13]); nc[ 8] := FnextEnext(nc[ 7]); nc[ 9] := Enext1(co.front[ 6]); nc[10] := FnextEnext(nc[ 9]); nc[11] := Enext1(co.front[ 1]); (* *) nc[12] := Enext1(co.front[11]); nc[13] := FnextEnext(nc[12]); nc[14] := Enext1(co.front[ 4]); (* *) nc[15] := Enext1(co.front[ 9]); ELSIF order = 5 THEN nc[ 0] := Enext1(co.front[24]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := Enext1(co.front[15]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := Enext1(co.front[ 8]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := Enext1(co.front[ 3]); nc[ 7] := FnextEnext(nc[ 6]); nc[ 8] := Enext1(co.front[ 0]); (* *) nc[ 9] := Enext1(co.front[22]); nc[10] := FnextEnext(nc[ 9]); nc[11] := Enext1(co.front[13]); nc[12] := FnextEnext(nc[11]); nc[13] := Enext1(co.front[ 6]); nc[14] := FnextEnext(nc[13]); nc[15] := Enext1(co.front[ 1]); (* *) nc[16] := Enext1(co.front[20]); nc[17] := FnextEnext(nc[16]); nc[18] := Enext1(co.front[11]); nc[19] := FnextEnext(nc[18]); nc[20] := Enext1(co.front[ 4]); (* *) nc[21] := Enext1(co.front[18]); nc[22] := FnextEnext(nc[21]); nc[23] := Enext1(co.front[ 9]); (* *) nc[24] := Enext1(co.front[16]); END END; IF cnum = 19 THEN IF order = 1 THEN nc[ 0] := Enext0(co.front[ 0]); ELSIF order = 2 THEN nc[ 0] := Enext0(co.front[ 1]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := Enext0(co.front[ 3]); (* *) nc[ 3] := Enext0(co.front[ 0]); ELSIF order = 3 THEN nc[ 0] := Enext0(co.front[ 4]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := Enext0(co.front[ 6]); nc[ 3] := FnextEnext(nc[2]); nc[ 4] := Enext0(co.front[ 8]); (* *) nc[ 5] := Enext0(co.front[ 1]); nc[ 6] := FnextEnext(nc[5]); nc[ 7] := Enext0(co.front[ 3]); (* *) nc[ 8] := Enext0(co.front[ 0]); ELSIF order = 4 THEN nc[ 0] := Enext0(co.front[ 9]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := Enext0(co.front[11]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := Enext0(co.front[13]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := Enext0(co.front[15]); (* *) nc[ 7] := Enext0(co.front[ 4]); nc[ 8] := FnextEnext(nc[ 7]); nc[ 9] := Enext0(co.front[ 6]); nc[10] := FnextEnext(nc[ 9]); nc[11] := Enext0(co.front[ 8]); (* *) nc[12] := Enext0(co.front[ 1]); nc[13] := FnextEnext(nc[12]); nc[14] := Enext0(co.front[ 3]); (* *) nc[15] := Enext0(co.front[ 0]); ELSIF order = 5 THEN nc[ 0] := Enext0(co.front[16]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := Enext0(co.front[18]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := Enext0(co.front[20]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := Enext0(co.front[22]); nc[ 7] := FnextEnext(nc[ 6]); nc[ 8] := Enext0(co.front[24]); (* *) nc[ 9] := Enext0(co.front[ 9]); nc[10] := FnextEnext(nc[ 9]); nc[11] := Enext0(co.front[11]); nc[12] := FnextEnext(nc[11]); nc[13] := Enext0(co.front[13]); nc[14] := FnextEnext(nc[13]); nc[15] := Enext0(co.front[15]); (* *) nc[16] := Enext0(co.front[ 4]); nc[17] := FnextEnext(nc[16]); nc[18] := Enext0(co.front[ 6]); nc[19] := FnextEnext(nc[18]); nc[20] := Enext0(co.front[ 8]); (* *) nc[21] := Enext0(co.front[ 1]); nc[22] := FnextEnext(nc[21]); nc[23] := Enext0(co.front[ 3]); (* *) nc[24] := Enext0(co.front[ 0]); END END; IF cnum = 20 THEN IF order = 1 THEN nc[ 0] := Enext2(co.front[ 0]); ELSIF order = 2 THEN nc[ 0] := Enext2(co.front[ 0]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := Enext2(co.front[ 1]); (* *) nc[ 3] := Enext2(co.front[ 3]); ELSIF order = 3 THEN nc[ 0] := Enext2(co.front[ 0]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := Enext2(co.front[ 1]); nc[ 3] := FnextEnext(nc[2]); nc[ 4] := Enext2(co.front[ 4]); (* *) nc[ 5] := Enext2(co.front[ 3]); nc[ 6] := FnextEnext(nc[5]); nc[ 7] := Enext2(co.front[ 6]); (* *) nc[ 8] := Enext2(co.front[ 8]); ELSIF order = 4 THEN nc[ 0] := Enext2(co.front[ 0]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := Enext2(co.front[ 1]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := Enext2(co.front[ 4]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := Enext2(co.front[ 9]); (* *) nc[ 7] := Enext2(co.front[ 3]); nc[ 8] := FnextEnext(nc[ 7]); nc[ 9] := Enext2(co.front[ 6]); nc[10] := FnextEnext(nc[ 9]); nc[11] := Enext2(co.front[11]); (* *) nc[12] := Enext2(co.front[ 8]); nc[13] := FnextEnext(nc[12]); nc[14] := Enext2(co.front[13]); (* *) nc[15] := Enext2(co.front[15]); ELSIF order = 5 THEN nc[ 0] := Enext2(co.front[ 0]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := Enext2(co.front[ 1]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := Enext2(co.front[ 4]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := Enext2(co.front[ 9]); nc[ 7] := FnextEnext(nc[ 6]); nc[ 8] := Enext2(co.front[16]); (* *) nc[ 9] := Enext2(co.front[ 3]); nc[10] := FnextEnext(nc[ 9]); nc[11] := Enext2(co.front[ 6]); nc[12] := FnextEnext(nc[11]); nc[13] := Enext2(co.front[11]); nc[14] := FnextEnext(nc[13]); nc[15] := Enext2(co.front[18]); (* *) nc[16] := Enext2(co.front[ 8]); nc[17] := FnextEnext(nc[16]); nc[18] := Enext2(co.front[13]); nc[19] := FnextEnext(nc[18]); nc[20] := Enext2(co.front[20]); (* *) nc[21] := Enext2(co.front[15]); nc[22] := FnextEnext(nc[21]); nc[23] := Enext2(co.front[22]); (* *) nc[24] := Enext2(co.front[24]); END END; IF cnum = 21 THEN IF order = 1 THEN nc[ 0] := ClockSpinEnext1(co.back[ 0]); ELSIF order = 2 THEN nc[ 0] := ClockSpinEnext1(co.back[ 0]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := ClockSpinEnext1(co.back[ 3]); (* *) nc[ 3] := ClockSpinEnext1(co.back[ 1]); ELSIF order = 3 THEN nc[ 0] := ClockSpinEnext1(co.back[ 0]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := ClockSpinEnext1(co.back[ 3]); nc[ 3] := FnextEnext(nc[2]); nc[ 4] := ClockSpinEnext1(co.back[ 8]); (* *) nc[ 5] := ClockSpinEnext1(co.back[ 1]); nc[ 6] := FnextEnext(nc[5]); nc[ 7] := ClockSpinEnext1(co.back[ 6]); (* *) nc[ 8] := ClockSpinEnext1(co.back[ 4]); ELSIF order = 4 THEN nc[ 0] := ClockSpinEnext1(co.back[ 0]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := ClockSpinEnext1(co.back[ 3]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := ClockSpinEnext1(co.back[ 8]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := ClockSpinEnext1(co.back[15]); (* *) nc[ 7] := ClockSpinEnext1(co.back[ 1]); nc[ 8] := FnextEnext(nc[ 7]); nc[ 9] := ClockSpinEnext1(co.back[ 6]); nc[10] := FnextEnext(nc[ 9]); nc[11] := ClockSpinEnext1(co.back[13]); (* *) nc[12] := ClockSpinEnext1(co.back[ 4]); nc[13] := FnextEnext(nc[12]); nc[14] := ClockSpinEnext1(co.back[11]); (* *) nc[15] := ClockSpinEnext1(co.back[ 9]); ELSIF order = 5 THEN nc[ 0] := ClockSpinEnext1(co.back[ 0]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := ClockSpinEnext1(co.back[ 3]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := ClockSpinEnext1(co.back[ 8]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := ClockSpinEnext1(co.back[15]); nc[ 7] := FnextEnext(nc[ 6]); nc[ 8] := ClockSpinEnext1(co.back[24]); (* *) nc[ 9] := ClockSpinEnext1(co.back[ 1]); nc[10] := FnextEnext(nc[ 9]); nc[11] := ClockSpinEnext1(co.back[ 6]); nc[12] := FnextEnext(nc[11]); nc[13] := ClockSpinEnext1(co.back[13]); nc[14] := FnextEnext(nc[13]); nc[15] := ClockSpinEnext1(co.back[22]); (* *) nc[16] := ClockSpinEnext1(co.back[ 4]); nc[17] := FnextEnext(nc[16]); nc[18] := ClockSpinEnext1(co.back[11]); nc[19] := FnextEnext(nc[18]); nc[20] := ClockSpinEnext1(co.back[20]); (* *) nc[21] := ClockSpinEnext1(co.back[ 9]); nc[22] := FnextEnext(nc[21]); nc[23] := ClockSpinEnext1(co.back[18]); (* *) nc[24] := ClockSpinEnext1(co.back[16]); END END; IF cnum = 22 THEN IF order = 1 THEN nc[ 0] := ClockSpinEnext2(co.back[ 0]); ELSIF order = 2 THEN nc[ 0] := ClockSpinEnext2(co.back[ 1]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := ClockSpinEnext2(co.back[ 0]); (* *) nc[ 3] := ClockSpinEnext2(co.back[ 3]); ELSIF order = 3 THEN nc[ 0] := ClockSpinEnext2(co.back[ 4]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := ClockSpinEnext2(co.back[ 1]); nc[ 3] := FnextEnext(nc[2]); nc[ 4] := ClockSpinEnext2(co.back[ 0]); (* *) nc[ 5] := ClockSpinEnext2(co.back[ 6]); nc[ 6] := FnextEnext(nc[5]); nc[ 7] := ClockSpinEnext2(co.back[ 3]); (* *) nc[ 8] := ClockSpinEnext2(co.back[ 8]); ELSIF order = 4 THEN nc[ 0] := ClockSpinEnext2(co.back[ 9]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := ClockSpinEnext2(co.back[ 4]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := ClockSpinEnext2(co.back[ 1]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := ClockSpinEnext2(co.back[ 0]); (* *) nc[ 7] := ClockSpinEnext2(co.back[11]); nc[ 8] := FnextEnext(nc[ 7]); nc[ 9] := ClockSpinEnext2(co.back[ 6]); nc[10] := FnextEnext(nc[ 9]); nc[11] := ClockSpinEnext2(co.back[ 3]); (* *) nc[12] := ClockSpinEnext2(co.back[13]); nc[13] := FnextEnext(nc[12]); nc[14] := ClockSpinEnext2(co.back[ 8]); (* *) nc[15] := ClockSpinEnext2(co.back[15]); ELSIF order = 5 THEN nc[ 0] := ClockSpinEnext2(co.back[16]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := ClockSpinEnext2(co.back[ 9]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := ClockSpinEnext2(co.back[ 4]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := ClockSpinEnext2(co.back[ 1]); nc[ 7] := FnextEnext(nc[ 6]); nc[ 8] := ClockSpinEnext2(co.back[ 0]); (* *) nc[ 9] := ClockSpinEnext2(co.back[18]); nc[10] := FnextEnext(nc[ 9]); nc[11] := ClockSpinEnext2(co.back[11]); nc[12] := FnextEnext(nc[11]); nc[13] := ClockSpinEnext2(co.back[ 6]); nc[14] := FnextEnext(nc[13]); nc[15] := ClockSpinEnext2(co.back[ 3]); (* *) nc[16] := ClockSpinEnext2(co.back[20]); nc[17] := FnextEnext(nc[16]); nc[18] := ClockSpinEnext2(co.back[13]); nc[19] := FnextEnext(nc[18]); nc[20] := ClockSpinEnext2(co.back[ 8]); (* *) nc[21] := ClockSpinEnext2(co.back[22]); nc[22] := FnextEnext(nc[21]); nc[23] := ClockSpinEnext2(co.back[15]); (* *) nc[24] := ClockSpinEnext2(co.back[24]); END END; IF cnum = 23 THEN IF order = 1 THEN nc[ 0] := ClockSpinEnext0(co.back[ 0]); ELSIF order = 2 THEN nc[ 0] := ClockSpinEnext0(co.back[ 3]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := ClockSpinEnext0(co.back[ 1]); (* *) nc[ 3] := ClockSpinEnext0(co.back[ 0]); ELSIF order = 3 THEN nc[ 0] := ClockSpinEnext0(co.back[ 8]); nc[ 1] := FnextEnext(nc[0]); nc[ 2] := ClockSpinEnext0(co.back[ 6]); nc[ 3] := FnextEnext(nc[2]); nc[ 4] := ClockSpinEnext0(co.back[ 4]); (* *) nc[ 5] := ClockSpinEnext0(co.back[ 3]); nc[ 6] := FnextEnext(nc[5]); nc[ 7] := ClockSpinEnext0(co.back[ 1]); (* *) nc[ 8] := ClockSpinEnext0(co.back[ 0]); ELSIF order = 4 THEN nc[ 0] := ClockSpinEnext0(co.back[15]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := ClockSpinEnext0(co.back[13]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := ClockSpinEnext0(co.back[11]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := ClockSpinEnext0(co.back[ 9]); (* *) nc[ 7] := ClockSpinEnext0(co.back[ 8]); nc[ 8] := FnextEnext(nc[ 7]); nc[ 9] := ClockSpinEnext0(co.back[ 6]); nc[10] := FnextEnext(nc[ 9]); nc[11] := ClockSpinEnext0(co.back[ 4]); (* *) nc[12] := ClockSpinEnext0(co.back[ 3]); nc[13] := FnextEnext(nc[12]); nc[14] := ClockSpinEnext0(co.back[ 1]); (* *) nc[15] := ClockSpinEnext0(co.back[ 0]); ELSIF order = 5 THEN nc[ 0] := ClockSpinEnext0(co.back[24]); nc[ 1] := FnextEnext(nc[ 0]); nc[ 2] := ClockSpinEnext0(co.back[22]); nc[ 3] := FnextEnext(nc[ 2]); nc[ 4] := ClockSpinEnext0(co.back[20]); nc[ 5] := FnextEnext(nc[ 4]); nc[ 6] := ClockSpinEnext0(co.back[18]); nc[ 7] := FnextEnext(nc[ 6]); nc[ 8] := ClockSpinEnext0(co.back[16]); (* *) nc[ 9] := ClockSpinEnext0(co.back[15]); nc[10] := FnextEnext(nc[ 9]); nc[11] := ClockSpinEnext0(co.back[13]); nc[12] := FnextEnext(nc[11]); nc[13] := ClockSpinEnext0(co.back[11]); nc[14] := FnextEnext(nc[13]); nc[15] := ClockSpinEnext0(co.back[ 9]); (* *) nc[16] := ClockSpinEnext0(co.back[ 8]); nc[17] := FnextEnext(nc[16]); nc[18] := ClockSpinEnext0(co.back[ 6]); nc[19] := FnextEnext(nc[18]); nc[20] := ClockSpinEnext0(co.back[ 4]); (* *) nc[21] := ClockSpinEnext0(co.back[ 3]); nc[22] := FnextEnext(nc[21]); nc[23] := ClockSpinEnext0(co.back[ 1]); (* *) nc[24] := ClockSpinEnext0(co.back[ 0]); END END; RETURN nc; END PairsOnFrontier; BEGIN END Refine. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (* Last edited on 2001-05-21 01:39:20 by stolfi *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/SimpleSpring.m3 MODULE SimpleSpring; (* Last Modification: 18-11-2000 *) IMPORT LR4, Triangulation, Fmt; FROM Triangulation IMPORT Topology, OrgV; FROM Octf IMPORT Clock; FROM Energy IMPORT Coords, Gradient; TYPE BOOLS = ARRAY OF BOOLEAN; LONGS = ARRAY OF LONGREAL; REVEAL T = Public BRANDED OBJECT K: LONGREAL; (* The energy normalization factor *) top: Topology; (* The topology *) termVar: REF BOOLS; (* TRUE if vertex is variable & existing *) edgeRelevant: REF BOOLS; (* TRUE if edge is relevant *) eDdif: REF LONGS (* (Work) Gradient of "e" rel. to "dif" *) OVERRIDES init := Init; defTop := DefTop; defVar := DefVar; eval := Eval; name := Name; END; PROCEDURE Init(erg: T): T = BEGIN RETURN erg END Init; PROCEDURE DefTop(erg: T; READONLY top: Topology) = BEGIN erg.K := 1.0d0; erg.top := top; erg.termVar := NEW(REF BOOLS, top.NV); erg.edgeRelevant := NEW(REF BOOLS, top.NE); erg.eDdif := NEW(REF LONGS, top.NE); (* Just in case the client forgets to call "defVar": *) FOR i := 0 TO top.NV-1 DO erg.termVar^[i] := FALSE END; FOR j := 0 TO top.NE-1 DO erg.edgeRelevant^[j] := FALSE END; END DefTop; PROCEDURE DefVar(erg: T; READONLY variable: BOOLS) = BEGIN (* Decide which edges are relevant to spring energy. A edge is relevant iff it has at least one endpoint vertex that is variable. *) WITH NV = erg.top.NV, NE = erg.top.NE, termVar = erg.termVar^, edge = erg.top.edge^, edgeRelevant = erg.edgeRelevant^ DO <* ASSERT NUMBER(variable) = NV *> FOR v := 0 TO NV-1 DO termVar[v] := variable[v]; END; (* Find the relevant edges : *) FOR k := 0 TO NE-1 DO edgeRelevant[k] := FALSE END; FOR k := 0 TO NE-1 DO WITH e = edge[k], u = NARROW(OrgV(e.pa), Triangulation.Vertex), v = NARROW(OrgV(Clock(e.pa)), Triangulation.Vertex), vvar = termVar[u.num] OR termVar[v.num] DO IF vvar THEN edgeRelevant[k] := TRUE; END END END END END DefVar; PROCEDURE Eval( erg: T; READONLY c: Coords; VAR e: LONGREAL; grad: BOOLEAN; VAR eDc: Gradient; ) = BEGIN WITH NV = erg.top.NV, NE = erg.top.NE, edge = erg.top.edge^, edgeRelevant = erg.edgeRelevant^, K = erg.K, L = FLOAT(erg.length, LONGREAL), eDdif = erg.eDdif^, termVar = erg.termVar DO PROCEDURE AccumTerm(READONLY cu,cv: LR4.T; VAR eDdif : LONGREAL) = (* Adds to "e" the energy term corresponding to a vertices "cv" and "cu". Returns also the gradient "eDdif". *) CONST Epsilon = 1.0d-10; BEGIN WITH n = LR4.Sub(cu,cv), dif = LR4.Norm(n), d2 = dif * dif + Epsilon, l2 = L * L + Epsilon, d3 = d2 * dif + Epsilon DO e := e + K * ((d2/l2) + (l2/d2) - 2.0d0); IF grad THEN eDdif := 2.0d0 * K * ((dif/l2)-(l2/d3) ); ELSE eDdif := 0.0d0; END END END AccumTerm; PROCEDURE Distribute_eDdif(READONLY u,v: CARDINAL; READONLY eDdif: LONGREAL) = (* Distribute eDdif on endpoints "c[u]" and "c[v]" *) CONST Epsilon = 1.0d-10; BEGIN WITH cu = c[u], cv = c[v], n = LR4.Sub(cu,cv), dif = LR4.Norm(n)+Epsilon, eDv = eDc[v], eDu = eDc[u] DO WITH difDcu = LR4.Scale(1.0d0/dif, n), difDcv = LR4.Scale(-1.0d0/dif,n), eDcu = LR4.Scale(eDdif, difDcu), eDcv = LR4.Scale(eDdif, difDcv) DO IF termVar[v] THEN eDv := LR4.Add(eDv, eDcv); END; IF termVar[u] THEN eDu := LR4.Add(eDu, eDcu); END END END END Distribute_eDdif; BEGIN FOR i := 0 TO NV-1 DO eDc[i]:=LR4.T{0.0d0, 0.0d0, 0.0d0, 0.0d0} END; e := 0.0d0; FOR k := 0 TO NE-1 DO WITH e = edge[k], un = OrgV(e.pa).num, vn = OrgV(Clock(e.pa)).num DO IF edgeRelevant[k] THEN AccumTerm(c[un], c[vn], eDdif[k]); IF grad THEN Distribute_eDdif(un, vn, eDdif[k]); END END END END END END END Eval; PROCEDURE Name(erg: T): TEXT = BEGIN RETURN "SimpleSpring(iLen := " & Fmt.Real(erg.length,Fmt.Style.Fix,prec := 3) & ")" END Name; BEGIN END SimpleSpring. (* Last edited on 2001-05-21 02:27:52 by stolfi *) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/SpreadEnergy.m3 MODULE SpreadEnergy; IMPORT LR4; FROM Triangulation IMPORT Topology; FROM Energy IMPORT Coords, Gradient; REVEAL T = Public BRANDED OBJECT top: Topology; (* The topology *) K: LONGREAL; (* Energy normalization constant *) (* Defined by "defVar: *) termVar: REF ARRAY OF BOOLEAN; (* Tells which terms are variable *) OVERRIDES init := Init; defTop := DefTop; defVar := DefVar; eval := Eval; name := Name; END; PROCEDURE Init(erg: T): T = BEGIN RETURN erg END Init; PROCEDURE DefTop(erg: T; READONLY top: Topology) = BEGIN erg.top := top; erg.K := 1.0d0/FLOAT(top.NV, LONGREAL); erg.termVar := NEW(REF ARRAY OF BOOLEAN, top.NV); (* In case the client forgets to call "defVar": *) FOR i := 0 TO LAST(erg.termVar^) DO erg.termVar^[i] := FALSE END; END DefTop; PROCEDURE DefVar(erg: T; READONLY variable: ARRAY OF BOOLEAN) = BEGIN (* There is a term for each existing vertex. The term of "v" is variable (termVar[v] = TRUE) if "v" is variable (variable[v] = TRUE). A vertex contributes to the energy only if "termVar[v] = TRUE", i.e. if "v" exists and "v" is variable. *) WITH NV = erg.top.NV, vertex = erg.top.vertex^, termVar = erg.termVar^ DO <* ASSERT NUMBER(variable) = NV *> FOR v := 0 TO NV-1 DO termVar[v] := variable[v] AND vertex[v].exists END; END END DefVar; PROCEDURE Eval( erg: T; READONLY c: Coords; VAR e: LONGREAL; grad: BOOLEAN; VAR eDc: Gradient; ) = BEGIN WITH NV = erg.top.NV, termVar = erg.termVar^, K = erg.K DO PROCEDURE AccumTerm(READONLY cv: LR4.T; VAR evDcv: LR4.T ) = (* Adds to "e" the energy term corresponding to a vertex at "cv". Returns also the gradient "evDcv" of that term relative to "cv". *) BEGIN e := e + K * LR4.NormSqr(cv); IF grad THEN evDcv := LR4.Scale(2.0d0 * K, cv) ELSE evDcv := LR4.T{0.0d0, 0.0d0, 0.0d0, 0.0d0}; END; END AccumTerm; BEGIN e := 0.0d0; FOR v := 0 TO NV-1 DO IF termVar[v] THEN AccumTerm(c[v], eDc[v]); ELSE eDc[v] := LR4.T{0.0d0, 0.0d0, 0.0d0, 0.0d0}; END; END; END; END END Eval; PROCEDURE Name(<*UNUSED*> erg: T): TEXT = BEGIN RETURN "Spread()" END Name; BEGIN END SpreadEnergy. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Squared.m3 MODULE Squared; (* This module contain procedures to build several structures such as: n-gons, triangles and squares, and solid polyhedra: cube, ball, bigcube (3D array of cube) with procedures for the gluing two such bigcubes. Revisions: 30-08-2000 : Nice version of the "MakeOctahedron" procedure. 19-09-2000 : Added the procedure "MakeDodecahedronTriang". 27-10-2000 : Modified "SetCubePropiertes" procedure. 04-11-2000 : Added the "CubeNegVertices" and "CubeBarycenter" procedures. *) IMPORT Octf, Triangulation, Tools, LR4; FROM Octf IMPORT Enext_1, Clock, SetEnext, SetFace, Fnext, Enext, SetFnext, SetEdge, SetEdgeAll, Fnext_1, Spin, Srot; FROM Triangulation IMPORT Pair, Org, MakeVertex, SetOrg, MakeFacetEdge, Pneg, SetAllOrgs, OrgV, SetAllPneg, MakePolyhedron, Node, SetPneg, Vertex, SetNextPneg, Glue, DegreeOfVertex, Ppos, MakeTetraTopo, Topology, Coords; TYPE PAIRS = ARRAY[0..3] OF Pair; VAR FacetEdgeCount: CARDINAL := 0; PolyhedronCount: CARDINAL := 0; PROCEDURE MakeTriangle() : Pair = (* Builds a triangular face and set the three pairs facetedges with the same face component. *) BEGIN WITH a = MakeFacetEdge(), b = MakeFacetEdge(), c = MakeFacetEdge(), f = a.facetedge.face, u = MakeVertex(), v = MakeVertex(), w = MakeVertex() DO a.facetedge.num := FacetEdgeCount; INC(FacetEdgeCount); SetOrg(a, u); SetOrg(Clock(a),v); b.facetedge.num := FacetEdgeCount; INC(FacetEdgeCount); SetEnext(a,b); SetFace(b,f); SetOrg(b,v); SetOrg(Clock(b),w); c.facetedge.num := FacetEdgeCount; INC(FacetEdgeCount); SetEnext(b,c); SetFace(c,f); SetOrg(c, w); SetOrg(Clock(c), Org(a)); RETURN a; END END MakeTriangle; PROCEDURE MakeGon(n: CARDINAL) : Pair = (* Builds one n-gon face. The "n-pairs" have the same face component.*) VAR sp : REF ARRAY OF Pair; sv : REF ARRAY OF Vertex; BEGIN sp := NEW(REF ARRAY OF Pair,n); sv := NEW(REF ARRAY OF Vertex,n); FOR i := 0 TO n-1 DO sp[i] := MakeFacetEdge(); sv[i] := MakeVertex(); END; WITH f = sp[0].facetedge.face DO FOR i := 0 TO n-1 DO sp[i].facetedge.num := FacetEdgeCount; INC(FacetEdgeCount); SetOrg(sp[i],sv[i]); SetOrg(Clock(sp[i]),sv[(i+1) MOD n]); SetEnext(sp[i],sp[(i+1) MOD n]); SetFace(sp[i],f); END END; RETURN sp[0]; END MakeGon; PROCEDURE MakeGonFull(n: CARDINAL) : REF ARRAY OF Pair = (* Builds one n-gon face. The "n-pairs" have the same face component.*) VAR sp : REF ARRAY OF Pair; sv : REF ARRAY OF Vertex; BEGIN sp := NEW(REF ARRAY OF Pair,n); sv := NEW(REF ARRAY OF Vertex,n); FOR i := 0 TO n-1 DO sp[i] := MakeFacetEdge(); sv[i] := MakeVertex(); END; WITH f = sp[0].facetedge.face DO FOR i := 0 TO n-1 DO sp[i].facetedge.num := FacetEdgeCount; INC(FacetEdgeCount); SetOrg(sp[i],sv[i]); SetOrg(Clock(sp[i]),sv[(i+1) MOD n]); SetEnext(sp[i],sp[(i+1) MOD n]); SetFace(sp[i],f); END END; RETURN sp; END MakeGonFull; PROCEDURE MakeSquare() : Pair = (* Builds one squared face. The four "pairs" have the same face component.*) BEGIN WITH a = MakeFacetEdge(), b = MakeFacetEdge(), c = MakeFacetEdge(), d = MakeFacetEdge(), f = a.facetedge.face, u = MakeVertex(), v = MakeVertex(), w = MakeVertex(), x = MakeVertex() DO a.facetedge.num := FacetEdgeCount; INC(FacetEdgeCount); SetOrg(a, u); SetOrg(Clock(a),v); b.facetedge.num := FacetEdgeCount; INC(FacetEdgeCount); SetEnext(a,b); SetFace(b,f); SetOrg(b,v); SetOrg(Clock(b),w); c.facetedge.num := FacetEdgeCount; INC(FacetEdgeCount); SetEnext(b,c); SetFace(c,f); SetOrg(c, w); SetOrg(Clock(c), x); d.facetedge.num := FacetEdgeCount; INC(FacetEdgeCount); SetEnext(c,d); SetFace(d,f); SetOrg(d, x); SetOrg(Clock(d), Org(a)); RETURN a; END END MakeSquare; PROCEDURE MakeHalfOct( ) : ARRAY[0..3] OF Pair = (* Builds half octahedron without polyhedron information. *) VAR p : ARRAY[0..3] OF Pair; BEGIN FOR i := 0 TO 3 DO p[i] := MakeTriangle(); END; FOR i := 0 TO 3 DO WITH a = Enext(p[i]), b = Clock(Enext_1(p[(i+1) MOD 4])) DO SetFnext(a,b); SetEdgeAll(a,a.facetedge.edge); END END; FOR i := 0 TO 3 DO SetAllOrgs(Enext_1(p[i]), Org(Enext_1(p[i]))); END; RETURN p; END MakeHalfOct; PROCEDURE MakeOctahedron( ) : ARRAY[0..7] OF Pair = (* Builds a topological octahedron, and return one pair facetedge "p[i]" for each face of the octahedron. *) VAR p : ARRAY [0..7] OF Pair; s,i : ARRAY [0..3] OF Pair; BEGIN s := MakeHalfOct(); i := MakeHalfOct(); (* builds an octahedron with two half-octahedra "s" (superior) and "i" (inferior). *) FOR j := 0 TO 3 DO p[j] := s[j]; END; FOR j := 4 TO 7 DO p[j] := i[j-4]; END; (* Set the common elements *) FOR j := 0 TO 3 DO SetFnext(p[j],p[j+4]); SetEdgeAll(p[j],p[j].facetedge.edge); SetAllOrgs(p[j], Org(p[j])); SetAllOrgs(Enext(p[j]), Org(Enext(p[j]))); END; (* set the polyhedron attribute, 24 facet-edges have the same polyhedron. *) WITH q = MakePolyhedron() DO q.num := PolyhedronCount; INC(PolyhedronCount); FOR i := 0 TO 7 DO SetNextPneg(p[i],q); END END; (* this test is apply for assert that any pair facetedge "p[i]" really underly on a topological octahedron.*) FOR i := 0 TO 7 DO WITH d = DegreeOfVertex(Srot(p[i])) DO <* ASSERT d = 8 *> END; END; RETURN p; END MakeOctahedron; PROCEDURE SetRingFaceExis(a: Pair; faceExists: BOOLEAN) = (* Set the face as existing or not. *) PROCEDURE SetFace(b: Pair) = BEGIN WITH t = NARROW(b.facetedge.face, Triangulation.Face) DO t.exists := faceExists; END END SetFace; VAR an: Pair := a; BEGIN REPEAT SetFace(an); an := Fnext(an) UNTIL an = a END SetRingFaceExis; PROCEDURE SetEdgeExis(a: Pair; edgeExists: BOOLEAN) = (* Set the edge as existing or not . *) BEGIN WITH e = NARROW(a.facetedge.edge, Triangulation.Edge) DO e.exists := edgeExists; END END SetEdgeExis; PROCEDURE SetVertexExis(a: Pair) = (* Set the vertex as not existing. *) BEGIN WITH v = NARROW(Org(a), Vertex) DO v.exists := FALSE; END END SetVertexExis; PROCEDURE MakeOctahedronTriang(Original: BOOLEAN) : ARRAY[0..7] OF Pair = (* Builds a triangulated octahedron, with eight tetrahedra, and return one facet-edge pair by original face. If Original=TRUE the procedure emphasize the original elements. *) VAR a : ARRAY[0..7] OF ARRAY[0..7] OF Pair; b : ARRAY[0..7] OF Pair; BEGIN FOR i := 0 TO 7 DO a[i] := Triangulation.MakeTetraTopo(1,1); END; (* first level gluing tetrahedra *) EVAL Glue(Spin(a[1][1]),a[0][0],1); EVAL Glue(Spin(a[2][1]),a[1][0],1); EVAL Glue(Spin(a[3][1]),a[2][0],1); EVAL Glue(Spin(a[0][1]),a[3][0],1); (* second level gluing tetrahedra *) EVAL Glue(Spin(a[0][3]),a[4][2],1); EVAL Glue(Spin(a[1][3]),a[5][2],1); EVAL Glue(Spin(a[2][3]),a[6][2],1); EVAL Glue(Spin(a[3][3]),a[7][2],1); (* gluing between levels *) EVAL Glue(Spin(a[5][1]),a[4][0],1); EVAL Glue(Spin(a[6][1]),a[5][0],1); EVAL Glue(Spin(a[7][1]),a[6][0],1); EVAL Glue(Spin(a[4][1]),a[7][0],1); IF Original THEN (* emphasize the original elements *) SetRingFaceExis(a[0][1],FALSE); SetRingFaceExis(a[4][1],FALSE); SetEdgeExis(a[0][1],FALSE); SetEdgeExis(a[4][1],FALSE); FOR i := 0 TO 3 DO SetRingFaceExis(Enext(a[i][1]),FALSE); END; FOR i := 4 TO 7 DO SetEdgeExis(Enext_1(a[i][1]),FALSE); END; SetVertexExis(a[4][1]); END; b[0] := a[0][2]; b[1] := a[1][2]; b[2] := a[2][2]; b[3] := a[3][2]; b[4] := a[4][3]; b[5] := a[5][3]; b[6] := a[6][3]; b[7] := a[7][3]; RETURN b; END MakeOctahedronTriang; <* UNUSED *> PROCEDURE OldMakeIcosahedronTriang( ) : ARRAY[0..19] OF Pair = (* Prior version of the "MakeIcosahedronTriang": Builds a triangualted icosahedron, with twenty tetrahedra, and return one facet-edge pair by original face (i.e. 20). *) VAR a : ARRAY[0..19] OF ARRAY[0..7] OF Pair; b : ARRAY[0..19] OF Pair; (* this variable will be retuned *) BEGIN FOR i := 0 TO 19 DO a[i] := MakeTetraTopo(1,1); END; (* first level *) EVAL Glue(Spin(a[1][1]),a[0][0],1); EVAL Glue(Spin(a[2][1]),a[1][0],1); EVAL Glue(Spin(a[3][1]),a[2][0],1); EVAL Glue(Spin(a[4][1]),a[3][0],1); EVAL Glue(Spin(a[0][1]),a[4][0],1); (* next level *) EVAL Glue(Spin(a[0][3]),a[5][2],1); EVAL Glue(Spin(a[1][3]),a[6][2],1); EVAL Glue(Spin(a[2][3]),a[7][2],1); EVAL Glue(Spin(a[3][3]),a[8][2],1); EVAL Glue(Spin(a[4][3]),a[9][2],1); EVAL Glue(Spin(a[10][1]),a[5][0],1); EVAL Glue(Spin(a[6][1]),Enext_1(a[10][7]),1); EVAL Glue(Spin(a[11][1]),a[6][0],1); EVAL Glue(Spin(a[7][1]),Enext_1(a[11][7]),1); EVAL Glue(Spin(a[12][1]),a[7][0],1); EVAL Glue(Spin(a[8][1]),Enext_1(a[12][7]),1); EVAL Glue(Spin(a[13][1]),a[8][0],1); EVAL Glue(Spin(a[9][1]),Enext_1(a[13][7]),1); EVAL Glue(Spin(a[14][1]),a[9][0],1); EVAL Glue(Spin(a[5][1]),Enext_1(a[14][7]),1); (* Last level *) EVAL Glue(Spin(Enext(a[10][0])),a[15][2],1); EVAL Glue(Spin(Enext(a[11][0])),a[16][2],1); EVAL Glue(Spin(Enext(a[12][0])),a[17][2],1); EVAL Glue(Spin(Enext(a[13][0])),a[18][2],1); EVAL Glue(Spin(Enext(a[14][0])),a[19][2],1); EVAL Glue(Spin(a[16][1]),a[15][0],1); EVAL Glue(Spin(a[17][1]),a[16][0],1); EVAL Glue(Spin(a[18][1]),a[17][0],1); EVAL Glue(Spin(a[19][1]),a[18][0],1); EVAL Glue(Spin(a[15][1]),a[19][0],1); FOR i := 0 TO 4 DO b[i] := a[i,2] END; FOR i := 5 TO 9 DO b[i] := a[i,3] END; FOR i := 10 TO 14 DO b[i] := a[i,3] END; FOR i := 15 TO 19 DO b[i] := a[i,3] END; RETURN b; END OldMakeIcosahedronTriang; PROCEDURE MakeIcosahedronTriang(Original: BOOLEAN) : ARRAY[0..19] OF Pair = (* Builds a triangualted icosahedron, with twenty tetrahedra, and return one facet-edge pair by original face (i.e. 20). If Original=TRUE the pro- cedure emphasize the original elements. *) VAR a : ARRAY[0..19] OF ARRAY[0..7] OF Pair; b : ARRAY[0..19] OF Pair; (* this variable will be retuned *) BEGIN FOR i := 0 TO 19 DO a[i] := MakeTetraTopo(1,1); END; (* inside the first level *) EVAL Glue(Spin(a[1][1]),a[0][0],1); EVAL Glue(Spin(a[2][1]),a[1][0],1); EVAL Glue(Spin(a[3][1]),a[2][0],1); EVAL Glue(Spin(a[4][1]),a[3][0],1); EVAL Glue(Spin(a[0][1]),a[4][0],1); (* between the first and second level *) EVAL Glue(Spin(a[0][3]),a[5][2],1); EVAL Glue(Spin(a[1][3]),a[6][2],1); EVAL Glue(Spin(a[2][3]),a[7][2],1); EVAL Glue(Spin(a[3][3]),a[8][2],1); EVAL Glue(Spin(a[4][3]),a[9][2],1); (* inside the second level *) EVAL Glue(Spin(Enext(a[10][1])), a[5][0], 1); EVAL Glue(Spin(a[6][1]), Enext(a[10][0]),1); EVAL Glue(Spin(Enext(a[11][1])), a[6][0], 1); EVAL Glue(Spin(a[7][1]), Enext(a[11][0]),1); EVAL Glue(Spin(Enext(a[12][1])), a[7][0], 1); EVAL Glue(Spin(a[8][1]), Enext(a[12][0]),1); EVAL Glue(Spin(Enext(a[13][1])), a[8][0], 1); EVAL Glue(Spin(a[9][1]), Enext(a[13][0]),1); EVAL Glue(Spin(Enext(a[14][1])), a[9][0], 1); EVAL Glue(Spin(a[5][1]), Enext(a[14][0]),1); (* between the second and third level *) EVAL Glue (Spin(a[10][3]), a[15][2],1); EVAL Glue (Spin(a[11][3]), a[16][2],1); EVAL Glue (Spin(a[12][3]), a[17][2],1); EVAL Glue (Spin(a[13][3]), a[18][2],1); EVAL Glue (Spin(a[14][3]), a[19][2],1); (* inside the third level *) EVAL Glue(Spin(a[16][1]),a[15][0],1); EVAL Glue(Spin(a[17][1]),a[16][0],1); EVAL Glue(Spin(a[18][1]),a[17][0],1); EVAL Glue(Spin(a[19][1]),a[18][0],1); EVAL Glue(Spin(a[15][1]),a[19][0],1); (* Rescue the pairs to be returned *) FOR i := 0 TO 4 DO b[i] := a[i,2] END; FOR i := 5 TO 9 DO b[i] := a[i,3] END; FOR i := 10 TO 14 DO b[i] := a[i,2] END; FOR i := 15 TO 19 DO b[i] := a[i,3] END; IF Original THEN (* emphasize the original elements *) SetRingFaceExis(a[0][1],FALSE); SetEdgeExis(a[0][1],FALSE); SetRingFaceExis(a[15][1],FALSE); SetEdgeExis(a[15][1],FALSE); SetVertexExis(a[15][1]); FOR i := 0 TO 4 DO SetRingFaceExis(Enext(a[i][1]),FALSE); END; FOR i := 5 TO 9 DO SetEdgeExis(Enext_1(a[i][1]),FALSE); END; FOR i := 15 TO 19 DO SetRingFaceExis(Enext_1(a[i][1]),FALSE); SetEdgeExis(Enext_1(a[i][1]),FALSE); END END; (* some assertions *) FOR i := 0 TO 4 DO <* ASSERT Fnext(b[i+5]) = Spin(b[i]) *> END; FOR i := 10 TO 14 DO <* ASSERT Fnext(b[i+5]) = Spin(b[i]) *> END; RETURN b; END MakeIcosahedronTriang; PROCEDURE MakeDodecahedronTriang( Original: BOOLEAN; ) : ARRAY[0..11] OF ARRAY [0..4] OF Pair = (* Builds a triangulated Dodecahedron, with 60 tetrahedra, trough the automatic gluing of tetrahedra. If Original=TRUE the procedure empha- size the original elements. *) TYPE Row4I = ARRAY[0..3] OF CARDINAL; VAR cell4 : REF ARRAY OF Row4I; tetra : REF ARRAY OF ARRAY [0..3] OF Pair; cellnum: CARDINAL; dode : ARRAY[0..11] OF ARRAY [0..4] OF Pair; PROCEDURE Gluing(Ti,Tj,Ci,Cj: CARDINAL) : Pair = (* Gluing the tetrahedra Ti with Tj through the free faces Ci and Cj respectively. *) BEGIN IF (* 1 *) Ci = 0 AND Cj = 0 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1], Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Dj) AND (Di=Oj) THEN EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; ELSIF (* 2 *) Ci = 0 AND Cj = 1 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1], Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi = Oj) AND (Di = Dj) THEN EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; ELSIF (* 3 *) Ci = 0 AND Cj = 2 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1], Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi = Oj) AND (Di = Dj) THEN EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END ELSIF (* 4 *) Ci = 0 AND Cj = 3 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1], Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi = Dj) AND (Di = Oj) THEN EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; ELSIF (* 5 *) Ci = 1 AND Cj = 0 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1], Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi = Oj) AND (Di = Dj) THEN EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; ELSIF (* 6 *) Ci = 1 AND Cj = 1 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1], Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Dj) AND (Di=Oj) THEN EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; ELSIF (* 7 *) Ci = 1 AND Cj = 2 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1], Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi=Dj) AND (Di=Oj) THEN EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; ELSIF (* 8 *) Ci = 1 AND Cj = 3 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1], Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi = Oj) AND (Di = Dj) THEN EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; ELSIF (* 9 *) Ci = 2 AND Cj = 0 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3], Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Oj) AND (Di=Dj) THEN EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; ELSIF (* 10 *) Ci = 2 AND Cj = 1 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3], Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Dj) AND (Di=Oj) THEN EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; ELSIF (* 11 *) Ci = 2 AND Cj = 2 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3], Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi=Dj) AND (Di=Oj) THEN EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; ELSIF (* 12 *) Ci = 2 AND Cj = 3 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3], Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi=Oj) AND (Di=Dj) THEN EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; ELSIF (* 13 *) Ci = 3 AND Cj = 0 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3], Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Dj) AND (Di=Oj) THEN EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; ELSIF (* 14 *) Ci = 3 AND Cj = 1 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3], Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Oj) AND (Di=Dj) THEN EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; ELSIF (* 15 *) Ci = 3 AND Cj = 2 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3], Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi=Oj) AND (Di=Dj) THEN EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END ELSIF (* 16 *) Ci = 3 AND Cj = 3 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3], Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi=Dj) AND (Di=Oj) THEN EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END END; RETURN tetra[Ti,0]; END Gluing; PROCEDURE SetCornersTetra(Ti: CARDINAL; row: Row4I) = (* Set the labels "row" in the tetrahedron Ti. *) BEGIN WITH a = OrgV(tetra[Ti,0]), b = OrgV(Clock(tetra[Ti,0])), c = OrgV(Enext_1(tetra[Ti,1])), d = OrgV(Enext_1(tetra[Ti,0])) DO a.num := row[0]; b.num := row[1]; c.num := row[2]; d.num := row[3]; END; END SetCornersTetra; PROCEDURE SetGhostVertex(Ti: CARDINAL; node:CARDINAL) = (* Set one vertex onto the tetrahedra "Ti" as non-existing.*) BEGIN WITH a = OrgV(tetra[Ti,0]), b = OrgV(Clock(tetra[Ti,0])), c = OrgV(Enext_1(tetra[Ti,1])), d = OrgV(Enext_1(tetra[Ti,0])) DO IF a.num = node THEN a.exists := FALSE; END; IF b.num = node THEN b.exists := FALSE; END; IF c.num = node THEN c.exists := FALSE; END; IF d.num = node THEN d.exists := FALSE; END END END SetGhostVertex; PROCEDURE SetGhostEdge(Ti: CARDINAL; node:CARDINAL) = (* Set all edges incidents in the vertex "node" as non-existing.*) BEGIN WITH a = OrgV(tetra[Ti,0]).num, b = OrgV(Clock(tetra[Ti,0])).num, c = OrgV(Enext_1(tetra[Ti,1])).num, d = OrgV(Enext_1(tetra[Ti,0])).num, e0 = tetra[Ti,0].facetedge.edge, e1 = tetra[Ti,2].facetedge.edge, e2 = Enext (tetra[Ti,2]).facetedge.edge, e3 = Enext_1(tetra[Ti,2]).facetedge.edge, e4 = Enext (tetra[Ti,0]).facetedge.edge, e5 = Enext (tetra[Ti,1]).facetedge.edge DO IF a = node OR b = node THEN e0.exists := FALSE; END; IF c = node OR d = node THEN e1.exists := FALSE; END; IF a = node OR d = node THEN e2.exists := FALSE; END; IF a = node OR c = node THEN e3.exists := FALSE; END; IF b = node OR d = node THEN e4.exists := FALSE; END; IF b = node OR c = node THEN e5.exists := FALSE; END; END END SetGhostEdge; PROCEDURE SaveFreeCorners() = (* Save the free corners on the triangulated dodecahedron, such allow us to use this polyhedron as the unglued scheme for the 3D maps obtained by the gluing of opposite faces on the dode- cahedron. *) PROCEDURE AssignmentOnFace(b: Pair; i: CARDINAL) = BEGIN IF Octf.SpinBit(b) = 0 THEN dode[i,0] := b; FOR j := 1 TO 4 DO dode[i,j] := Clock(Enext(Fnext(Enext_1(dode[i,j-1])))); END; ELSIF Octf.SpinBit(b) = 1 THEN dode[i,0] := b; FOR j := 1 TO 4 DO dode[i,j] := Clock(Enext_1(Fnext(Enext(dode[i,j-1])))); END END END AssignmentOnFace; VAR m,n: CARDINAL := 0; BEGIN FOR i := 0 TO 59 DO FOR j := 0 TO 3 DO WITH a = tetra[i,j], d = Octf.DegreeFaceRing(a) DO IF d # 1 AND Ppos(a) = NIL THEN dode[m,n] := tetra[i,j]; INC(n); IF n = 5 THEN INC(m); n := 0; END; END END END END; WITH a = dode[0,0] DO AssignmentOnFace(a,0) END; dode[1,0] := Spin(Fnext(dode[0,0])); AssignmentOnFace(dode[1,0],1); dode[2,0] := Spin(Fnext(dode[0,4])); AssignmentOnFace(dode[2,0],2); dode[3,0] := Spin(Fnext(dode[0,3])); AssignmentOnFace(dode[3,0],3); dode[4,0] := Spin(Fnext(dode[0,2])); AssignmentOnFace(dode[4,0],4); dode[5,0] := Spin(Fnext(dode[0,1])); AssignmentOnFace(dode[5,0],5); dode[8, 0] := Spin(Fnext(dode[4,2])); AssignmentOnFace(dode[8,0],8); dode[6, 0] := Spin(Fnext(dode[8,3])); AssignmentOnFace(dode[6,0],6); dode[7, 0] := Spin(Fnext(dode[6,1])); AssignmentOnFace(dode[7,0], 7); dode[9, 0] := Spin(Fnext(dode[6,4])); AssignmentOnFace(dode[9,0], 9); dode[10,0] := Spin(Fnext(dode[6,3])); AssignmentOnFace(dode[10,0],10); dode[11,0] := Spin(Fnext(dode[6,2])); AssignmentOnFace(dode[11,0],11); (* the free corners are computed follows the scheme bellow: /|\ /|\ / | \ / | \ / | \ / | \ / 3 | 2 \ / 3 | 2 \ / | \ / | \ /-----|-----\ /-----|-----\ \ 4 / \ 1 / \ 4 / \ 1 / \ / 0 \ / \ / 0 \ / \/_____\/ \/_____\/ <--- ---> SpinBit = 0 SpinBit = 1 *) END SaveFreeCorners; PROCEDURE SetGhostFace(Ti: CARDINAL; node: CARDINAL) = (* Set all facese incidents in the vertex "node" as non-existing.*) BEGIN WITH a = OrgV(tetra[Ti,0]).num, b = OrgV(Clock(tetra[Ti,0])).num, c = OrgV(Enext_1(tetra[Ti,1])).num, d = OrgV(Enext_1(tetra[Ti,0])).num, f0 = tetra[Ti,0].facetedge.face, f1 = tetra[Ti,1].facetedge.face, f2 = tetra[Ti,2].facetedge.face, f3 = tetra[Ti,3].facetedge.face DO IF a = node OR b = node OR d = node THEN f0.exists := FALSE; END; IF a = node OR b = node OR c = node THEN f1.exists := FALSE; END; IF a = node OR c = node OR d = node THEN f2.exists := FALSE; END; IF b = node OR c = node OR d = node THEN f3.exists := FALSE; END END END SetGhostFace; PROCEDURE MustBeGlue(Ti,Tj: Pair) : BOOLEAN = (* Return TRUE if the faces "Ti.facetedge.face" and "Tj.facetedge.face" have coherent orientations and must be glued. *) BEGIN WITH a = OrgV(Ti).num, ae = OrgV(Enext(Ti)).num, ae_1 = OrgV(Enext_1(Ti)).num, b = OrgV(Tj).num, be = OrgV(Enext(Tj)).num, be_1 = OrgV(Enext_1(Tj)).num DO IF (a = b AND ae = be AND ae_1 = be_1) OR (a = b AND ae = be_1 AND ae_1 = be) THEN RETURN TRUE END; RETURN FALSE END; END MustBeGlue; PROCEDURE EnextK(Ti: Pair; k : CARDINAL) : Pair = (* Given a pair "Ti", this procedure return Enext^{k}(Ti). *) BEGIN IF k = 0 THEN RETURN Ti ELSIF k = 1 THEN RETURN Enext(Ti) ELSIF k = 2 THEN RETURN Enext(Enext(Ti)) END; RETURN Ti; END EnextK; VAR poly : REF ARRAY OF ARRAY [0..7] OF Pair; count : CARDINAL := 1; faces : REF ARRAY OF Pair; glues : REF ARRAY OF Row4I; BEGIN cellnum := 60; cell4 := NEW(REF ARRAY OF Row4I, cellnum); poly := NEW(REF ARRAY OF ARRAY [0..7] OF Pair,cellnum); tetra := NEW(REF ARRAY OF ARRAY [0..3] OF Pair,cellnum); faces := NEW(REF ARRAY OF Pair, 4*cellnum); glues := NEW(REF ARRAY OF Row4I, 2*cellnum); (* creating topological tetrahedra *) FOR i := 0 TO cellnum-1 DO poly[i] := MakeTetraTopo(1,1); END; (* creating the tetrahedra *) FOR i := 0 TO cellnum-1 DO FOR j := 0 TO 3 DO tetra[i,j] := poly[i,j]; <* ASSERT Ppos(tetra[i,j]) = NIL *> END END; (* cells with corners perfectly assigments *) cell4[ 0]:=Row4I{100,500, 0, 1}; cell4[ 1]:=Row4I{100,500, 1, 4}; cell4[ 2]:=Row4I{100,500, 4, 7}; cell4[ 3]:=Row4I{100,500, 7, 2}; cell4[ 4]:=Row4I{100,500, 2, 0}; cell4[ 5]:=Row4I{500,101, 0, 1}; cell4[ 6]:=Row4I{500,101, 1, 5}; cell4[ 7]:=Row4I{500,101, 5, 8}; cell4[ 8]:=Row4I{500,101, 8, 3}; cell4[ 9]:=Row4I{500,101, 3, 0}; cell4[ 10]:=Row4I{500,102, 2, 0}; cell4[ 11]:=Row4I{500,102, 0, 3}; cell4[ 12]:=Row4I{500,102, 3, 9}; cell4[ 13]:=Row4I{500,102, 9, 6}; cell4[ 14]:=Row4I{500,102, 6, 2}; cell4[ 15]:=Row4I{103,500, 6, 2}; cell4[ 16]:=Row4I{500,103, 7, 2}; cell4[ 17]:=Row4I{103,500, 7, 13}; cell4[ 18]:=Row4I{103,500, 13, 12}; cell4[ 19]:=Row4I{500,103, 6, 12}; cell4[ 20]:=Row4I{500,104, 1, 4}; cell4[ 21]:=Row4I{500,104, 4, 10}; cell4[ 22]:=Row4I{500,104, 10, 11}; cell4[ 23]:=Row4I{500,104, 11, 5}; cell4[ 24]:=Row4I{500,104, 5, 1}; cell4[ 25]:=Row4I{500,105, 9, 3}; cell4[ 26]:=Row4I{500,105, 3, 8}; cell4[ 27]:=Row4I{500,105, 8, 14}; cell4[ 28]:=Row4I{500,105, 14, 15}; cell4[ 29]:=Row4I{500,105, 15, 9}; cell4[ 30]:=Row4I{500,106, 12, 6}; cell4[ 31]:=Row4I{500,106, 6, 9}; cell4[ 32]:=Row4I{500,106, 9, 15}; cell4[ 33]:=Row4I{500,106, 15, 18}; cell4[ 34]:=Row4I{500,106, 18, 12}; cell4[ 35]:=Row4I{500,107, 4, 7}; cell4[ 36]:=Row4I{500,107, 7, 13}; cell4[ 37]:=Row4I{500,107, 13, 16}; cell4[ 38]:=Row4I{500,107, 16, 10}; cell4[ 39]:=Row4I{500,107, 10, 4}; cell4[ 40]:=Row4I{108,500, 5, 8}; cell4[ 41]:=Row4I{108,500, 8, 14}; cell4[ 42]:=Row4I{108,500, 14, 17}; cell4[ 43]:=Row4I{108,500, 17, 11}; cell4[ 44]:=Row4I{108,500, 11, 5}; cell4[ 45]:=Row4I{109,500, 18, 12}; cell4[ 46]:=Row4I{109,500, 12, 13}; cell4[ 47]:=Row4I{109,500, 13, 16}; cell4[ 48]:=Row4I{109,500, 16, 19}; cell4[ 49]:=Row4I{109,500, 19, 18}; cell4[ 50]:=Row4I{500,110, 18, 15}; cell4[ 51]:=Row4I{500,110, 15, 14}; cell4[ 52]:=Row4I{500,110, 14, 17}; cell4[ 53]:=Row4I{500,110, 17, 19}; cell4[ 54]:=Row4I{500,110, 19, 18}; cell4[ 55]:=Row4I{111,500, 10, 11}; cell4[ 56]:=Row4I{111,500, 11, 17}; cell4[ 57]:=Row4I{111,500, 17, 19}; cell4[ 58]:=Row4I{111,500, 19, 16}; cell4[ 59]:=Row4I{111,500, 16, 10}; (* set the labels for each tetrahedra *) FOR i := 0 TO cellnum-1 DO SetCornersTetra(i,cell4[i]); END; IF Original THEN (* emphasize the original elements *) FOR i := 0 TO cellnum-1 DO SetGhostVertex(i,500); SetGhostEdge(i,500); SetGhostFace(i,500); FOR j := 100 TO 111 DO SetGhostVertex(i,j); SetGhostEdge(i,j); END END END; (* builds the table of faces for choose which tetrahedra must be gluing. *) FOR i := 0 TO cellnum-1 DO FOR k := 0 TO 3 DO faces[(4*i)+k] := tetra[i,k]; END END; (* computing which cells must be gluing. *) FOR k := 0 TO LAST(faces^) DO FOR l := k+1 TO LAST(faces^) DO FOR m := 0 TO 2 DO WITH e = EnextK(faces[l],m) DO IF MustBeGlue(faces[k],e) THEN WITH kc = k MOD 4, kt = k DIV 4, lc = l MOD 4, lt = l DIV 4 DO glues[count-1] := Row4I{kt,lt,kc,lc}; INC(count); END END END END END END; (* Do the automatic gluing of tetrahedra *) FOR i := 0 TO LAST(glues^) DO WITH c = glues[i] DO IF c # Row4I{0,0,0,0} THEN EVAL Gluing(c[0],c[1],c[2],c[3]); END END END; (* setting the origins. *) FOR i := 0 TO cellnum-1 DO FOR j := 0 TO 3 DO WITH a = tetra[i,j], b = Enext(a), c = Enext_1(a) DO Triangulation.SetAllOrgs(a,OrgV(a)); Triangulation.SetAllOrgs(b,OrgV(b)); Triangulation.SetAllOrgs(c,OrgV(c)); END END END; SaveFreeCorners(); RETURN dode; END MakeDodecahedronTriang; PROCEDURE MakePyramid(n: CARDINAL) : REF ARRAY OF Pair = (* Builds a pyramid with base as a n-gon face, without polyhedron information. *) VAR a := NEW(REF ARRAY OF Pair,n); BEGIN WITH b = MakeGonFull(n) DO (* creating the "n" triangular faces *) FOR i := 0 TO n-1 DO a[i] := MakeTriangle(); END; (* doing the connections between the base and the triangular faces *) FOR i := 0 TO n-1 DO SetFnext(a[i],b[i]); END; (* doing the connections between the triangular faces *) FOR i := 0 TO n-1 DO SetFnext( Enext(a[i]), Clock(Enext_1(a[(i+1) MOD n ])) ); END; (* setting the common elements: edges and vertices *) FOR j := 0 TO n-1 DO WITH a = a[j], b = Enext(a), c = Enext_1(a) DO SetEdgeAll(a,a.facetedge.edge); SetAllOrgs(a,OrgV(a)); SetEdgeAll(b,b.facetedge.edge); SetAllOrgs(b,OrgV(b)); SetEdgeAll(c,c.facetedge.edge); SetAllOrgs(c,OrgV(c)); END END; RETURN b; END END MakePyramid; PROCEDURE SetNextPnegC(a : Pair; n: Node) = (* Set the 24 pairs facetedges belonging to same polyhedron negative "n" for one cubic cell. *) VAR t : Pair := a; BEGIN SetAllPneg(t,n); REPEAT SetAllPneg(Clock(Fnext_1(t)),n); t := Enext_1(t); UNTIL t = a; t := Fnext_1(Enext_1(Enext_1(Fnext_1(a)))); SetAllPneg(t,n); END SetNextPnegC; PROCEDURE CubeNegVertices(a: Pair): ARRAY [0..7] OF Vertex = (* Valid for the versions Spin(a), Clock(a) and SpinClock(a). ? *) BEGIN <* ASSERT Pneg(a) # NIL *> WITH p = OrgV(a), q = OrgV(Enext_1(a)), r = OrgV(Enext_1(Enext_1(a))), s = OrgV(Enext_1(Fnext_1(Enext_1(a)))), b = Clock(Fnext(Enext_1(Enext_1(Fnext_1(a))))), t = OrgV(b), u = OrgV(Enext_1(b)), v = OrgV(Enext_1(Enext_1(b))), w = OrgV(Enext_1(Fnext_1(Enext_1(b)))) DO <* ASSERT Pneg(a) = Ppos(b) *> <* ASSERT (p # q) AND (q # r) AND (r # s) *> <* ASSERT s # t *> <* ASSERT (t # u) AND (u # v) AND (v # w) *> RETURN ARRAY [0..7] OF Vertex{p,q,r,s,t,u,v,w} END END CubeNegVertices; PROCEDURE CubeBarycenter(a: Pair; READONLY c: Coords): LR4.T = VAR n : CARDINAL := 0; sum := LR4.T{0.0d0, ..}; BEGIN WITH cube = CubeNegVertices(a) DO FOR i := 0 TO 7 DO WITH aoc = c[cube[i].num] DO sum := LR4.Add(sum, aoc); INC(n); END END END; RETURN LR4.Scale(1.0d0/FLOAT(n,LONGREAL), sum) END CubeBarycenter; PROCEDURE SetNextPnegB(a : Pair; n: Node) = (* Set the 8 pairs facetedges belonging to same polyhedron negative "n" for one cigar-shaped cell. *) VAR t : Pair := a; BEGIN SetAllPneg(t,n); REPEAT SetAllPneg(Clock(Fnext_1(t)),n); t := Enext_1(t); UNTIL t = a; t := Fnext_1(Enext_1(Fnext_1(a))); SetAllPneg(t,n); END SetNextPnegB; <* UNUSED *> PROCEDURE PrtNextPnegB(a: Pair) = (* Print the 8 pairs facetedges belonging to same polyhedron negative for one cubic cell. *) PROCEDURE NextPnegof(a: Pair) = VAR t : Pair := a; BEGIN REPEAT Tools.PrtPnegNum(t); t := Enext_1(t); UNTIL t = a; END NextPnegof; VAR t : Pair := a; BEGIN NextPnegof(t); REPEAT NextPnegof(Clock(Fnext_1(t))); t := Enext_1(t); UNTIL (t=a); t := Fnext_1(Enext_1(Fnext_1(a))); NextPnegof(t); END PrtNextPnegB; <* UNUSED *> PROCEDURE PrtPnegPpos(a: Pair) = (* Print the polyhedron negative and positive of pairs facetedges belonging to same face. *) VAR t : Pair := a; BEGIN REPEAT Tools.PrtPnegNum(t); Tools.PrtPposNum(t); Tools.PrtPnegNum(Clock(t)); Tools.PrtPposNum(Clock(t)); t := Enext_1(t); UNTIL t = a; END PrtPnegPpos; <* UNUSED *> PROCEDURE PrtNextPnegC(a: Pair) = (* Print the 24 pairs facetedges belonging to same polyhedron negative for one cubic cell. *) PROCEDURE NextPnegof(a: Pair) = VAR t : Pair := a; BEGIN REPEAT Tools.PrtPnegNum(t); t := Enext_1(t); UNTIL t = a; END NextPnegof; VAR t : Pair := a; BEGIN NextPnegof(t); REPEAT NextPnegof(Clock(Fnext_1(t))); t := Enext_1(t); UNTIL t = a; t := Fnext_1(Enext_1(Enext_1(Fnext_1(a)))); NextPnegof(t); END PrtNextPnegC; PROCEDURE MakeBall(): ARRAY [0..3] OF Pair = (* Build one polyhedron with American football shape. This polyhedron is the gluing scheme for obtain the "pseudomanifold" complex. *) VAR co : ARRAY [0..3] OF Pair; BEGIN FOR i := 0 TO 3 DO co[i] := MakeGon(2); END; (* Glue Faces *) FOR i := 0 TO 3 DO SetFnext(co[i],Clock(Enext(co[(i+1) MOD 4]))); SetEdge(co[i], Clock(Enext(co[(i+1) MOD 4])).facetedge.edge); SetAllOrgs(co[i], Org(co[i])); SetAllOrgs(Clock(co[i]), Org(Clock(co[i]))); END; WITH q = MakePolyhedron() DO q.num := PolyhedronCount; INC(PolyhedronCount); SetNextPnegB(co[0],q); END; RETURN co; END MakeBall; PROCEDURE MakeTetrahedron() : ARRAY [0..3] OF Pair = VAR co : ARRAY [0..3] OF Pair; BEGIN FOR i := 0 TO 3 DO co[i] := MakeTriangle(); END; (* Glue Faces *) SetFnext(co[3],Clock(co[0])); SetEdge(co[3],Clock(co[0]).facetedge.edge); SetFnext(Clock(co[1]), Enext(co[0])); SetEdge(Clock(co[1]), Enext(co[0]).facetedge.edge); SetFnext(Clock(Enext_1(co[0])), co[2]); SetEdge(Clock(Enext_1(co[0])), co[2].facetedge.edge); SetFnext(Clock(Enext_1(co[1])), Enext(co[2])); SetEdge(Clock(Enext_1(co[1])), Enext(co[2]).facetedge.edge); SetFnext(Clock(Enext(co[1])), Enext_1(co[3])); SetEdge(Clock(Enext(co[1])), Enext_1(co[3]).facetedge.edge); SetFnext(Clock(Enext_1(co[2])), Enext(co[3])); SetEdge(Clock(Enext_1(co[2])), Enext(co[3]).facetedge.edge); SetAllOrgs(co[0], Org(co[0])); SetAllOrgs(Clock(co[0]), Org(Clock(co[0]))); SetAllOrgs(co[1], Org(co[1])); SetAllOrgs(Enext_1(co[1]), Org(Enext_1(co[1]))); WITH q = MakePolyhedron() DO q.num := PolyhedronCount; INC(PolyhedronCount); SetAllPneg(co[0],q); END; RETURN co; END MakeTetrahedron; PROCEDURE GlueBall(a,b: Pair) : Pair = (* Make the glueing of two simples 2-gon faces around of one common face. The pair "a" and theirs adjacents with the same face component is killed. *) BEGIN <* ASSERT Octf.SpinBit(a) = Octf.SpinBit(b) *> Octf.Meld(a,b); (* updating edges relations *) SetEdgeAll(b, b.facetedge.edge); SetEdgeAll(Enext(b), Enext(b).facetedge.edge); (* updating vertices relations *) SetAllOrgs(b, Org(b)); SetAllOrgs(Enext(b), Org(Enext(b))); (* updating polyhedron relations *) SetPneg(b, Pneg(a)); SetPneg(Enext_1(b), Pneg(Enext_1(a))); RETURN b; END GlueBall; PROCEDURE MakeCube() : ARRAY [0..5] OF Pair = PROCEDURE CEE(a: Pair) : Pair = BEGIN RETURN Clock(Enext(Enext(a))); END CEE; VAR co : ARRAY [0..5] OF Pair; BEGIN FOR i := 0 TO 5 DO co[i] := MakeSquare(); END; (* Glue Faces *) SetFnext(co[1],CEE(co[2])); (* 1-2 *) SetEdge(co[1], CEE(co[2]).facetedge.edge); SetAllOrgs(co[1], Org(co[1])); SetAllOrgs(Clock(co[1]), Org(Clock(co[1]))); SetFnext(co[2],CEE(co[3])); (* 2-3 *) SetEdge(co[2], CEE(co[3]).facetedge.edge); SetAllOrgs(co[2], Org(co[2])); SetAllOrgs(Clock(co[2]), Org(Clock(co[2]))); SetFnext(co[3],CEE(co[4])); (* 3-4 *) SetEdge(co[3], CEE(co[4]).facetedge.edge); SetAllOrgs(co[3], Org(co[3])); SetAllOrgs(Clock(co[3]), Org(Clock(co[3]))); SetFnext(co[4],CEE(co[1])); (* 4-1 *) SetEdge(co[4], CEE(co[1]).facetedge.edge); SetAllOrgs(co[4], Org(co[4])); SetAllOrgs(Clock(co[4]), Org(Clock(co[4]))); SetFnext(Enext_1(co[1]), Clock(Enext(co[0]))); (* 1-0 *) SetEdge(Enext_1(co[1]), Clock(Enext(co[0])).facetedge.edge); SetAllOrgs(Enext_1(co[1]), Org(Enext_1(co[1]))); SetAllOrgs(Clock(Enext_1(co[1])), Org(Clock(Enext_1(co[1])))); SetFnext(Enext_1(co[5]), Clock(Enext(co[1]))); (* 5-1 *) SetEdge(Enext_1(co[5]), Clock(Enext(co[1])).facetedge.edge); SetAllOrgs(Enext_1(co[5]), Org(Enext_1(co[5]))); SetAllOrgs(Clock(Enext_1(co[5])), Org(Clock(Enext_1(co[5])))); SetFnext(co[5], Clock(Enext(co[2]))); (* 5-2 *) SetEdge(co[5], Clock(Enext(co[2])).facetedge.edge); SetAllOrgs(co[5], Org(co[5])); SetAllOrgs(Clock(co[5]), Org(Clock(co[5]))); SetFnext(Enext(co[5]), Clock(Enext(co[3]))); (* 5-3 *) SetEdge(Enext(co[5]), Clock(Enext(co[3])).facetedge.edge); SetAllOrgs(Enext(co[5]), Org(Enext(co[5]))); SetAllOrgs(Clock(Enext(co[5])), Org(Clock(Enext(co[5])))); SetFnext(Enext(Enext(co[5])), Clock(Enext(co[4]))); (* 5-4 *) SetEdge(Enext(Enext(co[5])), Clock(Enext(co[4])).facetedge.edge); SetAllOrgs(Enext(Enext(co[5])), Org(Enext(Enext(co[5])))); SetAllOrgs(Clock(Enext(Enext(co[5]))), Org(Clock(Enext(Enext(co[5]))))); SetFnext(co[0], Clock(Enext_1(co[2]))); (* 0-2 *) SetEdge(co[0], Clock(Enext_1(co[2])).facetedge.edge); SetAllOrgs(co[0], Org(co[0])); SetAllOrgs(Clock(co[0]), Org(Clock(co[0]))); SetFnext(Enext_1(co[0]), Clock(Enext_1(co[3]))); (* 0-3 *) SetEdge(Enext_1(co[0]), Clock(Enext_1(co[3])).facetedge.edge); SetAllOrgs(Enext_1(co[0]), Org(Enext_1(co[0]))); SetAllOrgs(Clock(Enext_1(co[0])), Org(Clock(Enext_1(co[0])))); SetFnext(Enext(Enext(co[0])), Clock(Enext_1(co[4]))); (* 0-4 *) SetEdge(Enext(Enext(co[0])), Clock(Enext_1(co[4])).facetedge.edge); SetAllOrgs(Enext(Enext(co[0])), Org(Enext(Enext(co[0])))); SetAllOrgs(Clock(Enext(Enext(co[0]))), Org(Clock(Enext(Enext(co[0]))))); WITH q = MakePolyhedron() DO q.num := PolyhedronCount; INC(PolyhedronCount); SetNextPnegC(co[0],q); END; RETURN co; END MakeCube; PROCEDURE GlueCube(a,b : Pair) : Pair = (* Make the glueing of two simples cubes around of one squared face common. The pair "a" and theirs adjacents with the same face component is killed. *) BEGIN Octf.Meld(a,b); (* updating edges relations *) SetEdgeAll(b, b.facetedge.edge); SetEdgeAll(Enext(b), Enext(b).facetedge.edge); SetEdgeAll(Enext(Enext(b)), Enext(Enext(b)).facetedge.edge); SetEdgeAll(Enext(Enext(Enext(b))), Enext(Enext(Enext(b))).facetedge.edge); (* updating vertices relations *) SetAllOrgs(b, Org(b)); SetAllOrgs(Enext(b), Org(Enext(b))); SetAllOrgs(Enext(Enext(b)), Org(Enext(Enext(b)))); SetAllOrgs(Enext(Enext(Enext(b))), Org(Enext(Enext(Enext(b))))); SetAllOrgs(Clock(b), Org(Clock(b))); SetAllOrgs(Clock(Enext(b)), OrgV(Clock(Enext(b)))); SetAllOrgs(Clock(Enext(Enext(b))), Org(Clock(Enext(Enext(b))))); SetAllOrgs(Clock(Enext(Enext(Enext(b)))), Org(Clock(Enext(Enext(Enext(b)))))); (* updating polyhedron relations *) SetPneg(b, Pneg(a)); SetPneg(Enext_1(b), Pneg(Enext_1(a))); SetPneg(Enext_1(Enext_1(b)), Pneg(Enext_1(Enext_1(a)))); SetPneg(Enext_1(Enext_1(Enext_1(b))), Pneg(Enext_1(Enext_1(Enext_1(a))))); RETURN b; END GlueCube; PROCEDURE GlueBigCube(a, b : Pair; n: CARDINAL) : Pair = VAR ta,tb: ARRAY [0..20] OF ARRAY [0..20] OF Pair; (* Make the glueing of two simples "bigcubes" around of one squared grid common face. *) BEGIN (* sanity check *) <* ASSERT n >= 1 *> ta[0,0] := a; tb[0,0] := b; FOR i := 1 TO n-1 DO ta[i,0] := Clock(Fnext_1(Enext(Enext(ta[i-1,0])))); tb[i,0] := Clock(Fnext(Enext(Enext(tb[i-1,0])))); END; FOR i := 0 TO n-1 DO FOR j := 1 TO n-1 DO ta[i,j] := Clock(Enext_1(Fnext_1(Enext(ta[i, j-1])))); tb[i,j] := Clock(Enext_1(Fnext(Enext(tb[i,j-1])))); <* ASSERT ta[i,j] # a *> <* ASSERT tb[i,j] # b *> END; END; FOR i := 0 TO n-1 DO Octf.Meld(tb[i,0], ta[i,0]); (* updating edges relations *) SetEdgeAll(ta[i,0], ta[i,0].facetedge.edge); SetEdgeAll(Enext(ta[i,0]), Enext(ta[i,0]).facetedge.edge); SetEdgeAll(Enext(Enext(ta[i,0])), Enext(Enext(ta[i,0])).facetedge.edge); SetEdgeAll(Enext(Enext(Enext(ta[i,0]))), Enext(Enext(Enext(ta[i,0]))).facetedge.edge); (* updating vertices relations *) SetAllOrgs(ta[i,0], Org(ta[i,0])); SetAllOrgs(Enext(ta[i,0]), Org(Enext(ta[i,0]))); SetAllOrgs(Enext(Enext(ta[i,0])), Org(Enext(Enext(ta[i,0])))); SetAllOrgs(Enext(Enext(Enext(ta[i,0]))), Org(Enext(Enext(Enext(ta[i,0]))))); SetAllOrgs(Clock(ta[i,0]), Org(Clock(ta[i,0]))); SetAllOrgs(Clock(Enext(ta[i,0])), OrgV(Clock(Enext(ta[i,0])))); SetAllOrgs(Clock(Enext(Enext(ta[i,0]))), Org(Clock(Enext(Enext(ta[i,0]))))); SetAllOrgs(Clock(Enext(Enext(Enext(ta[i,0])))), Org(Clock(Enext(Enext(Enext(ta[i,0])))))); SetPneg(ta[i,0], Pneg(tb[i,0])); SetPneg(Enext_1(ta[i,0]), Pneg(Enext_1(tb[i,0]))); SetPneg(Enext_1(Enext_1(ta[i,0])), Pneg(Enext_1(Enext_1(tb[i,0])))); SetPneg(Enext_1(Enext_1(Enext_1(ta[i,0]))), Pneg(Enext_1(Enext_1(Enext_1(tb[i,0]))))); END; FOR i := 0 TO n-1 DO FOR j := 1 TO n-1 DO Octf.Meld(tb[i,j],ta[i,j]); (* updating edges relations *) SetEdgeAll(ta[i,j], ta[i,j].facetedge.edge); SetEdgeAll(Enext(ta[i,j]), Enext(ta[i,j]).facetedge.edge); SetEdgeAll(Enext(Enext(ta[i,j])), Enext(Enext(ta[i,j])).facetedge.edge); SetEdgeAll(Enext(Enext(Enext(ta[i,j]))), Enext(Enext(Enext(ta[i,j]))).facetedge.edge); (* updating vertices relations *) SetAllOrgs(ta[i,j], Org(ta[i,j])); SetAllOrgs(Enext(ta[i,j]), Org(Enext(ta[i,j]))); SetAllOrgs(Enext(Enext(ta[i,j])), Org(Enext(Enext(ta[i,j])))); SetAllOrgs(Enext(Enext(Enext(ta[i,j]))), Org(Enext(Enext(Enext(ta[i,j]))))); SetAllOrgs(Clock(ta[i,j]), Org(Clock(ta[i,j]))); SetAllOrgs(Clock(Enext(ta[i,j])), OrgV(Clock(Enext(ta[i,j])))); SetAllOrgs(Clock(Enext(Enext(ta[i,j]))), Org(Clock(Enext(Enext(ta[i,j]))))); SetAllOrgs(Clock(Enext(Enext(Enext(ta[i,j])))), Org(Clock(Enext(Enext(Enext(ta[i,j])))))); SetPneg(ta[i,j], Pneg(tb[i,j])); SetPneg(Enext_1(ta[i,j]), Pneg(Enext_1(tb[i,j]))); SetPneg(Enext_1(Enext_1(ta[i,j])), Pneg(Enext_1(Enext_1(tb[i,j])))); SetPneg(Enext_1(Enext_1(Enext_1(ta[i,j]))), Pneg(Enext_1(Enext_1(Enext_1(tb[i,j]))))); END; END; RETURN ta[0,0]; END GlueBigCube; PROCEDURE MakeRowCube(order: CARDINAL) : REF ARRAY OF PAIRS = (* Build one row of cubes with order "order". *) VAR ca : REF ARRAY OF ARRAY [0..5] OF Pair; cb : REF ARRAY OF PAIRS; BEGIN ca := NEW(REF ARRAY OF ARRAY [0..5] OF Pair, order); cb := NEW(REF ARRAY OF PAIRS, order); FOR i := 0 TO order-1 DO ca[i] := MakeCube(); cb[i,0] := ca[i,1]; cb[i,1] := ca[i,3]; cb[i,2] := ca[i,0]; cb[i,3] := ca[i,5]; END; (* gluing *) FOR j := 0 TO order-2 DO EVAL GlueCube(ca[j,2], Fnext_1(ca[j+1,3])); END; RETURN cb; END MakeRowCube; PROCEDURE MakeColumnCube(order: CARDINAL) : REF TriPair = (* Builds one bidimensional array of cubes of order: "order x order". *) VAR cb : REF ARRAY OF ARRAY OF PAIRS; cc : REF TriPair; BEGIN cb := NEW(REF ARRAY OF ARRAY OF PAIRS, order, order); cc := NEW(REF ARRAY OF ARRAY OF ARRAY [0..1] OF Pair, order,order); (* Mounting the array cb *) FOR i := 0 TO order-1 DO WITH ca = MakeRowCube(order) DO FOR j := 0 TO order-1 DO FOR k := 0 TO 3 DO cb[i,j,k] := ca[j,k]; END END END END; (* gluing *) FOR j := 0 TO order-2 DO FOR k := 0 TO order-1 DO EVAL GlueCube(cb[j,k,1],Clock(Enext(Enext(cb[j+1,k,0])))); END END; (* Selecting the pairs for return *) FOR i := 0 TO order-1 DO FOR j := 0 TO order-1 DO FOR k := 0 TO 1 DO cc[i,j,k] := cb[i,j,k+2]; END END END; RETURN cc; END MakeColumnCube; PROCEDURE MakeBigCube(order: CARDINAL) : REF TriPair = (* Build one tridimensional array of cubic cells with random geometry. Return two arrays of pairs of order: "order x order", not eliminated by gluing procedure of columns of cubes. *) VAR cd := NEW(REF ARRAY OF ARRAY OF ARRAY OF PAIRS, order, order,order); ce := NEW(REF TriPair, order,order); BEGIN FOR i := 0 TO order-1 DO WITH cc = MakeColumnCube(order) DO FOR j := 0 TO order-1 DO FOR k := 0 TO order-1 DO FOR l := 0 TO 1 DO cd[i,j,k,l] := cc[j,k,l]; END END END END END; (* gluing *) FOR i := 0 TO order-2 DO FOR k := 0 TO order-1 DO FOR j := 0 TO order-1 DO EVAL GlueCube(cd[i,k,j,1],Clock(cd[i+1,k,j,0])); END END END; (* Selecting the pairs for return *) FOR j := 0 TO order-1 DO FOR k := 0 TO order-1 DO ce[j,k,0] := cd[0,k,j,0]; ce[j,k,1] := cd[order-1,k,j,1]; END END; RETURN ce; END MakeBigCube; PROCEDURE SetCubeProperties( a: REF TriPair; n: CARDINAL; READONLY tp: Topology; ) = PROCEDURE SetVertex(v: Vertex) = (* Emphasizes the original vertices. *) BEGIN v.exists := TRUE; END SetVertex; PROCEDURE SetEdge(a: Pair) = (* Emphasizes the original edges. *) BEGIN WITH e = NARROW(a.facetedge.edge, Triangulation.Edge) DO e.exists := TRUE; END; END SetEdge; PROCEDURE SetFace(a: Pair) = (* Emphasizes the original edges. *) BEGIN WITH f = NARROW(a.facetedge.face, Triangulation.Face) DO f.exists := TRUE; END; END SetFace; PROCEDURE FaceOnBoundary(a: Pair) : BOOLEAN = (* Return "TRUE" if the face "a.facetedge.face" is on the frontier. *) BEGIN IF Ppos(a) = NIL OR Pneg(a) = NIL THEN RETURN TRUE; ELSE RETURN FALSE; END END FaceOnBoundary; VAR c1,c2,c3,c4 : REF ARRAY OF Pair; (* edges on the columns *) index : CARDINAL := 0; BEGIN c1 := NEW(REF ARRAY OF Pair, n); c2 := NEW(REF ARRAY OF Pair, n); c3 := NEW(REF ARRAY OF Pair, n); c4 := NEW(REF ARRAY OF Pair, n); (* Set the original vertices *) SetVertex(Org(Clock(Enext(a[0,0,0])))); (* vertex 1 *) SetVertex(Org(Clock(a[n-1,0,0]))); (* vertex 2 *) SetVertex(Org(a[n-1,n-1,0])); (* vertex 3 *) SetVertex(Org(a[n-1,0,1])); (* vertex 4 *) SetVertex(Org(Clock(a[n-1,n-1,1]))); (* vertex 5 *) SetVertex(Org(Clock(Enext(a[0,n-1,1]))));(* vertex 6 *) SetVertex(Org(Enext_1(a[0,0,1]))); (* vertex 7 *) SetVertex(Org(Enext_1(a[0,n-1,0]))); (* vertex 8 *) (* Set the original edges *) FOR i := 0 TO n-1 DO SetEdge(Enext_1(a[i,0,1])); SetEdge(Enext(a[i,0,0])); SetEdge(a[n-1,i,0]); SetEdge(a[n-1,i,1]); SetEdge(Enext_1(a[i,n-1,0])); SetEdge(Enext(a[i,n-1,1])); SetEdge(Enext(Enext(a[0,i,1]))); SetEdge(Enext(Enext(a[0,i,0]))); END; (* computing edges on the colums *) c1[0] := Enext(Fnext(a[n-1,0,0])); c2[0] := Enext_1(Fnext(a[n-1,n-1,0])); c3[0] := Enext(Fnext(Enext(a[0,0,0]))); c4[0] := Enext_1(Fnext(Enext_1(a[0,n-1,0]))); FOR k := 1 TO n-1 DO c1[k] := Clock(Enext_1(Fnext_1(Enext(c1[k-1])))); c2[k] := Clock(Enext(Fnext_1(Enext_1(c2[k-1])))); c3[k] := Clock(Enext_1(Fnext_1(Enext(c3[k-1])))); c4[k] := Clock(Enext(Fnext_1(Enext_1(c4[k-1])))); END; (* Now set the the original edges *) FOR j := 0 TO n-1 DO SetEdge(c1[j]); SetEdge(c2[j]); SetEdge(c3[j]); SetEdge(c4[j]); END; FOR i := 0 TO tp.NF-1 DO WITH f = tp.face[i].pa DO IF FaceOnBoundary(f) THEN SetFace(f); INC(index) END; END END; <* ASSERT index = 6*n*n *> END SetCubeProperties; BEGIN END Squared. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Tools.m3 MODULE Tools; (* This module contain procedures "tools" for tests and others miscelaneus procedures. Created by L. P. Lozada (see the copyright and authorship futher down). *) IMPORT Wr, Thread, Octf, Triangulation, Stdio, Fmt; FROM Octf IMPORT Pair, Enext, Fnext, DegreeFaceRing, DegreeEdgeRing, Enext_1, Clock, Fnext_1, PrintPair; FROM Triangulation IMPORT Org, DegreeOfVertex, Pneg, Ppos; FROM Stdio IMPORT stderr; PROCEDURE PrtDFR(a: Pair) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN PrintPair(stderr, a, 5); Wr.PutText(stderr," " ); WITH n = DegreeFaceRing(a) DO Wr.PutText(stderr,"DFR: " & Fmt.Pad(Fmt.Int(n),4) & "\n"); END END PrtDFR; PROCEDURE PrtDER(a: Pair) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN PrintPair(stderr, a, 5); Wr.PutText(stderr," " ); WITH n = DegreeEdgeRing(a) DO Wr.PutText(stderr,"DER: " & Fmt.Pad(Fmt.Int(n),4) & "\n"); END END PrtDER; (* PROCEDURE PrtDFE(a: Pair) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN PrintPair(stderr, a, 5); Wr.PutText(stderr," " ); WITH n = DegreeOfFacetEdges(a) DO Wr.PutText(stderr,"DFE: " & Fmt.Pad(Fmt.Int(n),4) & "\n"); END END PrtDFE; *) PROCEDURE PrtDOV(a: Pair) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN PrintPair(stderr, a, 5); Wr.PutText(stderr," " ); WITH n = DegreeOfVertex(a) DO Wr.PutText(stderr,"DOV: " & Fmt.Pad(Fmt.Int(n),4) & "\n"); END END PrtDOV; PROCEDURE PrtEnext(a: Pair) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN PrintPair(stderr, a); Wr.PutText(stderr, " Enext(a): "); PrintPair(stderr, Enext(a), 5, TRUE); END PrtEnext; PROCEDURE PrtFnext(a: Pair) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN PrintPair(stderr, a); Wr.PutText(stderr, " Fnext(a): "); PrintPair(stderr, Fnext(a), 5, TRUE); END PrtFnext; PROCEDURE PrtOrg(a: Pair) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(stderr,"a: "); PrintPair(stderr, a); Wr.PutText(stderr," Org(a): "); Wr.PutText(stderr, Fmt.Int(Org(a).num) ); Wr.PutText(stderr,"\n"); END PrtOrg; PROCEDURE PrtFaceNum(a: Pair) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(stderr,"a: "); PrintPair(stderr, a); Wr.PutText(stderr, " a.facetedge.face.num(a): "); Wr.PutText(stderr, Fmt.Int(a.facetedge.face.num) ); Wr.PutText(stderr,"\n"); END PrtFaceNum; PROCEDURE PrtEdgeNum(a: Pair) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(stderr,"a: "); PrintPair(stderr, a); Wr.PutText(stderr, " a.facetedge.edge.num(a): "); Wr.PutText(stderr, Fmt.Int(a.facetedge.edge.num) ); Wr.PutText(stderr,"\n"); END PrtEdgeNum; PROCEDURE PrtPnegNum(a: Pair) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN IF Pneg(a) # NIL THEN Wr.PutText(stderr, " "); PrintPair(stderr, a); Wr.PutText(stderr, " Pneg.num: "); Wr.PutText(stderr, Fmt.Int(Pneg(a).num) & "\n"); (* remenber Pneg(a) = Org(Srot(a)) *) ELSE Wr.PutText(stderr,"Negative Polyhedron not exists\n"); END END PrtPnegNum; PROCEDURE PrtPposNum(a: Pair) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN IF Ppos(a) # NIL THEN Wr.PutText(stderr, " "); PrintPair(stderr, a); Wr.PutText(stderr, " Ppos.num: "); Wr.PutText(stderr, Fmt.Int(Ppos(a).num) & "\n"); (* remenber Ppos(a) = Org(Tors(a)) *) ELSE Wr.PutText(stderr,"Positive Polyhedron not exists\n"); END END PrtPposNum; PROCEDURE PrtNextPneg(a: Pair) = PROCEDURE NextPnegof(a: Pair) = VAR h: Pair := a; BEGIN REPEAT PrtPnegNum(h); h := Enext_1(h); UNTIL (h = a); END NextPnegof; VAR t: Pair := a; BEGIN NextPnegof(t); REPEAT NextPnegof(Clock(Fnext_1(t))); t := Enext_1(t); UNTIL (t = a); END PrtNextPneg; PROCEDURE PrtNextPpos(a: Pair) = PROCEDURE NextPposof(a: Pair) = VAR h: Pair := a; BEGIN REPEAT PrtPposNum(h); h := Enext_1(h); UNTIL (h = a); END NextPposof; VAR t: Pair := a; BEGIN NextPposof(t); REPEAT NextPposof(Clock(Fnext(t))); t := Enext_1(t); UNTIL (t=a); END PrtNextPpos; BEGIN END Tools. (**************************************************************************) (* *) (* Copyright (C) 1999 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Triangulation.m3 MODULE Triangulation; (* This module contain essentially procedures created by R. Marcone and J. Stolfi (see the copyright and authorship futher down), modified extensively by L. Lozada for the visualization of 3D-maps. Revisions: 03-08-2000 : Optimized version of the Read and Write procedures by J. Stolfi. 30-08-2000 : Modified the Read and Write procedures for include the case when the cells are octahedra. 07-10-2000 : Added procedure for compute the barycenter of a tetrahedron. 27-01-2001 : Modified for exploding cubic cells. *) IMPORT Octf, Random, LR4, LR4Extras, Stdio, Wr, Fmt, Thread, Math, FloatMode, FileRd, FileWr, Mis, Text, OSError, Lex, Rd, R3, FileFmt; FROM Octf IMPORT Fnext, Clock, SrotBits, RBits, SpliceFacets, Enext_1, Srot, Spin, SetFace, GetPairNum,Tors, Enext, Fnext_1, Onext, SetFnext, SetEdge, SetEdgeAll, SetEnext; FROM Stdio IMPORT stderr; FROM Mis IMPORT WriteCommentsJS; FROM FileFmt IMPORT WriteHeader, WriteFooter, ReadHeader, ReadFooter; <* FATAL Thread.Alerted, Rd.Failure, Wr.Failure *> <* FATAL Rd.EndOfFile, FloatMode.Trap, Lex.Error, OSError.E *> REVEAL FacetEdge = PublicFacetEdge BRANDED OBJECT org: ARRAY RBits OF Node; OVERRIDES init := FacetEdgeInit; END; REVEAL Vertex = PublicVertex BRANDED OBJECT END; REVEAL Polyhedron = PublicPolyhedron BRANDED OBJECT END; (* === INIT METHODS === *) PROCEDURE FacetEdgeInit(fe: FacetEdge): FacetEdge = BEGIN EVAL NARROW(fe, Octf.FacetEdge).init(); fe.org[0] := NIL; (* For now, vertex of primal: C *) fe.org[1] := NIL; (* For now, vertex of dual: C' *) fe.org[2] := NIL; (* For now, vertex of primal: C *) fe.org[3] := NIL; (* For now, vertex of dual: C' *) RETURN fe; END FacetEdgeInit; (* === ELEMENT CREATION === *) PROCEDURE MakeFacetEdge(): Pair = VAR a : Pair; BEGIN WITH e = NEW(FacetEdge).init() DO a := Pair{facetedge := e, bits := 0}; a.facetedge.edge.pa := a; a.facetedge.face.pa := a; RETURN a; END; END MakeFacetEdge; PROCEDURE MakeVertex(): Vertex = BEGIN RETURN NEW(Vertex) END MakeVertex; PROCEDURE MakePolyhedron(): Polyhedron = BEGIN RETURN NEW(Polyhedron) END MakePolyhedron; (* === PAIR PROPERTIES === *) PROCEDURE Org(a: Pair): Node = BEGIN WITH c = NARROW(a.facetedge, FacetEdge).org[SrotBits(a)] DO RETURN c; END; END Org; PROCEDURE SetOrg(a: Pair; n: Node) = BEGIN WITH c = NARROW(a.facetedge, FacetEdge).org[SrotBits(a)] DO c := n; END; END SetOrg; PROCEDURE Set(a: Pair; n: Node) = VAR c : Pair := a; BEGIN WITH nei = Octf.NumberEdgesForDegree(ARRAY OF Pair{a}) DO FOR i := 0 TO LAST(nei^) DO WITH b = nei[i] DO c := b; REPEAT SetOrg(c,n); c := Fnext(c) UNTIL (c = b); END END END END Set; PROCEDURE SetAllOrgs(a: Pair; n: Node) = BEGIN Set(a,n); END SetAllOrgs; PROCEDURE Pneg(a: Pair): Node = BEGIN RETURN Org(Srot(a)) END Pneg; PROCEDURE SetPneg(a: Pair; n: Node) = BEGIN SetOrg(Srot(a), n) END SetPneg; PROCEDURE SetNextPneg(a: Pair; n: Node) = VAR t: Pair := a; BEGIN REPEAT SetPneg(t, n); t := Enext_1(t); UNTIL t = a; END SetNextPneg; PROCEDURE SetAllPneg(a : Pair; n: Node) = VAR t: Pair := a; BEGIN SetNextPneg(t,n); REPEAT SetNextPneg(Clock(Fnext_1(t)),n); t := Enext_1(t); UNTIL t = a; END SetAllPneg; PROCEDURE Ppos(a: Pair): Node = BEGIN RETURN Pneg(Clock(a)) END Ppos; PROCEDURE SetPpos(a: Pair; n: Node) = BEGIN SetOrg(Tors(a), n) END SetPpos; PROCEDURE SetAllPpos(a: Pair; n: Node) = VAR t: Pair := a; BEGIN REPEAT SetPpos(t, n); t := Enext_1(t); UNTIL t = a; END SetAllPpos; PROCEDURE SetNextPpos(a : Pair; n: Node) = VAR t : Pair := Clock(a); BEGIN SetAllPneg(t,n); REPEAT SetAllPneg(Fnext_1(t),n); t := Enext_1(t); UNTIL t = Clock(a); END SetNextPpos; PROCEDURE OrgV(a: Pair): Vertex = BEGIN RETURN NARROW(Org(a), Vertex); END OrgV; PROCEDURE DesV(a: Pair): Vertex = BEGIN RETURN OrgV(Clock(a)); END DesV; PROCEDURE PnegP(a: Pair): Polyhedron = BEGIN RETURN NARROW(Pneg(a), Polyhedron); END PnegP; PROCEDURE PposP(a : Pair): Polyhedron = BEGIN RETURN PnegP(Clock(a)); END PposP; PROCEDURE TetraNegVertices(a: Pair): ARRAY [0..3] OF Vertex = (* Valid for the versions Spin(a), Clock(a) and SpinClock(a). *) BEGIN <* ASSERT Pneg(a) # NIL *> WITH p = OrgV(a), q = OrgV(Enext(a)), r = OrgV(Enext_1(a)), s = OrgV(Enext_1(Fnext_1(a))) DO <* ASSERT Pneg(a) = Ppos(Enext_1(Fnext_1(a))) *> <* ASSERT (p # q) AND (q # r) AND (r # s) *> RETURN ARRAY [0..3] OF Vertex{p,q,r,s} END END TetraNegVertices; PROCEDURE TetraFaces(a: Pair): ARRAY [0..3] OF Face = BEGIN <* ASSERT Pneg(a) # NIL *> WITH f0 = a.facetedge.face, f1 = Fnext_1(a).facetedge.face, f2 = Fnext_1(Enext(a)).facetedge.face, f3 = Fnext_1(Enext_1(a)).facetedge.face DO <* ASSERT (f0 # f1) AND (f1 # f2) AND (f2 # f3) *> RETURN ARRAY [0..3] OF Face{f0,f1,f2,f3} END END TetraFaces; PROCEDURE TetraEdges(a: Pair): ARRAY [0..5] OF Edge = BEGIN <* ASSERT Pneg(a) # NIL *> WITH e0 = a.facetedge.edge, e1 = Enext(a).facetedge.edge, e2 = Enext_1(a).facetedge.edge, e3 = Enext(Fnext_1(a)).facetedge.edge, e4 = Enext_1(Fnext_1(a)).facetedge.edge, e5 = Enext(Fnext_1(Enext(a))).facetedge.edge DO <* ASSERT (e0#e1) AND (e1#e2) AND (e2#e3) AND (e3#e4) AND (e4#e5) *> RETURN ARRAY [0..5] OF Edge{e0,e1,e2,e3,e4,e5} END END TetraEdges; PROCEDURE FaceEdges(a: Pair): ARRAY [0..2] OF Edge = BEGIN WITH e0 = a.facetedge.edge, e1 = Enext(a).facetedge.edge, e2 = Enext_1(a).facetedge.edge DO <* ASSERT (e0 # e1) AND (e1 # e2) *> RETURN ARRAY [0..2] OF Edge{e0,e1,e2} END END FaceEdges; PROCEDURE EdgeIsBorder(a: Pair): BOOL = VAR b: Pair := a; BEGIN REPEAT IF Pneg(b) = NIL THEN RETURN TRUE END; b := Fnext(b) UNTIL b = a; RETURN FALSE END EdgeIsBorder; PROCEDURE FaceIsBorder(a: Pair): BOOL = BEGIN RETURN Ppos(a) = NIL OR Pneg(a) = NIL; END FaceIsBorder; PROCEDURE TetraPosVertices(a: Pair): ARRAY [0..3] OF Vertex = (* Valid for the versions Spin(a), Clock(a) and SpinClock(a). *) BEGIN <* ASSERT Ppos(a) # NIL *> WITH p = OrgV(a), q = OrgV(Enext(a)), r = OrgV(Enext_1(a)), s = OrgV(Enext_1(Fnext(a))) DO <* ASSERT Ppos(a) = Pneg(Enext_1(Fnext(a))) *> RETURN ARRAY [0..3] OF Vertex{p,q,r,s} END END TetraPosVertices; PROCEDURE TetraNegPosVertices(a: Pair): ARRAY [0..4] OF Node = (* Valid for the versions Spin(a), Clock(a) and SpinClock(a). We change the otion OrgV by Org such as, this procedure can be used in the dual space but the assertion is valid only in the primal space. *) BEGIN WITH p = Org(a), q = Org(Enext(a)), r = Org(Enext_1(a)), s = Org(Enext_1(Fnext_1(a))), t = Org(Enext_1(Fnext(a))) DO <* ASSERT Ppos(a) = Pneg(Enext_1(Fnext(a))) AND Pneg(a) = Ppos(Enext_1(Fnext_1(a))) *> RETURN ARRAY [0..4] OF Node{p,q,r,s,t} END END TetraNegPosVertices; (* ================= CONSTRUCTION TOOLS ========== *) PROCEDURE MakeTetraTopo(nx,ny : CARDINAL): ARRAY [0..7] OF Pair = VAR FacetEdgeCount: CARDINAL := 0; PolyhedronCount: CARDINAL := 0; PROCEDURE MakeTriangle(): Pair = (* Make one triangular face and set of the three pairs facetedges with the same face component. *) BEGIN WITH a = MakeFacetEdge(), b = MakeFacetEdge(), c = MakeFacetEdge(), f = a.facetedge.face, u = MakeVertex(), v = MakeVertex(), w = MakeVertex() DO a.facetedge.num := FacetEdgeCount; INC(FacetEdgeCount); SetOrg(a, u); SetOrg(Clock(a),v); b.facetedge.num := FacetEdgeCount; INC(FacetEdgeCount); SetEnext(a,b); SetFace(b,f); SetOrg(b,v); SetOrg(Clock(b),w); c.facetedge.num := FacetEdgeCount; INC(FacetEdgeCount); SetEnext(b,c); SetFace(c,f); SetOrg(c, w); SetOrg(Clock(c), Org(a)); RETURN a; END END MakeTriangle; PROCEDURE MakeCell(a: Pair) : Pair = (* Build a new tetrahedral cell by insertion of two triangular faces and operations SpliceFacets. The argument "a" is the pair return by MakeTriangle(). The pair "f" is return by MakeCell(). *) VAR c : Pair; BEGIN c := Enext(Fnext(a)); SetEdge(a, Enext_1(c).facetedge.edge); WITH f = MakeTriangle(), g = MakeTriangle() DO SetFnext(Enext_1(a), Enext_1(f)); SetEdge(Enext_1(f), Enext_1(a).facetedge.edge); SetAllOrgs(Enext_1(a), Org(Enext_1(a))); SetAllOrgs(Clock(Enext_1(a)), Org(Clock(Enext_1(a)))); SetFnext(Clock(f), Enext(c)); SetEdge(Clock(f), Enext(c).facetedge.edge); SetAllOrgs(Enext(c), Org(Enext(c))); SetAllOrgs(Clock(Enext(c)), Org(Clock(Enext(c)))); SetFnext(Enext(g), Enext(f)); SetEdge(Enext(g), Enext(f).facetedge.edge); SetAllOrgs(Enext(f), Org(Enext(f))); SetAllOrgs(Clock(Enext(f)), Org(Clock(Enext(f)))); SetFnext(g, c); SetEdge(g, c.facetedge.edge); SetAllOrgs(c, Org(c)); SetAllOrgs(Clock(c), Org(Clock(c))); SetFnext(Enext_1(g), Clock(Enext(a))); SetEdge(Enext_1(g), Clock(Enext(a)).facetedge.edge); SetAllOrgs(Enext(a), Org(Enext(a))); SetAllOrgs(Clock(Enext(a)), Org(Clock(Enext(a)))); WITH p = MakePolyhedron() DO p.num := PolyhedronCount; INC(PolyhedronCount); SetAllPneg(f,p); END; RETURN f; END; END MakeCell; PROCEDURE MakeCellRow(a: Pair) : Pair = (* Adds one new row of tetradedral cells and return the pair facetedge belong to the cell more rigth. *) BEGIN FOR col := 0 TO nx-1 DO a := MakeCell(a); END; RETURN a; END MakeCellRow; VAR t,b: Pair; ca: ARRAY [0..7] OF Pair; BEGIN (* =============== create bottom row of triangles =========== *) FOR col := 0 TO nx-1 DO WITH c = MakeTriangle() DO IF col = 0 THEN t := c; ELSE SpliceFacets(Enext(b), Clock(Enext_1(c))); SetEdge(Enext(b), Clock(Enext_1(c)).facetedge.edge); SetAllOrgs(Enext(b), Org(Enext(b))); SetAllOrgs(Clock(Enext(b)), Org(Clock(Enext(b)))); END; b := c; END; END; ca[2] := t; ca[7] := Spin(Clock(b)); FOR row := 0 TO ny-1 DO WITH a = MakeTriangle() DO IF row = 0 THEN ca[1] := Clock(Enext_1(a)) END; IF row = ny-1 THEN ca[4] := Spin(Enext_1(a)) END; SpliceFacets(Clock(a), Clock(Enext_1(t))); SetAllOrgs(Enext_1(t), Org(Enext_1(t))); SetAllOrgs(Clock(Enext_1(t)), Org(Clock(Enext_1(t)))); WITH aa = MakeCellRow(a) DO t := Fnext_1(t); SetOrg(Enext_1(t), Org(Enext_1(a))); b := Fnext_1(b); SetOrg(Clock(Enext(b)), Org(Enext_1(aa))); IF row = 0 THEN ca[0] := Clock(Spin(Enext_1(aa))) END; IF row = ny-1 THEN ca[5] := Enext_1(aa) END; END; END; END; ca[3] := Spin(t); ca[6] := Clock(b); RETURN ca; END MakeTetraTopo; PROCEDURE EmphasizeTetrahedron(a, b: Pair; n: CARDINAL) = PROCEDURE HiddenVertex(v: Vertex) = (* Hidden the vertex "v". *) BEGIN v.exists := FALSE; END HiddenVertex; PROCEDURE HiddenEdge(a: Pair) = (* Hidden the edge "a.facetedge.edge".*) BEGIN WITH e = NARROW(a.facetedge.edge, Edge) DO e.exists := FALSE; END; END HiddenEdge; PROCEDURE HiddenFace(a: Pair) = (* Hidden the face "a.facetedge.face".*) BEGIN WITH f = NARROW(a.facetedge.face, Face) DO f.exists := FALSE; END; END HiddenFace; PROCEDURE HiddenRingFace(a: Pair) = (* Hidden the ring face "a.facetedge.face". *) VAR an : Pair := Fnext_1(a); BEGIN FOR j := 1 TO n-1 DO HiddenFace(an); an := Fnext_1(an); END; END HiddenRingFace; VAR ta,tb: ARRAY [0..100] OF Pair; BEGIN ta[0] := a; tb[0] := b; FOR i := 1 TO n-1 DO ta[i] := Clock(Enext_1(Fnext(Enext(ta[i-1])))); tb[i] := Clock(Enext_1(Fnext(Enext(tb[i-1])))); END; FOR i := 0 TO n-1 DO HiddenRingFace(ta[i]); HiddenRingFace(tb[i]); END; FOR i := 1 TO n-1 DO HiddenVertex(OrgV(tb[i])); HiddenVertex(OrgV(ta[i])); VAR dn: Pair := tb[i]; BEGIN FOR j := 0 TO n DO HiddenEdge(Enext_1(dn)); dn := Fnext_1(dn); END END END; FOR i := 0 TO n-2 DO HiddenEdge(Enext(ta[i])); HiddenEdge(Enext(Fnext(ta[i]))); END; END EmphasizeTetrahedron; PROCEDURE Glue( a,b : Pair; n : CARDINAL; setorg: BOOLEAN := TRUE; ): Pair = (* The pair "a" and "b" have the same Orientation and Spin bits, such as, after of the glue procedure performs: Pneg(a) = Pneg(b). *) VAR ta,tb: ARRAY [0..100] OF Pair; BEGIN (*Wr.PutText(Stdio.stderr, "colou\n");*) (* sanity check *) <* ASSERT n >= 1 *> ta[0] := a; tb[0] := b; IF n > 1 THEN FOR i := 1 TO n-1 DO ta[i] := Clock(Enext_1(Fnext_1(Enext(ta[i-1])))); tb[i] := Clock(Enext_1(Fnext(Enext(tb[i-1])))); <* ASSERT ta[i] # a *> <* ASSERT tb[i] # b *> END; END; Octf.Meld(b, a); (* updating edges relations for i=0 *) SetEdgeAll(a, a.facetedge.edge); SetEdgeAll(Enext(a), Enext(a).facetedge.edge); SetEdgeAll(Enext_1(a), Enext_1(a).facetedge.edge); IF setorg THEN (* updating vertices relations for i=0 *) SetAllOrgs(a, Org(a)); SetAllOrgs(Clock(a), Org(Clock(a))); SetAllOrgs(Enext(a), Org(Enext(a))); SetAllOrgs(Clock(Enext(a)), Org(Clock(Enext(a)))); SetAllOrgs(Enext_1(a), Org(Enext_1(a))); SetAllOrgs(Clock(Enext_1(a)), Org(Clock(Enext_1(a)))); END; (* updating polyhedron relations for i=0 *) SetPneg(a, Pneg(b)); SetPneg(Enext_1(a), Pneg(Enext_1(b))); SetPneg(Enext(a), Pneg(Enext(b))); FOR i := 1 TO n-1 DO Octf.Meld(tb[i],ta[i]); (* updating edges relations *) SetEdgeAll(ta[i], ta[i].facetedge.edge); SetEdgeAll(Enext(ta[i]), Enext(ta[i]).facetedge.edge); SetEdgeAll(Enext_1(ta[i]), Enext_1(ta[i]).facetedge.edge); IF setorg THEN (* updating vertices relations *) SetAllOrgs(ta[i], Org(ta[i])); SetAllOrgs(Clock(ta[i]), Org(Clock(ta[i]))); SetAllOrgs(Enext(ta[i]), Org(Enext(ta[i]))); SetAllOrgs(Clock(Enext(ta[i])), Org(Clock(Enext(ta[i])))); SetAllOrgs(Enext_1(ta[i]), Org(Enext_1(ta[i]))); SetAllOrgs(Clock(Enext_1(ta[i])), Org(Clock(Enext_1(ta[i])))); END; (* updating polyhedron relations *) WITH f = Pneg(tb[i]), g = Pneg(Enext_1(tb[i])), h = Pneg(Enext(tb[i])) DO SetPneg(ta[i],f); SetPneg(Enext_1(ta[i]),g); SetPneg(Enext(ta[i]),h); END END; IF setorg THEN SetAllOrgs(Clock(Enext_1(Fnext_1(Enext_1(ta[n-1])))),Org(Enext_1(a))); END; RETURN ta[n-1]; END Glue; (* === GLOBAL PROCEDURES === *) VAR seenNode: REF ARRAY OF Node := NIL; nodeOnum: REF ARRAY OF CARDINAL := NIL; seenNodeCount: CARDINAL := 0; PROCEDURE MarkNode(n: Node) = BEGIN IF seenNode = NIL OR NUMBER(seenNode^) <= seenNodeCount THEN DoubleseenNode() END; WITH k = seenNodeCount+0 DO seenNode[k] := n; nodeOnum[k] := n.num; n.num := k; INC(seenNodeCount) END END MarkNode; PROCEDURE DoubleseenNode() = VAR sz: CARDINAL; BEGIN IF seenNode = NIL THEN sz := 0 ELSE sz := NUMBER(seenNode^) END; WITH szNew = MAX(2*sz, 1000), seenNodeNew = NEW(REF ARRAY OF Node, szNew), nodeOnumNew = NEW(REF ARRAY OF CARDINAL, szNew) DO IF seenNode # NIL THEN SUBARRAY(seenNodeNew^, 0, sz) := seenNode^; SUBARRAY(nodeOnumNew^, 0, sz) := nodeOnum^; END; seenNode := seenNodeNew; nodeOnum := nodeOnumNew; END END DoubleseenNode; PROCEDURE NodeIsMarked(n: Node) : BOOLEAN = BEGIN RETURN (n.num < seenNodeCount) AND (seenNode[n.num] = n) END NodeIsMarked; PROCEDURE UnmarkMarkedNodes() = BEGIN WHILE seenNodeCount > 0 DO WITH k = seenNodeCount-1, n = seenNode[k] DO n.num := nodeOnum[k]; DEC(seenNodeCount) END END END UnmarkMarkedNodes; PROCEDURE EnumVertices(a: Pair; visit: VisitProc) = CONST IniStackSize = 1000; VAR festack := NEW(REF ARRAY OF FacetEdge, IniStackSize); bstack := NEW(REF ARRAY OF SRBits, IniStackSize); top : CARDINAL; (* top for "festack" stack *) PROCEDURE DoubleStack() = BEGIN WITH sz = NUMBER(festack^), szNew = 2*sz, festackNew = NEW(REF ARRAY OF FacetEdge, szNew), bstackNew = NEW(REF ARRAY OF SRBits, szNew) DO SUBARRAY(festackNew^, 0, sz):= festack^; festack := festackNew; SUBARRAY(bstackNew^, 0, sz) := bstack^; bstack := bstackNew; END END DoubleStack; PROCEDURE Stack(c: Pair) = VAR cn : Pair := c; dn : Pair; BEGIN REPEAT IF top > LAST(festack^) THEN DoubleStack() END; festack[top] := cn.facetedge; bstack[top] := cn.bits; top := top + 1; dn := Clock(Enext_1(cn)); REPEAT IF top > LAST(festack^) THEN DoubleStack() END; festack[top] := dn.facetedge; bstack[top] := dn.bits; top := top + 1; dn := Fnext(dn); UNTIL( dn = Clock(Enext_1(cn)) ); cn := Fnext(cn); UNTIL (cn = c); END Stack; PROCEDURE VisitAndMark(c: Pair)= (* If org(c) is diferent that the origins pairs stacked, stack the pair "c". *) VAR cn : Pair; BEGIN WITH n = Org(c) DO IF n # NIL AND NOT NodeIsMarked(n) THEN visit(c); MarkNode(n); Stack(c); cn := c; REPEAT Stack(cn); cn := Onext(cn); UNTIL (cn = c) END END; END VisitAndMark; VAR seen: CARDINAL; BEGIN top := 0; seen := 0; <* ASSERT seenNodeCount = 0 *> VisitAndMark(a); WHILE seen < top DO WITH b = Pair{festack[seen], bstack[seen]} DO VisitAndMark(Fnext(b)); VisitAndMark(Fnext(Enext(b))); VisitAndMark(Enext(b)); VisitAndMark(Fnext_1(Enext_1(b))); END; seen := seen + 1; END; UnmarkMarkedNodes(); END EnumVertices; PROCEDURE NumberVertices(a: Pair): CARDINAL = VAR n: CARDINAL := 0; PROCEDURE Visit(c: Pair) = PROCEDURE Visit_(c: Pair) = VAR cn,dn: Pair; BEGIN WITH v = Org(c) DO cn := c; REPEAT WITH vn = Org(cn) DO <* ASSERT vn = v *> vn.num := n; dn := Clock(Enext_1(cn)); REPEAT WITH wn = Org(dn) DO <* ASSERT wn = vn *> wn.num := n; dn := Fnext(dn); END; UNTIL ( dn = Clock(Enext_1(cn)) ); cn := Fnext(cn); END; UNTIL ( cn = c ); END; END Visit_; VAR cn: Pair := c; BEGIN REPEAT Visit_(cn); cn := Onext(cn); UNTIL cn = c; INC(n); END Visit; PROCEDURE VisitDual(c: Pair) = PROCEDURE VisitDual_(c: Pair) = VAR cn: Pair; p,pn: Node; BEGIN p := Org(c); IF p # NIL THEN cn := c; REPEAT pn := Org(cn); IF pn # NIL THEN <* ASSERT pn = p *> pn.num := n; END; cn := Fnext(cn); UNTIL( cn = c ) END; END VisitDual_; VAR cn: Pair := c; BEGIN VisitDual_(cn); VisitDual_(Clock(Enext_1(cn))); INC(n); END VisitDual; BEGIN IF Octf.DualBit(a) = 0 THEN EnumVertices(a, Visit); ELSE EnumVertices(a, VisitDual); END; RETURN n END NumberVertices; PROCEDURE MakeTopology(a: Pair) : Topology = VAR top : Topology; euler : INTEGER; BEGIN top.NV := NumberVertices(a); top.vertex := NEW(REF ARRAY OF Vertex, top.NV); top.facetedge := Octf.NumberFacetEdges(ARRAY OF Pair{a}); top.NFE := NUMBER(top.facetedge^); top.edge := Octf.NumberEdges(ARRAY OF Pair{top.facetedge[0]}); top.face := Octf.NumberFacets(ARRAY OF Pair{top.facetedge[0]}); top.out := NEW(REF ARRAY OF Pair, top.NV); top.NE := NUMBER(top.edge^); top.NF := NUMBER(top.face^); top.NP := NumberVertices(Srot(a)); top.polyhedron := NEW(REF ARRAY OF Polyhedron, top.NP); top.region := NEW(REF ARRAY OF Pair, top.NP); (* top.der := Octf.DegreeEdgeRing(top.face[0].pa); top.bdr := bdr; *) FOR i:= 0 TO top.NFE-1 DO VAR c: Pair := top.facetedge[i]; v,p: Node; vi,pi: CARDINAL; BEGIN FOR k:= 0 TO 1 DO v := Org(c); vi := v.num; top.vertex[vi] := v; top.out[vi] := c; p := Pneg(c); IF p # NIL THEN pi := p.num; top.polyhedron[pi] := p; top.region[pi] := Srot(c); <* ASSERT Pneg(c) = Org(top.region[pi]) *> END; c := Clock(c); END END END; WITH m = Mis.NumDigits(top.NFE)+1 DO Wr.PutText(stderr, "\n"); Wr.PutText(stderr, "nv := " & Fmt.Pad(Fmt.Int(top.NV),m) & "\n"); Wr.PutText(stderr, "ne := " & Fmt.Pad(Fmt.Int(top.NE),m) & "\n"); Wr.PutText(stderr, "nf := " & Fmt.Pad(Fmt.Int(top.NF),m) & "\n"); Wr.PutText(stderr, "np := " & Fmt.Pad(Fmt.Int(top.NP),m) & "\n"); Wr.PutText(stderr, "nfe := " & Fmt.Pad(Fmt.Int(top.NFE),m) & "\n"); END; (* Euler's Number *) euler := top.NV-top.NE+top.NF-top.NP; IF euler = 0 THEN Wr.PutText(stderr,"\nThe Map performs the Euler's Number = 0\n"); ELSE Wr.PutText(stderr,"\nThe Euler's Number: " & Fmt.Int(euler) & "\n"); END; RETURN top; END MakeTopology; PROCEDURE GetTetraCorners(a : Pair) : TetraCorners = VAR c : TetraCorners; BEGIN WITH a0 = a, a1 = Enext(a0), a2 = Enext(a1), b0 = Clock(Fnext_1(a0)), c0 = Clock(Fnext_1(a1)), d0 = Clock(Fnext_1(a2)) DO (* the 12 elements on the array must have the same negative polyhedron. *) c[0 ] := a0; c[1 ] := Enext(a0); c[2 ] := Enext_1(a0); c[3 ] := b0; c[4 ] := Enext(b0); c[5 ] := Enext_1(b0); c[6 ] := c0; c[7 ] := Enext(c0); c[8 ] := Enext_1(c0); c[9 ] := d0; c[10] := Enext(d0); c[11] := Enext_1(d0); <* ASSERT c[0] = a *> END; RETURN c; END GetTetraCorners; PROCEDURE CollectTetrahedra(READONLY tp: Topology) : REF ARRAY OF Pair = VAR seen,processed,conflicts: CARDINAL := 0; BEGIN WITH rt = NEW(REF ARRAY OF Pair, tp.NP), t = rt^ , q = NEW(REF ARRAY OF Pair, tp.NP) DO FOR i := 0 TO LAST(t) DO t[i] := Pair{facetedge := NIL, bits := 0}; END; FOR k := 0 TO LAST(t) DO IF t[k].facetedge = NIL THEN t[k] := Tors(tp.region[k]); q[seen] := t[k]; INC(seen); WHILE processed < seen DO WITH a = q[processed] DO PROCEDURE Visit(f: Pair) = BEGIN IF Pneg(f) = NIL THEN RETURN END; <* ASSERT Consistent(a,f) *> WITH n = Pneg(f).num DO IF t[n].facetedge = NIL THEN t[n] := f; q[seen] := f; INC(seen); ELSE <* ASSERT Pneg(t[n]).num = n *> IF NOT SameOrientation(t[n],f) THEN INC(conflicts) END END END END Visit; PROCEDURE Consistent(p,q:Pair) : BOOLEAN = (* Checks whether Pneg(q) and the Pneg(q) are adjacentes tetrahedra with consistent orientations. *) BEGIN WITH cp = GetTetraCorners(p), cq = GetTetraCorners(q) DO FOR i := 0 TO 11 DO FOR j := 0 TO 11 DO IF cp[i] = Clock(cq[j]) THEN RETURN TRUE END; END; END; RETURN FALSE; END END Consistent; PROCEDURE SameOrientation(p,q:Pair) : BOOLEAN = (* Checks whether Pneg(p) = Pneg(q) and both have the same orientation. *) BEGIN WITH cp = GetTetraCorners(p) DO FOR i := 0 TO 11 DO IF cp[i] = q THEN RETURN TRUE END; END; RETURN FALSE; END END SameOrientation; BEGIN WITH b = Fnext(a), c = Fnext_1(Enext(a)), d = Fnext_1(Enext_1(a)), e = Fnext_1(a) DO Visit(b); Visit(c); Visit(d); Visit(e); END END; INC(processed); END END END END; IF conflicts # 0 THEN Wr.PutText(Stdio.stderr, "CollectTetrahedra: conflicts = " & Fmt.Int(conflicts) & "\n"); END; <* ASSERT processed = tp.NP *> RETURN rt; END; END CollectTetrahedra; PROCEDURE DegreeOfVertex(a: Pair) : CARDINAL = BEGIN WITH edge = Octf.NumberEdgesForDegree(ARRAY OF Pair{a}), degree = NUMBER(edge^) DO RETURN degree; END; END DegreeOfVertex; PROCEDURE MakeAdjacencyMatrix(READONLY top: Topology): REF AdjacencyMatrix = VAR m := NEW(REF ARRAY OF ARRAY OF BOOLEAN, top.NV, top.NV); BEGIN FOR i := 0 TO top.NV-1 DO WITH mi = m[i] DO FOR j := 0 TO top.NV-1 DO mi[j] := FALSE END END END; FOR ei := 0 TO top.NFE-1 DO WITH a = top.facetedge[ei] DO WITH i = Org(a).num, j = Org(Clock(a)).num DO m[i,j] := TRUE; m[j,i] := TRUE; END END END; RETURN m; END MakeAdjacencyMatrix; PROCEDURE TriviallyIsomorphic(READONLY ta, tb: Topology): BOOLEAN = BEGIN IF ta.NV # tb.NV OR ta.NF # tb.NF OR ta.NE # tb.NE OR ta.NP # tb.NP OR ta.NFE # tb.NFE THEN RETURN FALSE END; WITH NFE = ta.NFE DO FOR i := 0 TO NFE-1 DO VAR sa: Pair := ta.facetedge[i]; sb: Pair := tb.facetedge[i]; BEGIN FOR r := 0 TO 3 DO WITH na = Org(sa).num, nb = Org(sb).num DO IF na # nb THEN RETURN FALSE END END; WITH za = GetPairNum(Fnext(sa)), zb = GetPairNum(Fnext(sb)) DO IF za # zb THEN RETURN FALSE END END; sa := Srot(sa); sb := Srot(sb); END END END END; RETURN TRUE END TriviallyIsomorphic; PROCEDURE CheckOutAndRegion(READONLY top: Topology) = BEGIN FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i], e = top.out[i] DO <* ASSERT v.num = i *> <* ASSERT Org(e) = v *> END END; FOR i := 0 TO top.NP-1 DO WITH p = top.polyhedron[i], r = top.region[i] DO <* ASSERT p.num = i *> <* ASSERT Org(r) = p *> END END; END CheckOutAndRegion; PROCEDURE GetVariableVertices(READONLY top: Topology; VAR vr: ARRAY OF BOOLEAN) = BEGIN FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i] DO vr[i] := NOT v.fixed; END; END; END GetVariableVertices; (* === GEOMETRIC TOOLS === *) PROCEDURE InitCoords( coins: Random.T; VAR c: Coords; radius: REAL := 1.0 ) = BEGIN WITH r = FLOAT(radius, LONGREAL) DO FOR i := 0 TO LAST(c) DO c[i] := LR4.T{ coins.longreal(-r, r), coins.longreal(-r, r), coins.longreal(-r, r), coins.longreal(-r, r) } END END END InitCoords; PROCEDURE GenCoords(READONLY t: Topology) : REF Coords = BEGIN WITH coins = NEW(Random.Default).init(TRUE), r = NEW(REF Coords, t.NV), c = r^ DO FOR i := 0 TO LAST(c) DO c[i] := LR4.T{ coins.longreal(-1.0d0, +1.0d0), coins.longreal(-1.0d0, +1.0d0), coins.longreal(-1.0d0, +1.0d0), coins.longreal(-1.0d0, +1.0d0) } END; RETURN r END END GenCoords; PROCEDURE Barycenter(READONLY top: Topology; READONLY c: Coords; all: BOOL): LR4.T = VAR b: LR4.T := LR4.T{0.0d0, ..}; N: CARDINAL := 0; BEGIN FOR i := 0 TO LAST(c) DO WITH v = top.vertex[i] DO IF all OR v.exists THEN b := LR4.Add(b, c[i]); INC(N) END; END; END; IF N = 0 THEN RETURN b ELSE RETURN LR4.Scale(1.0d0/FLOAT(N, LONGREAL), b) END END Barycenter; PROCEDURE PartialBarycenter(READONLY v: Vertices; READONLY c: Coords; all: BOOL): LR4.T = VAR b: LR4.T := LR4.T{0.0d0, ..}; N: CARDINAL := 0; BEGIN FOR k := 0 TO LAST(c) DO WITH vk = v[k], i = vk.num DO IF all OR vk.exists THEN b := LR4.Add(b, c[i]); INC(N) END; END; END; IF N = 0 THEN RETURN b ELSE RETURN LR4.Scale(1.0d0/FLOAT(N, LONGREAL), b) END END PartialBarycenter; PROCEDURE MeanVertexDistance( READONLY top: Topology; READONLY c: Coords; READONLY ctr: LR4.T; all: BOOL; ): LONGREAL = VAR S: LONGREAL := 0.0d0; N: CARDINAL := 0; BEGIN FOR i := 0 TO LAST(c) DO WITH v = top.vertex[i] DO IF all OR v.exists THEN WITH d2 = LR4.DistSqr(ctr, c[i]) DO S := S + d2 END; INC(N) END END END; IF N = 0 THEN RETURN 1.0d0 ELSE RETURN Math.sqrt(S/FLOAT(N,LONGREAL)) END END MeanVertexDistance; PROCEDURE MaxVertexDistance( READONLY top: Topology; READONLY c: Coords; READONLY ctr: LR4.T; all: BOOL; ): LONGREAL = VAR radius := 0.0d0; BEGIN FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i] DO IF all OR v.exists THEN WITH d = LR4.Dist(ctr, c[i]) DO IF d > radius THEN radius := d END END END END END; RETURN radius END MaxVertexDistance; PROCEDURE MeanThickness( READONLY top: Topology; READONLY c: Coords; READONLY ctr: LR4.T; READONLY norm: LR4.T; all: BOOL; ): LONGREAL = VAR S : LONGREAL := 0.0d0; N: CARDINAL := 0; BEGIN FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i] DO IF all OR v.exists THEN WITH d = LR4.Dot(LR4.Sub(c[i],ctr), norm) DO S := S + d*d; END; INC(N) END END END; IF N = 0 THEN RETURN 1.0d0 ELSE RETURN Math.sqrt(S/FLOAT(N,LONGREAL)) END END MeanThickness; PROCEDURE MeanEdgeLength(READONLY top: Topology; READONLY c: Coords; all: BOOL): LONGREAL = VAR S: LONGREAL := 0.0d0; N: CARDINAL := 0; BEGIN FOR i := 0 TO top.NE-1 DO WITH e = top.edge[i] DO IF all OR e.exists THEN WITH o = OrgV(e.pa).num, d = OrgV(Clock(e.pa)).num DO S := S + LR4.DistSqr(c[o], c[d]) END; INC(N); END END END; IF N = 0 THEN RETURN 1.0d0 ELSE RETURN Math.sqrt(S/FLOAT(N,LONGREAL)) END END MeanEdgeLength; PROCEDURE MeanPolyhedronNormal(READONLY top: Topology; READONLY c: Coords; all: BOOL): LR4.T = VAR norm: LR4.T := LR4.T{0.0d0, ..}; BEGIN FOR i := 0 TO top.NP-1 DO WITH f = Tors(top.region[i]), p = PnegP(f) DO IF all OR (p # NIL AND p.exists) THEN WITH n = PolyCross(f, c) DO norm := LR4.Add(norm, n) END END END END; WITH m = LR4.Norm(norm) DO IF m < 1.0d-20 THEN RETURN LR4.T{0.0d0, 0.0d0, 0.0d0, 1.0d0} ELSE RETURN LR4.Scale(1.0d0/m, norm); END END END MeanPolyhedronNormal; PROCEDURE Displace(READONLY top: Topology; d: LR4.T; VAR c: Coords) = BEGIN FOR i := 0 TO LAST(c) DO IF top.vertex[i].exists THEN WITH vc = c[i] DO vc := LR4.Add(vc, d) END END END END Displace; PROCEDURE Scale(READONLY top: Topology; s: LONGREAL; VAR c: Coords) = BEGIN FOR i := 0 TO LAST(c) DO IF top.vertex[i].exists THEN WITH vc = c[i] DO vc := LR4.Scale(s, vc) END; END END END Scale; PROCEDURE NormalizeVertexDistances(READONLY top: Topology; VAR c: Coords; all: BOOL) = BEGIN WITH b = Barycenter(top, c, all) DO Displace(top, LR4.Neg(b), c) END; WITH s = MeanVertexDistance(top, c, LR4.T{0.0d0, ..}, all) DO Scale(top, 1.0d0/s, c) END; END NormalizeVertexDistances; PROCEDURE NormalizeEdgeLengths(READONLY top: Topology; VAR c: Coords; all: BOOL) = BEGIN WITH b = Barycenter(top, c, all) DO Displace(top, LR4.Neg(b), c) END; WITH s = MeanEdgeLength(top, c, all) DO Scale(top, 1.0d0/s, c) END; END NormalizeEdgeLengths; PROCEDURE FaceCross(a: Pair; READONLY c: Coords): LR4.T = BEGIN IF NOT a.facetedge.face.exists THEN RETURN LR4.T{1.0d0, 0.0d0, 0.0d0, 0.0d0} ELSE WITH ov = OrgV(a), dv = OrgV(Clock(a)), pv = OrgV(Enext_1(a)), qv = OrgV(Enext_1(Fnext(a))), rv = OrgV(Enext_1(Fnext_1(a))) DO WITH o = c[ov.num], d = c[dv.num], p = c[pv.num], q = c[qv.num], r = c[rv.num], n1 = LR4Extras.Cross(LR4.Sub(p,o), LR4.Sub(r,o), LR4.Sub(d,o)), n2 = LR4Extras.Cross(LR4.Sub(p,o), LR4.Sub(d,o), LR4.Sub(q,o)) DO RETURN LR4.Add(n1,n2); END END END END FaceCross; PROCEDURE FaceNormal(a: Pair; READONLY c: Coords): LR4.T = BEGIN WITH n = FaceCross(a,c), s = LR4.Norm(n) DO IF s = 0.0d0 THEN RETURN LR4.T{1.0d0, 0.0d0, 0.0d0, 0.0d0} ELSE RETURN LR4.Scale(1.0d0/s, n) END END END FaceNormal; PROCEDURE PolyCross(a: Pair; READONLY c: Coords): LR4.T = BEGIN IF NOT PnegP(a).exists THEN RETURN LR4.T{1.0d0, 0.0d0, 0.0d0, 0.0d0} ELSE WITH ov = OrgV(a), dv = OrgV(Clock(a)), pv = OrgV(Enext_1(a)), rv = OrgV(Enext_1(Fnext_1(a))) DO WITH o = c[ov.num], d = c[dv.num], p = c[pv.num], r = c[rv.num] DO RETURN LR4Extras.Cross(LR4.Sub(p,o), LR4.Sub(r,o), LR4.Sub(d,o)); END END END END PolyCross; PROCEDURE PolyNormal(a: Pair; READONLY c: Coords): LR4.T = BEGIN WITH n = PolyCross(a, c), s = LR4.Norm(n) DO IF s = 0.0d0 THEN RETURN LR4.T{1.0d0, 0.0d0, 0.0d0, 0.0d0} ELSE RETURN LR4.Scale(1.0d0/s, n) END END END PolyNormal; PROCEDURE FaceBarycenter(a: Pair; READONLY c: Coords): LR4.T = VAR ao : Pair; n : CARDINAL := 0; sum := LR4.T{0.0d0, ..}; BEGIN ao := a; REPEAT WITH aoc = c[OrgV(ao).num] DO sum := LR4.Add(sum, aoc); INC(n); ao := Enext(ao); END; UNTIL (ao = a); IF n = 0 THEN RETURN sum ELSE RETURN LR4.Scale(1.0d0/FLOAT(n,LONGREAL), sum) END END FaceBarycenter; PROCEDURE TetraBarycenter(a: Pair; READONLY c: Coords): LR4.T = VAR n : CARDINAL := 0; sum := LR4.T{0.0d0, ..}; BEGIN WITH tetra = TetraNegVertices(a) DO FOR i := 0 TO 3 DO WITH aoc = c[tetra[i].num] DO sum := LR4.Add(sum, aoc); INC(n); END END END; RETURN LR4.Scale(1.0d0/FLOAT(n,LONGREAL), sum) END TetraBarycenter; PROCEDURE EdgeCross(a: Pair; READONLY c: Coords): LR4.T = VAR sum: LR4.T := LR4.T{0.0d0,..}; ao : Pair; BEGIN WITH uv = OrgV(a), u = c[uv.num] DO IF NOT a.facetedge.edge.exists THEN RETURN LR4.T{1.0d0, 0.0d0, 0.0d0, 0.0d0} ELSE ao := a; REPEAT WITH an = Fnext_1(ao), dv = OrgV(Clock(ao)), pv = OrgV(Enext_1(ao)), rv = OrgV(Enext_1(an)) DO WITH d = c[dv.num], p = c[pv.num], r = c[rv.num], n = LR4Extras.Cross(LR4.Sub(p,u), LR4.Sub(d,u), LR4.Sub(r,u)) DO IF ao = a THEN sum := n; ELSE sum := LR4.Add(sum,n) END; END; ao := an; END; UNTIL (ao = a); RETURN sum; END END; END EdgeCross; PROCEDURE EdgeNormal(a: Pair; READONLY c: Coords): LR4.T = BEGIN WITH n = EdgeCross(a, c), s = LR4.Norm(n) DO IF s = 0.0d0 THEN RETURN LR4.T{1.0d0, 0.0d0, 0.0d0, 0.0d0} ELSE RETURN LR4.Scale(1.0d0/s, n) END END END EdgeNormal; PROCEDURE VertexCross(a: Pair; READONLY c: Coords; READONLY top : Topology): LR4.T = VAR sum,n: LR4.T := LR4.T{0.0d0, ..}; BEGIN WITH uv = OrgV(a), poly = StarOfVertex(a,top) DO IF NOT uv.exists THEN RETURN LR4.T{1.0d0, 0.0d0, 0.0d0, 0.0d0} ELSE FOR i := 0 TO LAST(poly^) DO IF poly[i][0].exists AND poly[i][1].exists AND poly[i][2].exists AND poly[i][3].exists THEN WITH u = c[poly[i][0].num], d = c[poly[i][1].num], p = c[poly[i][2].num], r = c[poly[i][3].num] DO n:= LR4Extras.Cross(LR4.Sub(p,u), LR4.Sub(d,u), LR4.Sub(r,u)); IF i = 0 THEN sum := n; ELSE sum := LR4.Add(sum,n) END; END; END; END; END; RETURN sum; END; END VertexCross; PROCEDURE VertexNormal(a: Pair; READONLY c: Coords; READONLY top: Topology): LR4.T = BEGIN WITH n = VertexCross(a, c, top), s = LR4.Norm(n) DO IF s = 0.0d0 THEN RETURN LR4.T{1.0d0, 0.0d0, 0.0d0, 0.0d0} ELSE RETURN LR4.Scale(1.0d0/s, n) END END END VertexNormal; PROCEDURE Neighbors( v: Vertex; READONLY top: Topology; ): REF Vertices = VAR rv: REF Vertices := NIL; nv: CARDINAL := 0; PROCEDURE Stack(u: Vertex) = BEGIN IF rv = NIL OR nv >= NUMBER(rv^) THEN WITH sv = NEW(REF Vertices, MAX(10, 2*nv)) DO IF rv # NIL THEN SUBARRAY(sv^, 0, nv) := rv^ END; rv := sv END END; rv[nv] := u; INC(nv); END Stack; PROCEDURE Check(b: Pair) = BEGIN IF OrgV(b) = v THEN Stack(OrgV(Clock(b))) END END Check; BEGIN FOR i := 0 TO top.NE - 1 DO WITH ei = top.edge[i].pa DO Check(ei); Check(Clock(ei)) END END; WITH r = NEW(REF Vertices, nv) DO r^ := SUBARRAY(rv^, 0, nv); RETURN r; END; END Neighbors; PROCEDURE StarOfVertex(a: Pair; READONLY top: Topology) : REF ARRAY OF Quadv = PROCEDURE VertexPoly(READONLY top : Topology): REF ARRAY OF Quadp = (* Return four pairs facetedges such as the origins corresponding to vertices extremes of each tetrahedron of Triangulation. *) VAR poly : REF ARRAY OF Quadp := NEW(REF ARRAY OF Quadp, top.NP); BEGIN FOR i := 0 TO top.NP-1 DO WITH da = top.region[i], a0 = Tors(da), db = Clock(Enext_1(da)), b0 = Tors(db) DO (*<* ASSERT DegreeOfVertex(a0) = 4 *> *) (* consuming time *) WITH a1 = Enext(a0), a2 = Enext(a1), a3 = Enext_1(b0) DO IF Enext(a2) # a0 THEN Wr.PutText(stderr, "\nTriangulation: This topology isn't" & " a triangulation\n"); <* ASSERT Enext(a2) = a0 *> END; <* ASSERT Pneg(a0).num = i *> IF Pneg(b0) # NIL THEN <* ASSERT Pneg(a0) = Pneg(b0) *> END; <* ASSERT a0 # b0 *> poly[i] := Quadp{a0,a1,a2,a3}; END END END; RETURN poly; END VertexPoly; VAR poly1 : REF ARRAY OF Quadv := NEW(REF ARRAY OF Quadv, top.NP); n : CARDINAL := 0; BEGIN WITH poly = VertexPoly(top), v = OrgV(a) DO FOR i := 0 TO LAST(poly^) DO IF (OrgV(poly[i][0]) = v) OR (OrgV(poly[i][1]) = v) OR (OrgV(poly[i][2]) = v) OR (OrgV(poly[i][3]) = v) THEN FOR j := 0 TO 3 DO IF OrgV(poly[i][j]) = v THEN WITH uv = OrgV(poly[i][j]), dv = OrgV(Enext(poly[i][j])), pv = OrgV(Enext_1(poly[i][j])), rv = OrgV(Enext_1(Fnext_1(poly[i][j]))) DO poly1[n] := Quadv{uv,dv,pv,rv}; INC(n); END END END END END; WITH r = NEW(REF ARRAY OF Quadv, n) DO r^ := SUBARRAY(poly1^, 0, n); RETURN r; END; END; END StarOfVertex; PROCEDURE NumberPolyOfStar(quad: REF ARRAY OF Quadv): CARDINAL = BEGIN WITH n = NUMBER(quad^) DO RETURN n; END; END NumberPolyOfStar; PROCEDURE ComputeAllVertexNormals( READONLY top: Topology; READONLY c: Coords; ): REF ARRAY OF LR4.T = BEGIN WITH rvn = NEW(REF ARRAY OF LR4.T, top.NV), vn = rvn^ DO FOR i := 0 TO top.NV-1 DO vn[i] := VertexNormal(top.out[i], c, top) END; RETURN rvn END; END ComputeAllVertexNormals; PROCEDURE ComputeAllEdgeNormals( READONLY top: Topology; READONLY c: Coords; ): REF ARRAY OF LR4.T = BEGIN WITH rvn = NEW(REF ARRAY OF LR4.T, top.NE), vn = rvn^ DO FOR i := 0 TO top.NE-1 DO vn[i] := EdgeNormal(top.edge[i].pa, c); END; RETURN rvn END; END ComputeAllEdgeNormals; PROCEDURE ComputeAllFaceNormals( READONLY top: Topology; READONLY c: Coords; ): REF ARRAY OF LR4.T = BEGIN WITH rvn = NEW(REF ARRAY OF LR4.T, top.NF), vn = rvn^ DO FOR i := 0 TO top.NF-1 DO vn[i] := FaceNormal(top.face[i].pa, c); END; RETURN rvn END; END ComputeAllFaceNormals; PROCEDURE ComputeAllPolyhedronNormals( READONLY top: Topology; READONLY c: Coords; ): REF ARRAY OF LR4.T = BEGIN WITH rvn = NEW(REF ARRAY OF LR4.T, top.NP), vn = rvn^ DO FOR i := 0 TO top.NP-1 DO vn[i] := PolyNormal(Tors(top.region[i]), c); END; RETURN rvn END; END ComputeAllPolyhedronNormals; PROCEDURE MakePolyhedronTopology(a: Pair): PolyhedronTopology = VAR ne, nv: CARDINAL; b, bn: Pair; ptop: PolyhedronTopology; BEGIN WITH pneg = Org(a), star = Octf.NumberEdgesForDegree(ARRAY OF Pair{a})^ DO (* Gather faces: *) ptop.NF := NUMBER(star); ptop.fRef := NEW(REF ARRAY OF Pair, ptop.NF); ne := 0; FOR i := 0 TO ptop.NF-1 DO WITH side = Octf.Sdual(star[i]) DO ptop.fRef[i] := side; <* ASSERT Pneg(ptop.fRef[i]) = pneg *> b := side; REPEAT INC(ne); WITH e = b.facetedge.edge DO e.xmark := FALSE; OrgV(b).xmark := FALSE; (* OrgV(b).xmark := FALSE *) END; b := Enext(b) UNTIL b = side; END END; (* Gather edges: *) <* ASSERT ne MOD 2 = 0 *> ptop.NE := ne DIV 2; ptop.eRef := NEW(REF ARRAY OF Pair, ptop.NE); ne := 0; FOR i := 0 TO ptop.NF-1 DO WITH side = Octf.Sdual(star[i]) DO b := side; REPEAT WITH e = b.facetedge.edge DO IF NOT e.xmark THEN ptop.eRef[ne] := b; <* ASSERT Pneg(ptop.eRef[ne]) = pneg *> bn := b; REPEAT bn.facetedge.edge.xmark := TRUE; bn := Fnext(bn); UNTIL (bn = b); INC(ne); END; END; b := Enext(b) UNTIL b = side END END; (* Gather vertices: *) ptop.NV := 2 + ptop.NE - ptop.NF; ptop.vRef := NEW(REF ARRAY OF Pair, ptop.NV); nv := 0; FOR i := 0 TO ptop.NE-1 DO WITH eu = ptop.eRef[i], u = OrgV(eu), ev = Clock(Fnext_1(eu)), v = OrgV(ev) DO IF NOT u.xmark THEN ptop.vRef[nv] := eu; <* ASSERT Pneg(ptop.vRef[nv]) = pneg *> INC(nv); u.xmark := TRUE; END; IF NOT v.xmark THEN ptop.vRef[nv] := ev; <* ASSERT Pneg(ptop.vRef[nv]) = pneg *> INC(nv); v.xmark := TRUE END; eu.facetedge.edge.xmark := FALSE; END; END; FOR i := 0 TO ptop.NV-1 DO WITH u = OrgV(ptop.vRef[i]) DO u.xmark := FALSE END END; END; RETURN ptop END MakePolyhedronTopology; (* ========== INPUT/OUTPUT ================== *) CONST Boole = Mis.Boole; AlphaChars = Mis.AlphaChars; PROCEDURE ReadTopology(rd: Rd.T): TopCom = VAR top: Topology; comments: TEXT; n : CHAR; BEGIN (* Topology *) ReadHeader(rd,"topology","99-08-25"); comments := Mis.ReadCommentsJS(rd, '|'); (* Element counts: *) Lex.Skip(rd, cs := AlphaChars); top.NV := Lex.Int(rd); Lex.Skip(rd, cs := AlphaChars); top.NE := Lex.Int(rd); Lex.Skip(rd, cs := AlphaChars); top.NF := Lex.Int(rd); Lex.Skip(rd, cs := AlphaChars); top.NP := Lex.Int(rd); Lex.Skip(rd, cs := AlphaChars); top.NFE := Lex.Int(rd); Lex.Skip(rd, cs := AlphaChars); EVAL Lex.Int(rd); (* top.der *) Lex.Skip(rd, cs := AlphaChars); EVAL Lex.Int(rd); (* top.bdr *) Lex.Skip(rd); WITH map = NEW(REF ARRAY OF Octf.FacetEdge, top.NFE)^ DO (* Create vertex records: *) top.vertex := NEW(REF ARRAY OF Vertex, top.NV); top.out := NEW(REF ARRAY OF Pair, top.NV); FOR i := 0 TO top.NV-1 DO top.vertex[i] := MakeVertex(); END; (* Create edges records *) top.edge := NEW(REF ARRAY OF Octf.Edge, top.NE); FOR i := 0 TO top.NE-1 DO top.edge[i] := Octf.MakeEdge(); FOR j := 0 TO 1 DO top.edge[i].vertex[j] := MakeVertex(); END; END; (* Create face records: *) top.face := NEW(REF ARRAY OF Face, top.NF); FOR i := 0 TO top.NF-1 DO top.face[i] := Octf.MakeFace(); (* top.face[i].vertex := NEW(REF ARRAY OF Node,top.der); FOR j := 0 TO top.der-1 DO top.face[i].vertex^[j] := MakeVertex(); END; *) END; (* Create polyhedra records: *) top.polyhedron := NEW(REF ARRAY OF Polyhedron, top.NP); top.region := NEW(REF ARRAY OF Pair, top.NP); FOR i := 0 TO top.NP-1 DO top.polyhedron[i] := MakePolyhedron(); (* IF top.der = 3 THEN IF top.bdr = 2 THEN (* Obs: bdr=2 indicate that the cells are octahedra. *) top.polyhedron[i].vertex := NEW(REF ARRAY OF Node,top.der+3); FOR j := 0 TO top.der+2 DO top.polyhedron[i].vertex^[j] := MakeVertex(); END; ELSE top.polyhedron[i].vertex := NEW(REF ARRAY OF Node,top.der+1); FOR j := 0 TO top.der DO top.polyhedron[i].vertex^[j] := MakeVertex(); END END ELSIF top.der = 4 THEN top.polyhedron[i].vertex := NEW(REF ARRAY OF Node,2*top.der); FOR j := 0 TO 2*top.der-1 DO top.polyhedron[i].vertex^[j] := MakeVertex(); END ELSIF top.der = 2 THEN top.polyhedron[i].vertex := NEW(REF ARRAY OF Node,2); FOR j := 0 TO 1 DO top.polyhedron[i].vertex^[j] := MakeVertex(); END ELSIF top.der = 5 THEN top.polyhedron[i].vertex := NEW(REF ARRAY OF Node,4*top.der); FOR j := 0 TO 19 DO top.polyhedron[i].vertex^[j] := MakeVertex(); END END *) END; (* Create facetedge records: *) top.facetedge := NEW(REF ARRAY OF Octf.Pair, top.NFE); FOR i := 0 TO top.NFE-1 DO top.facetedge[i] := MakeFacetEdge(); top.facetedge[i].facetedge.num := i; map[i] := top.facetedge[i].facetedge; END; (* Read edge data: *) EVAL Mis.ReadCommentsJS(rd, '|'); FOR j := 0 TO top.NE-1 DO Lex.Skip(rd); WITH ne = Lex.Int(rd), (* index to edge *) e = top.edge[ne] DO <* ASSERT ne = j *> e.num := ne; e.pa := Octf.ReadPair(rd,map); END; END; Lex.Skip(rd); (* Read face data: *) EVAL Mis.ReadCommentsJS(rd, '|'); FOR j := 0 TO top.NF-1 DO Lex.Skip(rd); WITH nf = Lex.Int(rd), (* index to face *) f = top.face[nf] DO <* ASSERT nf = j *> f.num := nf; f.pa := Octf.ReadPair(rd,map); END; END; Lex.Skip(rd); (* Read facetedge data: *) EVAL Mis.ReadCommentsJS(rd, '|'); FOR j := 0 TO top.NFE-1 DO Lex.Skip(rd); WITH nfe = Lex.Int(rd), (* index to facetedge *) fe = NARROW(top.facetedge[nfe].facetedge, FacetEdge) DO <* ASSERT nfe = j *> <* ASSERT top.facetedge[nfe].bits = 0 *> fe.num := nfe; Octf.ReadFacetEdge(rd, fe, map); FOR k := 0 TO 3 DO Lex.Skip(rd); n := Rd.GetChar(rd); IF n # '-' THEN Rd.UnGetChar(rd); WITH m = Lex.Int(rd), vf = fe.org[k] DO IF Rd.GetChar(rd) = 'v' THEN vf := top.vertex[m]; top.out[m] := Pair{facetedge := fe, bits := 2*k}; ELSE vf := top.polyhedron[m]; top.region[m] := Pair{facetedge := fe, bits := 2*k}; END; END; END; END; Lex.Skip(rd); fe.face.num := Lex.Int(rd); <* ASSERT Rd.GetChar(rd) = 'f' *> Lex.Skip(rd); fe.edge.num := Lex.Int(rd); <* ASSERT Rd.GetChar(rd) = 'e' *> END; END; ReadFooter(rd,"topology"); RETURN TopCom{top, comments} END END ReadTopology; PROCEDURE ReadMaterials( rd: Rd.T; READONLY top: Topology; ro_te: BOOLEAN := FALSE; ) = BEGIN (* Materials *) ReadHeader(rd,"materials","99-08-25"); (* Read vertex data Materials: *) EVAL Mis.ReadCommentsJS(rd, '|'); FOR j := 0 TO top.NV-1 DO Lex.Skip(rd); WITH nv = Lex.Int(rd), (* index to vertex *) v = top.vertex[nv] DO <* ASSERT nv = j *> v.num := nv; Lex.Skip(rd); v.exists := Mis.ReadBool(rd); Lex.Skip(rd); v.fixed := Mis.ReadBool(rd); Lex.Skip(rd); WITH cc = v.color DO cc[0] := Lex.Real(rd); Lex.Skip(rd); cc[1] := Lex.Real(rd); Lex.Skip(rd); cc[2] := Lex.Real(rd); END; Lex.Skip(rd); WITH tt = v.transp DO tt[0] := Lex.Real(rd); Lex.Skip(rd); tt[1] := Lex.Real(rd); Lex.Skip(rd); tt[2] := Lex.Real(rd); END; Lex.Skip(rd); v.radius := Lex.Real(rd); Lex.Skip(rd); v.label := Rd.GetText(rd,2); END END; Lex.Skip(rd); (* Read edge data materials: *) EVAL Mis.ReadCommentsJS(rd, '|'); FOR j := 0 TO top.NE-1 DO Lex.Skip(rd); WITH ne = Lex.Int(rd), (* index to edge *) e = top.edge[ne] DO <* ASSERT ne = j *> e.num := ne; Lex.Skip(rd); e.exists := Mis.ReadBool(rd); Lex.Skip(rd); WITH cc = e.color DO cc[0] := Lex.Real(rd); Lex.Skip(rd); cc[1] := Lex.Real(rd); Lex.Skip(rd); cc[2] := Lex.Real(rd); END; Lex.Skip(rd); WITH tt = e.transp DO tt[0] := Lex.Real(rd); Lex.Skip(rd); tt[1] := Lex.Real(rd); Lex.Skip(rd); tt[2] := Lex.Real(rd); END; Lex.Skip(rd); e.radius := Lex.Real(rd); Lex.Skip(rd); e.degenerate := Mis.ReadBool(rd); Lex.Skip(rd); WITH n = Rd.GetChar(rd) DO IF n # '-' THEN Rd.UnGetChar(rd); e.root := Lex.Int(rd); ELSE e.root := -1; END END END END; Lex.Skip(rd); (* Read face data materials: *) EVAL Mis.ReadCommentsJS(rd, '|'); FOR j := 0 TO top.NF-1 DO Lex.Skip(rd); WITH nf = Lex.Int(rd), (* index to face *) f = top.face[nf] DO <* ASSERT nf = j *> f.num := nf; Lex.Skip(rd); f.exists := Mis.ReadBool(rd); Lex.Skip(rd); WITH cc = f.color DO cc[0] := Lex.Real(rd); Lex.Skip(rd); cc[1] := Lex.Real(rd); Lex.Skip(rd); cc[2] := Lex.Real(rd); END; Lex.Skip(rd); WITH tt = f.transp DO tt[0] := Lex.Real(rd); Lex.Skip(rd); tt[1] := Lex.Real(rd); Lex.Skip(rd); tt[2] := Lex.Real(rd); END; Lex.Skip(rd); f.degenerate := Mis.ReadBool(rd); Lex.Skip(rd); WITH n = Rd.GetChar(rd) DO IF n # '-' THEN Rd.UnGetChar(rd); f.root := Lex.Int(rd); ELSE f.root := -1; END END END END; Lex.Skip(rd); (* Read polyhedron data materials: *) IF top.NP # 0 THEN EVAL Mis.ReadCommentsJS(rd, '|'); END; FOR j := 0 TO top.NP-1 DO Lex.Skip(rd); WITH np = Lex.Int(rd), (* index to polyhedron *) p = top.polyhedron[np] DO <* ASSERT np = j *> p.num := np; Lex.Skip(rd); p.exists := Mis.ReadBool(rd); Lex.Skip(rd); WITH cc = p.color DO cc[0] := Lex.Real(rd); Lex.Skip(rd); cc[1] := Lex.Real(rd); Lex.Skip(rd); cc[2] := Lex.Real(rd); END; Lex.Skip(rd); WITH tt = p.transp DO tt[0] := Lex.Real(rd); Lex.Skip(rd); tt[1] := Lex.Real(rd); Lex.Skip(rd); tt[2] := Lex.Real(rd); END; Lex.Skip(rd); EVAL Mis.ReadBool(rd); (* p.degenerate *) IF ro_te THEN Lex.Skip(rd); WITH n = Rd.GetChar(rd) DO IF n # '-' THEN Rd.UnGetChar(rd); p.root := Lex.Int(rd); ELSE p.root := -1; END END END END END; ReadFooter(rd,"materials"); Rd.Close(rd); CheckOutAndRegion(top); END ReadMaterials; PROCEDURE ReadToMa(name: TEXT; ro_te: BOOLEAN := FALSE): TopCom = (* Where ro_te meaning "root tetrahedron". *) VAR tc: TopCom; BEGIN WITH ntp = name & ".tp", rtp = FileRd.Open(ntp) DO Wr.PutText(stderr, "reading " & ntp & "\n"); tc := ReadTopology(rtp); Rd.Close(rtp); END; WITH nma = name & ".ma", rma = FileRd.Open(nma) DO Wr.PutText(stderr, "reading " & nma & "\n"); ReadMaterials(rma, tc.top, ro_te); Rd.Close(rma); END; RETURN tc END ReadToMa; PROCEDURE ReadState(name: TEXT): REF Coords = <* FATAL Rd.Failure, Thread.Alerted,FloatMode.Trap, Lex.Error, OSError.E *> VAR c: REF Coords; comments: TEXT; nv : CARDINAL; BEGIN WITH rs = FileRd.Open(name & ".st") DO (* Read Headers File Formats*) ReadHeader(rs,"state","99-08-25"); (* Element counts: *) Lex.Skip(rs, cs := AlphaChars); nv := Lex.Int(rs); Lex.Skip(rs); comments := Mis.ReadCommentsJS(rs, '|'); c := NEW(REF Coords, nv); (* Read vertex data state: *) FOR j := 0 TO nv-1 DO Lex.Skip(rs); WITH nv = Lex.Int(rs) DO WITH cv = c[nv] DO cv[0] := Lex.LongReal(rs); Lex.Skip(rs); cv[1] := Lex.LongReal(rs); Lex.Skip(rs); cv[2] := Lex.LongReal(rs); Lex.Skip(rs); cv[3] := Lex.LongReal(rs); END END END; ReadFooter(rs,"state"); Rd.Close(rs); RETURN c; END; END ReadState; PROCEDURE WriteState( name: TEXT; READONLY top: Topology; READONLY c: Coords; comments: TEXT := ""; ) = <* FATAL Wr.Failure, Thread.Alerted *> <* FATAL OSError.E *> BEGIN WITH st = FileWr.Open(name & ".st"), vWidth = Mis.NumDigits(top.NV - 1) DO PROCEDURE WriteCoord(x: LONGREAL) = BEGIN Wr.PutText(st, Fmt.Pad(Fmt.LongReal(x, Fmt.Style.Sci, prec := 3), 7)); END WriteCoord; PROCEDURE WritePoint(READONLY c: LR4.T) = BEGIN WriteCoord(c[0]); Wr.PutText(st, " "); WriteCoord(c[1]); Wr.PutText(st, " "); WriteCoord(c[2]); Wr.PutText(st, " "); WriteCoord(c[3]); END WritePoint; BEGIN WriteHeader(st,"state","99-08-25"); Wr.PutText(st, "vertices "); Wr.PutText(st, Fmt.Int(top.NV) & "\n"); IF NOT Text.Empty(comments) THEN Mis.WriteCommentsJS(st, comments & "\n", '|') END; Mis.WriteCommentsJS(st, "\nVertex data:\n", '|'); FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i] DO (* state *) Wr.PutText(st, Fmt.Pad(Fmt.Int(v.num), vWidth)); Wr.PutText(st, " "); WritePoint(c[v.num]); Wr.PutText(st, "\n"); END END; END; WriteFooter(st, "state"); Wr.Close(st); END; END WriteState; PROCEDURE WriteMaterials( name: TEXT; READONLY top: Topology; comments: TEXT := ""; ro_te: BOOLEAN := FALSE; (* root tetrahedron *) ) = <* FATAL Wr.Failure, Thread.Alerted, OSError.E *> VAR pWidth : INTEGER; BEGIN IF top.NP = 0 THEN pWidth := 2 ELSE pWidth := Mis.NumDigits(top.NP-1) END; WITH ma = FileWr.Open(name & ".ma"), vWidth = Mis.NumDigits(top.NV-1), fWidth = Mis.NumDigits(top.NF-1), eWidth = Mis.NumDigits(top.NE-1) DO PROCEDURE WriteIntensity(r: REAL) = BEGIN Wr.PutText(ma, Fmt.Real(r, Fmt.Style.Fix, prec := 2)); END WriteIntensity; PROCEDURE WriteColor(READONLY c: R3.T) = BEGIN WriteIntensity(c[0]); Wr.PutText(ma, " "); WriteIntensity(c[1]); Wr.PutText(ma, " "); WriteIntensity(c[2]); END WriteColor; PROCEDURE WriteRadius(r: REAL) = BEGIN IF r = 0.02 THEN Wr.PutText(ma, "0.020"); ELSE Wr.PutText(ma,Fmt.Real(r, prec := 4)); END END WriteRadius; PROCEDURE WriteLabel(label: TEXT) = BEGIN Wr.PutText(ma, label); END WriteLabel; BEGIN WriteHeader(ma,"materials","99-08-25"); IF NOT Text.Empty(comments) THEN WriteCommentsJS(ma, comments & "\n", '|') END; WITH m = Mis.NumDigits(top.NP) DO WriteCommentsJS(ma,"vertices " & Fmt.Pad(Fmt.Int(top.NV),m), '|'); WriteCommentsJS(ma,"edges " & Fmt.Pad(Fmt.Int(top.NE),m), '|'); WriteCommentsJS(ma,"faces " & Fmt.Pad(Fmt.Int(top.NF),m), '|'); WriteCommentsJS(ma,"polyhedra " & Fmt.Int(top.NP), '|'); END; WriteCommentsJS(ma, "\nVertex data:\n", '|'); FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i] DO (* materials *) Wr.PutText(ma, Fmt.Pad(Fmt.Int(v.num), vWidth)); Wr.PutText(ma, " "); Wr.PutText(ma, Fmt.Char(Boole[v.exists])); Wr.PutText(ma, " "); Wr.PutText(ma, Fmt.Char(Boole[v.fixed])); Wr.PutText(ma, " "); WriteColor(v.color); Wr.PutText(ma, " "); WriteColor(v.transp); Wr.PutText(ma, " "); WriteRadius(v.radius); Wr.PutText(ma, " "); WriteLabel(v.label); Wr.PutText(ma, "\n"); END END; WriteCommentsJS(ma, "\nEdge data:\n", '|'); FOR i := 0 TO top.NE-1 DO WITH e = top.edge[i] DO (* materials *) Wr.PutText(ma, Fmt.Pad(Fmt.Int(e.num), eWidth)); Wr.PutText(ma, " "); Wr.PutText(ma, Fmt.Char(Boole[e.exists])); Wr.PutText(ma, " "); WriteColor(e.color); Wr.PutText(ma, " "); WriteColor(e.transp); Wr.PutText(ma, " "); WriteRadius(e.radius); Wr.PutText(ma, " "); Wr.PutText(ma, Fmt.Char(Boole[e.degenerate])); Wr.PutText(ma, " "); IF e.root = -1 THEN Wr.PutText(ma, " - "); ELSE Wr.PutText(ma, Fmt.Pad(Fmt.Int(e.root), eWidth)); END; Wr.PutText(ma, "\n"); END END; WriteCommentsJS(ma, "\nFace data:\n", '|'); FOR i := 0 TO top.NF-1 DO WITH f = top.face[i] DO Wr.PutText(ma, Fmt.Pad(Fmt.Int(f.num), fWidth)); Wr.PutText(ma, " "); Wr.PutText(ma, Fmt.Char(Boole[f.exists])); Wr.PutText(ma, " "); WriteColor(f.color); Wr.PutText(ma, " "); WriteColor(f.transp); Wr.PutText(ma, " "); Wr.PutText(ma, Fmt.Char(Boole[f.degenerate])); Wr.PutText(ma, " "); IF f.root = -1 THEN Wr.PutText(ma, " - "); ELSE Wr.PutText(ma, Fmt.Pad(Fmt.Int(f.root), fWidth)); END; Wr.PutText(ma, "\n"); END END; IF top.NP # 0 THEN WriteCommentsJS(ma, "\nPolyhedron data:\n", '|'); END; FOR i := 0 TO top.NP-1 DO WITH p = top.polyhedron[i] DO Wr.PutText(ma, Fmt.Pad(Fmt.Int(p.num), pWidth)); Wr.PutText(ma, " "); Wr.PutText(ma, Fmt.Char(Boole[p.exists])); Wr.PutText(ma, " "); WriteColor(p.color); Wr.PutText(ma, " "); WriteColor(p.transp); Wr.PutText(ma, " "); WITH degenerate = FALSE DO Wr.PutText(ma, Fmt.Char(Boole[degenerate])) END; IF ro_te THEN Wr.PutText(ma, " "); IF p.root = -1 THEN Wr.PutText(ma, " - "); ELSE Wr.PutText(ma, Fmt.Pad(Fmt.Int(p.root), pWidth)); END END; Wr.PutText(ma, "\n"); END END END; WriteFooter(ma, "materials"); Wr.Close(ma); END; END WriteMaterials; PROCEDURE CollectFaceEdges(a: Pair; VAR re: REF ARRAY OF Pair; VAR ne: CARDINAL) = VAR b: Pair; BEGIN b := a; ne := 0; REPEAT <* ASSERT b.facetedge.face = a.facetedge.face *> IF re = NIL OR ne >= NUMBER(re^) THEN WITH se = NEW(REF ARRAY OF Pair, MAX(10, 2*ne)) DO IF re # NIL THEN SUBARRAY(se^, 0, ne) := re^ END; re := se END END; re[ne] := b; INC(ne); b := Enext(b) UNTIL b = a; END CollectFaceEdges; PROCEDURE CollectPolyhedronFaces(a: Pair; VAR rf: REF ARRAY OF Pair; VAR nf: CARDINAL) = VAR scanned: CARDINAL := 0; PROCEDURE StackFace(c: Pair) = BEGIN <* ASSERT Pneg(c) = Pneg(a) *> c.facetedge.face.xmark := TRUE; IF rf = NIL OR nf >= NUMBER(rf^) THEN WITH sf = NEW(REF ARRAY OF Pair, MAX(10, 2*nf)) DO IF rf # NIL THEN SUBARRAY(sf^, 0, nf) := rf^ END; rf := sf END END; rf[nf] := c; INC(nf); END StackFace; PROCEDURE VisitFace(b: Pair) = VAR c: Pair := Clock(Fnext_1(b)); BEGIN REPEAT <* ASSERT Pneg(c) = Pneg(a) *> WITH g = c.facetedge.face DO IF NOT g.xmark THEN StackFace(c); (* We have only one mark per face, but a face may incide twice on "p": *) (* Assumes that the cell's boundary is oriented! *) IF PposP(c) = Pneg(a) THEN StackFace(Clock(c)) END; END END; c := Enext(c) UNTIL c = b; END VisitFace; BEGIN nf := 0; scanned := 0; StackFace(a); WHILE scanned < nf DO VisitFace(rf[scanned]); INC(scanned) END; (* Clear "xmark", just in case: *) FOR k := 0 TO nf - 1 DO WITH b = rf[k] DO b.facetedge.face.xmark := FALSE END END; END CollectPolyhedronFaces; PROCEDURE CollectPolyhedronEdges( a: Pair; VAR re: REF ARRAY OF Pair; VAR ne: CARDINAL; VAR rf: REF ARRAY OF Pair; (* Working area *) ) = VAR nf: CARDINAL; b: Pair; BEGIN CollectPolyhedronFaces(a, rf, nf); ne := 0; FOR k := 0 TO nf-1 DO WITH f = rf[k] DO <* ASSERT Pneg(f) = Pneg(a) *> b := f; REPEAT WITH e = b.facetedge.edge DO IF NOT e.xmark THEN IF re = NIL OR ne >= NUMBER(re^) THEN WITH se = NEW(REF ARRAY OF Pair, MAX(10, 2*ne)) DO IF re # NIL THEN SUBARRAY(se^, 0, ne) := re^ END; re := se END END; e.xmark := TRUE; re[ne] := b; INC(ne) END END; b := Enext(b) UNTIL b = f; END END; (* Clear "xmark" bits: *) FOR k := 0 TO ne - 1 DO WITH b = re[k] DO b.facetedge.edge.xmark := FALSE END END; END CollectPolyhedronEdges; PROCEDURE CollectPolyhedronVertices( a: Pair; VAR rv: REF ARRAY OF Pair; VAR nv: CARDINAL; VAR rf: REF ARRAY OF Pair; (* Working area *) ) = VAR nf: CARDINAL; b: Pair; BEGIN CollectPolyhedronFaces(a, rf, nf); nv := 0; FOR k := 0 TO nf - 1 DO WITH f = rf[k] DO <* ASSERT Pneg(f) = Pneg(a) *> b := f; REPEAT WITH v = OrgV(b) DO IF NOT v.xmark THEN IF rv = NIL OR nv >= NUMBER(rv^) THEN WITH sv = NEW(REF ARRAY OF Pair, MAX(10, 2*nv)) DO IF rv # NIL THEN SUBARRAY(sv^, 0, nv) := rv^ END; rv := sv END END; v.xmark := TRUE; rv[nv] := b; INC(nv) END END; b := Enext(b) UNTIL b = f; END END; (* Clear "xmark" bits: *) FOR k := 0 TO nv-1 DO WITH b = rv[k] DO OrgV(b).xmark := FALSE END END; END CollectPolyhedronVertices; PROCEDURE WriteTopology( name: TEXT; READONLY top: Topology; comments: TEXT := " "; ) = <* FATAL Wr.Failure, Thread.Alerted, OSError.E *> VAR pWidth : INTEGER; BEGIN IF top.NP = 0 THEN pWidth:= 2 ELSE pWidth := Mis.NumDigits(top.NP-1) END; WITH tp = FileWr.Open(name & ".tp"), vWidth = Mis.NumDigits(top.NV - 1), eWidth = Mis.NumDigits(top.NE - 1), fWidth = Mis.NumDigits(top.NF - 1), feWidth = Mis.NumDigits(top.NFE -1) DO WriteHeader(tp,"topology","99-08-25"); IF NOT Text.Empty(comments) THEN WriteCommentsJS(tp, comments & "\n", '|') END; WITH m = Mis.NumDigits(top.NFE) DO Wr.PutText(tp, "vertices "); Wr.PutText(tp, Fmt.Pad(Fmt.Int(top.NV),m) & "\n"); Wr.PutText(tp, "edges "); Wr.PutText(tp, Fmt.Pad(Fmt.Int(top.NE),m) & "\n"); Wr.PutText(tp, "faces "); Wr.PutText(tp, Fmt.Pad(Fmt.Int(top.NF),m) & "\n"); Wr.PutText(tp, "polyhedra "); Wr.PutText(tp, Fmt.Pad(Fmt.Int(top.NP),m) & "\n"); Wr.PutText(tp, "facetedges "); Wr.PutText(tp, Fmt.Int(top.NFE) & "\n"); Wr.PutText(tp, "der "); WITH der = 0 DO Wr.PutText(tp, Fmt.Pad(Fmt.Int(der),m) & "\n") END; Wr.PutText(tp, "bdr "); WITH bdr = 0 DO Wr.PutText(tp, Fmt.Pad(Fmt.Int(bdr),m) & "\n") END; END; WriteCommentsJS(tp, "\nEdge data:\n", '|'); FOR i := 0 TO top.NE-1 DO WITH e = top.edge[i] DO Wr.PutText(tp, Fmt.Pad(Fmt.Int(e.num), eWidth)); Wr.PutText(tp, " "); Octf.PrintPair(tp, e.pa, eWidth+1, TRUE); END END; WriteCommentsJS(tp, "\nFace data:\n", '|'); FOR i := 0 TO top.NF-1 DO WITH f = top.face[i] DO Wr.PutText(tp, Fmt.Pad(Fmt.Int(f.num), fWidth)); Wr.PutText(tp, " "); Octf.PrintPair(tp, f.pa, fWidth+1, TRUE); END END; WriteCommentsJS(tp, "\nFacetEdge data:\n", '|'); FOR i := 0 TO top.NFE-1 DO WITH fe = NARROW(top.facetedge[i].facetedge, FacetEdge) DO Wr.PutText(tp, Fmt.Pad(Fmt.Int(fe.num), feWidth)); Wr.PutText(tp, " "); Octf.PrintFacetEdge(tp, fe, feWidth); Wr.PutText(tp, " "); FOR j := 0 TO 3 DO WITH n = fe.org[j] DO TYPECASE n OF | NULL => FOR i:= 0 TO pWidth-2 DO Wr.PutText(tp," "); END; Wr.PutText(tp, " - "); | Vertex(v) => Wr.PutText(tp, Fmt.Pad(Fmt.Int(v.num), vWidth) & "v "); | Polyhedron(p) => Wr.PutText(tp, Fmt.Pad(Fmt.Int(p.num), pWidth) & "p "); ELSE (* nothing *) END; END; END; Wr.PutText(tp, " "); WITH f = fe.face DO Wr.PutText(tp, Fmt.Pad(Fmt.Int(f.num), fWidth)); END; Wr.PutText(tp, "f "); WITH e = fe.edge DO Wr.PutText(tp, Fmt.Pad(Fmt.Int(e.num), eWidth)); END; Wr.PutText(tp, "e\n"); END END; WriteFooter(tp, "topology"); Wr.Close(tp); END; END WriteTopology; PROCEDURE WriteDualTopology( name: TEXT; READONLY top: Topology; comments: TEXT := " "; ) = <* FATAL Wr.Failure, Thread.Alerted, OSError.E *> PROCEDURE PrintDualPair(wr: Wr.T; a: Pair; feWidth: CARDINAL) = BEGIN Wr.PutText(wr,Fmt.Pad(Fmt.Int(a.facetedge.num), feWidth) & ":" & Fmt.Int((Octf.SrotBits(a)+ 3) MOD 4) & ":" & Fmt.Int(Octf.SpinBit(a))); END PrintDualPair; PROCEDURE PrintDualFacetEdge(wr: Wr.T; n: FacetEdge; feWidth: CARDINAL) = VAR b: Pair; BEGIN b := Srot(Pair{facetedge := n, bits := 0}); FOR i := 0 TO 3 DO PrintDualPair(wr, Fnext(b), feWidth); Wr.PutText(wr, " "); b := Srot(b) END END PrintDualFacetEdge; BEGIN WITH tp = FileWr.Open(name & ".tp"), vWidth = Mis.NumDigits(MAX(1,top.NV - 1)), eWidth = Mis.NumDigits(MAX(1,top.NE - 1)), fWidth = Mis.NumDigits(MAX(1,top.NF - 1)), pWidth = Mis.NumDigits(MAX(1,top.NP - 1)), feWidth = Mis.NumDigits(MAX(1,top.NFE -1)) DO WriteHeader(tp,"topology","99-08-25"); IF NOT Text.Empty(comments) THEN WriteCommentsJS(tp, comments & "\n", '|') END; WITH m = Mis.NumDigits(top.NFE) DO Wr.PutText(tp, "vertices "); Wr.PutText(tp, Fmt.Pad(Fmt.Int(top.NP),m) & "\n"); Wr.PutText(tp, "edges "); Wr.PutText(tp, Fmt.Pad(Fmt.Int(top.NF),m) & "\n"); Wr.PutText(tp, "faces "); Wr.PutText(tp, Fmt.Pad(Fmt.Int(top.NE),m) & "\n"); Wr.PutText(tp, "polyhedra "); Wr.PutText(tp, Fmt.Pad(Fmt.Int(top.NV),m) & "\n"); Wr.PutText(tp, "facetedges "); Wr.PutText(tp, Fmt.Int(top.NFE) & "\n"); Wr.PutText(tp, "der "); Wr.PutText(tp, Fmt.Pad(Fmt.Int(1),m) & "\n"); Wr.PutText(tp, "bdr "); Wr.PutText(tp, Fmt.Pad(Fmt.Int(0),m) & "\n"); END; WriteCommentsJS(tp, "\nEdge data:\n", '|'); FOR i := 0 TO top.NF-1 DO WITH f = top.face[i] DO Wr.PutText(tp, Fmt.Pad(Fmt.Int(f.num), fWidth)); Wr.PutText(tp, " "); Octf.PrintPair(tp, f.pa, feWidth); (* [sic] *) Wr.PutText(tp, "\n") END END; WriteCommentsJS(tp, "\nFace data:\n", '|'); FOR i := 0 TO top.NE-1 DO WITH e = top.edge[i] DO Wr.PutText(tp, Fmt.Pad(Fmt.Int(e.num), eWidth)); Wr.PutText(tp, " "); Octf.PrintPair(tp, e.pa, feWidth+1); (* [sic] *) Wr.PutText(tp, "\n") END END; WriteCommentsJS(tp, "\nFacetEdge data:\n", '|'); FOR i := 0 TO top.NFE-1 DO WITH fe = NARROW(top.facetedge[i].facetedge, FacetEdge) DO Wr.PutText(tp, Fmt.Pad(Fmt.Int(fe.num), feWidth)); Wr.PutText(tp, " "); PrintDualFacetEdge(tp, fe, feWidth); Wr.PutText(tp, " "); FOR j := 0 TO 3 DO WITH n = fe.org[(j+1) MOD 4] DO TYPECASE n OF | NULL => FOR i:= 0 TO pWidth-2 DO Wr.PutText(tp," "); END; Wr.PutText(tp, " - "); | Vertex(v) => Wr.PutText(tp, Fmt.Pad(Fmt.Int(v.num), vWidth) & "p "); | Polyhedron(p) => Wr.PutText(tp, Fmt.Pad(Fmt.Int(p.num), pWidth) & "v "); ELSE (* nothing *) END; END; END; Wr.PutText(tp, " "); WITH e = fe.edge DO Wr.PutText(tp, Fmt.Pad(Fmt.Int(e.num), eWidth)); END; Wr.PutText(tp, "f "); WITH f = fe.face DO Wr.PutText(tp, Fmt.Pad(Fmt.Int(f.num), fWidth)); END; Wr.PutText(tp, "e"); Wr.PutText(tp, "\n"); END END; WriteFooter(tp, "topology"); Wr.Close(tp); END; END WriteDualTopology; PROCEDURE WriteStDe( wr: Wr.T; READONLY c: Coords; READONLY Dc: Coords; prec: CARDINAL := 4; comments: TEXT := ""; ) = PROCEDURE WriteCoord(x: LONGREAL) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(wr, Fmt.LongReal(x, Fmt.Style.Sci, prec := prec)) END WriteCoord; PROCEDURE WritePoint(READONLY p: LR4.T) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WriteCoord(p[1]); Wr.PutText(wr, " "); WriteCoord(p[0]); Wr.PutText(wr, " "); WriteCoord(p[2]); Wr.PutText(wr, " "); WriteCoord(p[3]); Wr.PutText(wr, " "); END WritePoint; <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH NV = NUMBER(c), d = Mis.NumDigits(NV-1) DO WriteHeader(wr,"state-derivatives","99-08-25"); Mis.WriteCommentsJS(wr, "\n" & comments & "\n",'|'); Wr.PutText(wr, "vertices = " & Fmt.Int(NV) & "\n"); FOR i := 0 TO NV-1 DO Wr.PutText(wr, Fmt.Pad(Fmt.Int(i), d) & ": "); WritePoint(c[i]); Wr.PutText(wr, " "); (* if the derivatives of vertices are zero them writes "0 0 0 0" else writes velocites with the format for write points defined here. *) IF Dc[i][0] = 0.0d0 AND Dc[i][1] = 0.0d0 AND Dc[i][2] = 0.0d0 AND Dc[i][3] = 0.0d0 THEN Wr.PutText(wr, "0 0 0 0") ELSE WritePoint(Dc[i]) END; Wr.PutText(wr, "\n"); END; WriteFooter(wr, "state-derivatives"); Wr.PutText(wr, "\n"); Wr.Flush(wr); END; END WriteStDe; BEGIN END Triangulation. (* (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) *) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Tridimensional.m3 MODULE Tridimensional; (* This module contains procedures that computing geometric operations onto tridimensional mesh. Also, contain procedures for write and read a 3D state. Also we include some procedures defined by R. L. W. L. and slightly modified in her tools "Animacao Dinamica de Corpos Elasticos". See the copyright and authorship futher down. Last modification: 19-02-200. *) IMPORT Wr, Rd, Lex, Triangulation, Mis, FileRd, FloatMode, FileWr, Fmt, Thread, Text, OSError, LR3, LR4, LR4Extras, Math, FileFmt; FROM Triangulation IMPORT Topology, Ppos, Pneg, OrgV, TetraNegPosVertices; FROM Octf IMPORT Pair, Fnext, Enext_1, Clock; FROM FileFmt IMPORT WriteFooter; FROM Mis IMPORT WriteCommentsJS, WriteLong, WritePoint3D, WriteInt; CONST (* constants for use with the R.L.W.L. procedures *) TE_VERSION = "99-08-25"; ST_VERSION = "99-08-25"; EN_VERSION = "99-08-25"; AlphaChars = Mis.AlphaChars; PROCEDURE Barycenter3D( READONLY top: Topology; READONLY c3: Coords3D; ): LR3.T = VAR B: LR3.T := LR3.T{0.0d0, ..}; N: CARDINAL := 0; BEGIN FOR i := 0 TO LAST(c3) DO WITH v = top.vertex[i] DO IF v.exists THEN B := LR3.Add(B, c3[i]); INC(N) END; END END; RETURN LR3.Scale(1.0d0/FLOAT(N, LONGREAL), B) END Barycenter3D; PROCEDURE MeanVertexDistance3D( READONLY top: Topology; READONLY c3: Coords3D; ): LONGREAL = VAR S: LONGREAL := 0.0d0; N: CARDINAL := 0; BEGIN FOR i := 0 TO LAST(c3) DO WITH v = top.vertex[i] DO IF v.exists THEN S := S + LR3.NormSqr(c3[i]); INC(N) END END END; RETURN Math.sqrt(S/FLOAT(N,LONGREAL)) END MeanVertexDistance3D; PROCEDURE Displace3D( READONLY top: Topology; d: LR3.T; VAR c3: Coords3D; ) = BEGIN FOR i := 0 TO LAST(c3) DO IF top.vertex[i].exists THEN WITH vc = c3[i] DO vc := LR3.Add(vc, d) END END END END Displace3D; PROCEDURE Scale3D( READONLY top: Topology; s: LONGREAL; VAR c3: Coords3D; ) = BEGIN FOR i := 0 TO LAST(c3) DO IF top.vertex[i].exists THEN WITH vc = c3[i] DO vc := LR3.Scale(s,vc) END; END END END Scale3D; PROCEDURE NormalizeVertexDistance3D( READONLY top: Topology; VAR c3: Coords3D; ) = BEGIN WITH b = Barycenter3D(top, c3) DO Displace3D(top, LR3.Neg(b), c3) END; WITH s = MeanVertexDistance3D(top, c3) DO Scale3D(top, 1.0d0/s, c3) END; END NormalizeVertexDistance3D; PROCEDURE EdgeWindingNumber(a: Pair; READONLY c3: Coords3D): INTEGER = (* Returns the winding number of the tetrahedra incident to the edge. In a proper embedding, the number should be +1 or -1. *) VAR b: Pair := a; wnd: INTEGER := 0; BEGIN WITH (* Edge endpoints: *) u3 = c3[OrgV(a).num], v3 = c3[OrgV(Clock(a)).num], u4 = LR4.T{u3[0], u3[1], u3[2], 1.0d0}, v4 = LR4.T{v3[0], v3[1], v3[2], 1.0d0}, pl = ChoosePlaneThroughPoints(u3, v3) DO REPEAT WITH (* Endpoints of opposite edge in tetrahedron: *) p3 = c3[OrgV(Enext_1(b)).num], q3 = c3[OrgV(Enext_1(Fnext(b))).num], p4 = LR4.T{p3[0], p3[1], p3[2], 1.0d0}, q4 = LR4.T{q3[0], q3[1], q3[2], 1.0d0}, det = LR4Extras.Det(u4, v4, p4, q4), pb = (LR4.Dot(p4,pl) <= 0.0d0), qb = (LR4.Dot(q4,pl) <= 0.0d0) DO IF pb AND (NOT qb) THEN IF det > 0.0d0 THEN wnd := wnd + 1 END ELSIF (NOT pb) AND qb THEN IF det < 0.0d0 THEN wnd := wnd - 1 END END END; b := Fnext(b) UNTIL b = a; END; RETURN wnd END EdgeWindingNumber; PROCEDURE ChoosePlaneThroughPoints(u, v: LR3.T): LR4.T = VAR iMin: CARDINAL := 0; BEGIN WITH d3 = LR3.Sub(u, v) DO (* Find smallest coordinate in "d3": *) FOR i := 1 TO 2 DO IF ABS(d3[i]) < ABS(d3[iMin]) THEN iMin := i END END; WITH u4 = LR4.T{u[0], u[1], u[2], 1.0d0}, v4 = LR4.T{v[0], v[1], v[2], 1.0d0}, w4 = LR4.Axis(iMin) DO RETURN LR4Extras.Cross(u4, v4, w4) END END END ChoosePlaneThroughPoints; PROCEDURE FaceIsSilhouette(a: Pair; READONLY c3: Coords3D): BOOLEAN = (* Return TRUE iff the projected face associated to the pair "a" is a silhouette face. *) BEGIN IF Ppos(a) = NIL OR Pneg(a) = NIL THEN RETURN FALSE END; WITH t = TetraNegPosVertices(a), un = t[0].num, vn = t[1].num, wn = t[2].num, xn = t[3].num, yn = t[4].num, d1 = TetraDet3D(un,vn,wn,xn, c3), d2 = TetraDet3D(un,vn,wn,yn, c3) DO RETURN d1*d2 >= 0.0d0 END END FaceIsSilhouette; PROCEDURE TetraDet3D(u,v,w,x: CARDINAL; READONLY c3: Coords3D): LONGREAL = BEGIN WITH a = LR4.T{c3[u][0], c3[u][1], c3[u][2], 1.0d0}, b = LR4.T{c3[v][0], c3[v][1], c3[v][2], 1.0d0}, c = LR4.T{c3[w][0], c3[w][1], c3[w][2], 1.0d0}, d = LR4.T{c3[x][0], c3[x][1], c3[x][2], 1.0d0} DO RETURN LR4Extras.Det(a,b,c,d); END END TetraDet3D; PROCEDURE WriteState3D( name: TEXT; READONLY top: Topology; READONLY c: Coords3D; comments: TEXT := " "; ) = <* FATAL Wr.Failure, Thread.Alerted, OSError.E *> BEGIN WITH st3 = FileWr.Open(name & ".st3"), vWidth = Mis.NumDigits(top.NV - 1) DO FileFmt.WriteHeader(st3,"state3D","99-08-25"); Wr.PutText(st3, "vertices "); Wr.PutText(st3, Fmt.Int(top.NV) & "\n"); IF NOT Text.Empty(comments) THEN Mis.WriteCommentsJS(st3, comments & "\n", '|') END; Mis.WriteCommentsJS(st3, "\nVertex data:\n", '|'); FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i] DO (* state 3D *) Wr.PutText(st3, Fmt.Pad(Fmt.Int(v.num), vWidth)); Wr.PutText(st3," "); WritePoint3D(st3,c[v.num]); Wr.PutText(st3,"\n"); END END; FileFmt.WriteFooter(st3,"state3D"); Wr.Close(st3); END; END WriteState3D; PROCEDURE ReadState3D(name: TEXT): REF Coords3D = <* FATAL Rd.Failure,Thread.Alerted,FloatMode.Trap,Lex.Error,OSError.E *> VAR c: REF Coords3D; comments: TEXT; nv: CARDINAL; BEGIN WITH rs = FileRd.Open(name & ".st3") DO (* Read Headers File Formats*) FileFmt.ReadHeader(rs,"state3D","99-08-25"); (* Element counts: *) Lex.Skip(rs, cs := AlphaChars); nv := Lex.Int(rs); Lex.Skip(rs); comments := Mis.ReadCommentsJS(rs, '|'); c := NEW(REF Coords3D, nv); (* Read vertex data state: *) FOR j := 0 TO nv-1 DO Lex.Skip(rs); WITH nv = Lex.Int(rs) DO WITH cv = c[nv] DO cv[0] := Lex.LongReal(rs); Lex.Skip(rs); cv[1] := Lex.LongReal(rs); Lex.Skip(rs); cv[2] := Lex.LongReal(rs); END END END; FileFmt.ReadFooter(rs,"state3D"); Rd.Close(rs); RETURN c; END; END ReadState3D; (* procedures associated to the R.L.W.L.'s tools *) PROCEDURE WriteSpace(wr: Wr.T; n: CARDINAL) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN FOR i := 1 TO n DO Wr.PutChar(wr,' ') END END WriteSpace; PROCEDURE WriteEOL(wr: Wr.T) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutChar(wr,'\n') END WriteEOL; PROCEDURE WriteStates( wr: Wr.T; time: LONGREAL; READONLY vertex: ARRAY OF Vertex; prec: CARDINAL := 4; comments: TEXT := ""; ) = PROCEDURE WriteCoord3(x: LONGREAL) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(wr, Fmt.LongReal(x, Fmt.Style.Sci, prec := prec)) END WriteCoord3; PROCEDURE WritePoint3(READONLY p: LR3.T) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WriteCoord3(p[0]); Wr.PutText(wr, " "); WriteCoord3(p[1]); Wr.PutText(wr, " "); WriteCoord3(p[2]); Wr.PutText(wr, " "); END WritePoint3; <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH NV = NUMBER(vertex), vWidth = Mis.NumDigits(NV-1) DO FileFmt.WriteHeader(wr, "state3D", "99-08-25"); Wr.PutText(wr, "vertices " & Fmt.Int(NUMBER(vertex)) & "\n"); WriteCommentsJS(wr, comments & "\n", '|'); Mis.WriteCommentsJS(wr, "\nVertex data:\n", '|'); Wr.PutText(wr,"t " & Fmt.Pad(Fmt.LongReal(time,Fmt.Style.Fix,prec:=2),4)&"\n"); FOR i := 0 TO LAST(vertex) DO Wr.PutText(wr, Fmt.Pad(Fmt.Int(i), vWidth)); Wr.PutText(wr, " "); WritePoint3(vertex[i]); WriteEOL(wr); END; WriteFooter(wr, "state3D"); Wr.Close(wr) END END WriteStates; (* Notice: actually WriteStates = WriteState3D *) PROCEDURE WriteTetrahedra( name: TEXT; READONLY top: Topology; READONLY cell: ARRAY OF Tetrahedron; comments: TEXT := " "; ) = <* FATAL Wr.Failure, Thread.Alerted, OSError.E *> BEGIN WITH wr = FileWr.Open(name & ".te"), pWidth = Mis.NumDigits(top.NP - 1) DO FileFmt.WriteHeader(wr, "tetrahedra","99-08-25"); Wr.PutText(wr, "tetrahedra " & Fmt.Int(NUMBER(cell)) & "\n"); WriteCommentsJS(wr, comments & "\n", '|'); FOR i := 0 TO LAST(cell) DO Wr.PutText(wr, Fmt.Pad(Fmt.Int(i), pWidth)); Wr.PutText(wr," "); WriteTetrahedron(wr, cell[i], 0); END; WriteFooter(wr, "tetrahedra"); Wr.Close(wr) END END WriteTetrahedra; PROCEDURE WriteTetrahedron (wr: Wr.T; READONLY t: Tetrahedron; nbase: CARDINAL; ) = BEGIN WriteSpace(wr,0); WriteLong(wr, t.A[0,0]); WriteSpace(wr,0); WriteLong(wr, t.A[0,1]); WriteSpace(wr,0); WriteLong(wr, t.A[0,2]); WriteSpace(wr,1); WriteLong(wr, t.A[1,0]); WriteSpace(wr,0); WriteLong(wr, t.A[1,1]); WriteSpace(wr,0); WriteLong(wr, t.A[1,2]); WriteSpace(wr,1); WriteLong(wr, t.A[2,0]); WriteSpace(wr,0); WriteLong(wr, t.A[2,1]); WriteSpace(wr,0); WriteLong(wr, t.A[2,2]); WriteEOL(wr); WriteSpace(wr, 3); WriteInt(wr, nbase + t.p0); WriteSpace(wr,0); WriteInt(wr, nbase + t.p1); WriteSpace(wr,0); WriteInt(wr, nbase + t.p2); WriteSpace(wr,0); WriteInt(wr, nbase + t.p3); WriteEOL(wr); WriteSpace(wr, 2); WriteLong(wr, t.density); WriteSpace(wr,1); WriteLong(wr, t.alpha); WriteSpace(wr,1); WriteLong(wr, t.beta); WriteSpace(wr,1); WriteEOL(wr); END WriteTetrahedron; PROCEDURE ReadTetrahedron(rd: Rd.T; VAR t: Tetrahedron) = <* FATAL Rd.Failure, Thread.Alerted, FloatMode.Trap, Lex.Error *> BEGIN t.A[0,0] := Lex.LongReal(rd); Lex.Skip(rd); t.A[1,0] := Lex.LongReal(rd); Lex.Skip(rd); t.A[2,0] := Lex.LongReal(rd); Lex.Skip(rd); t.A[0,1] := Lex.LongReal(rd); Lex.Skip(rd); t.A[1,1] := Lex.LongReal(rd); Lex.Skip(rd); t.A[2,1] := Lex.LongReal(rd); Lex.Skip(rd); t.A[0,2] := Lex.LongReal(rd); Lex.Skip(rd); t.A[1,2] := Lex.LongReal(rd); Lex.Skip(rd); t.A[2,2] := Lex.LongReal(rd); Lex.Skip(rd); t.p0 := Lex.Int(rd); Lex.Skip(rd); t.p1 := Lex.Int(rd); Lex.Skip(rd); t.p2 := Lex.Int(rd); Lex.Skip(rd); t.p3 := Lex.Int(rd); Lex.Skip(rd); t.density := Lex.LongReal(rd); Lex.Skip(rd); t.alpha := Lex.LongReal(rd); Lex.Skip(rd); t.beta := Lex.LongReal(rd); Lex.Skip(rd); END ReadTetrahedron; PROCEDURE ReadVectors(rd: Rd.T; n: CARDINAL; pos: Vectors3D) = <* FATAL Rd.EndOfFile, Rd.Failure,Thread.Alerted, FloatMode.Trap, Lex.Error *> BEGIN FOR i := 0 TO n-1 DO EVAL Lex.Int(rd); EVAL Rd.GetChar(rd); pos[i][0] := Lex.LongReal(rd); Lex.Skip(rd); pos[i][1] := Lex.LongReal(rd); Lex.Skip(rd); pos[i][2] := Lex.LongReal(rd); Lex.Skip(rd); END END ReadVectors; PROCEDURE ReadHeader(rd: Rd.T; type, param: TEXT): CARDINAL RAISES {Rd.EndOfFile} = <* FATAL Rd.Failure, Thread.Alerted, FloatMode.Trap, Lex.Error *> VAR n := 0; BEGIN TRY Lex.Match(rd,"begin " & type & " (format of " & GetVersion(type) & ")") EXCEPT ELSE RAISE Rd.EndOfFile END; Lex.Skip(rd); IF param # NIL THEN Lex.Match(rd, param); n := Lex.Int(rd); Lex.Skip(rd); END; EVAL Mis.ReadCommentsJS(rd,'|'); RETURN n; END ReadHeader; PROCEDURE ReadFooter(rd: Rd.T; type: TEXT) = <* FATAL Rd.Failure, Thread.Alerted, Lex.Error *> BEGIN Lex.Skip(rd); Lex.Match(rd, "end " & type) END ReadFooter; PROCEDURE GetVersion(type: TEXT): TEXT = BEGIN IF Text.Equal(type, "tetrahedra") THEN RETURN TE_VERSION ELSIF Text.Equal(type, "state3D") THEN RETURN ST_VERSION ELSIF Text.Equal(type, "energies") THEN RETURN EN_VERSION ELSE <* ASSERT FALSE *> END END GetVersion; PROCEDURE WriteHeader(wr: Wr.T; type, param: TEXT; n: CARDINAL) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(wr,"begin " & type & " (format of " & GetVersion(type) & ")\n"); IF param # NIL THEN Wr.PutText(wr, param); WriteInt(wr, n); WriteEOL(wr); END END WriteHeader; BEGIN END Tridimensional. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/Trunc.m3 q := LR4.Cos(a,b); IF NOT (-1.0d0 <= q AND q <= 1.0d0) THEN q := FLOAT(TRUNC(q), LONGREAL); END; z := Math.acos(q); (* Aproximation *)~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/UneqVolEnergy.m3 MODULE UneqVolEnergy; IMPORT LR4, LR4Extras, Triangulation, Math; FROM Octf IMPORT Enext_1, Fnext_1, Enext, Fnext; FROM Triangulation IMPORT OrgV, Topology, PnegP, PposP, Polyhedron; FROM Energy IMPORT Coords, Gradient; FROM Math IMPORT sqrt; CONST Zero = 0.0d0; TYPE BOOLS = ARRAY OF BOOLEAN; LONGS = ARRAY OF LONGREAL; REVEAL T = Public BRANDED OBJECT K: LONGREAL; (* The energy normalization factor *) top: Topology; (* The topology *) vVar: REF BOOLS; (* TRUE if vertex is variable *) faceRelevant: REF BOOLS; (* TRUE if face is relevant *) vr: REF LONGS; (* (Work) Volume ratio of two polyhedrons incident to face relevant *) eDvr: REF LONGS; (* (Work) Derivate of energy rel. to volume ratio *) OVERRIDES init := Init; defTop := DefTop; defVar := DefVar; eval := Eval; name := Name; END; PROCEDURE Init(erg: T): T = BEGIN RETURN erg END Init; PROCEDURE DefTop(erg: T; READONLY top: Topology) = BEGIN erg.K := 1.0d0/FLOAT(top.NF, LONGREAL); erg.top := top; erg.vVar := NEW(REF BOOLS, top.NV); erg.faceRelevant := NEW(REF BOOLS, top.NF); (* Allocate volume ratio tables: *) erg.vr := NEW(REF LONGS, top.NF); erg.eDvr := NEW(REF LONGS, top.NF); (* Just in case the client forgets to call "defVar": *) FOR i := 0 TO top.NV-1 DO erg.vVar^[i] := FALSE END; FOR i := 0 TO top.NF-1 DO erg.faceRelevant^[i] := FALSE END; END DefTop; PROCEDURE DefVar(erg: T; READONLY variable: BOOLS) = VAR p1,p2: Polyhedron; BEGIN (* Decide which face are relevant to unequal volume energy. A face is relevant iff it exists, has exactly two polyhedron incident to it being least one existing polyhedron and the face have at least one variable corner. *) WITH NV = erg.top.NV, NF = erg.top.NF, vVar = erg.vVar^, face = erg.top.face^, faceRelevant = erg.faceRelevant^ DO <* ASSERT NUMBER(variable) = NV *> vVar := variable; (* Find the relevant faces: *) FOR i := 0 TO NF-1 DO faceRelevant[i] := FALSE END; FOR i := 0 TO NF-1 DO WITH f = face[i], a = f.pa^ DO p1 := PnegP(a); p2 := PposP(a); IF p1 # NIL AND p2 # NIL THEN WITH pvar = p1.exists OR p2.exists, u = OrgV(a), v = OrgV(Enext(a)), w = OrgV(Enext_1(a)), vvar = vVar[u.num] OR vVar[v.num] OR vVar[w.num] DO IF f.exists AND pvar AND vvar THEN <* ASSERT u.exists AND v.exists AND w.exists *> faceRelevant[i] := TRUE; END END END END END END END DefVar; PROCEDURE Eval( erg: T; READONLY c: Coords; VAR e: LONGREAL; grad: BOOLEAN; VAR eDc: Gradient; ) = BEGIN WITH K = erg.K, NV = erg.top.NV, NF = erg.top.NF, face = erg.top.face^, vVar = erg.vVar^, faceRelevant = erg.faceRelevant^, vr = erg.vr^, eDvr = erg.eDvr^ DO PROCEDURE Accum_vr(READONLY u, v, w, x, y: LR4.T; VAR vro: LONGREAL) = (* Compute the volume ratio of tetrahedrons "u w v x" (Ppos) and "u w y v" (Pneg). "n1" is the cross product "(w - u)X(v - u)X(x - u)" and "n2" is the cross product (w - u)X(y - u)X(v - u)". The coordinates "u v w" defined the common face of two tetrahedrons where "x" is the vertex extremus of polyhedron Ppos and "y" is the vertex extremus of polyhedron Pneg. Note that the rigth-hand rule is valid in R^{4} for determining in which of the two possible direc- tions "a x b x c" points. *) BEGIN WITH uv = LR4.Sub(v, u), uw = LR4.Sub(w, u), ux = LR4.Sub(x, u), uy = LR4.Sub(y, u), n1 = LR4Extras.Cross(uw, uv, ux), n2 = LR4Extras.Cross(uw, uy, uv), v1 = 1.0d0/6.0d0 * LR4.Norm(n1), v2 = 1.0d0/6.0d0 * LR4.Norm(n2) DO vro := vro + v1/v2; END END Accum_vr; PROCEDURE Accum_e_from_vr(vr: LONGREAL; VAR e: LONGREAL; VAR etDvr: LONGREAL) = (* Adds to "e" the energy term corresponding to a face with volume ratio "vr" of polyhedrons incidents to it. Also, if "grad" is true, stores in "etDvr" the derivative of that term. *) BEGIN <* ASSERT vr # 0.0d0 *> IF vr <= 0.0d0 THEN etDvr := 0.0d0 ELSE WITH d = vr - 1.0d0, d2 = d * d DO e := e + K * d2; IF grad THEN etDvr := 2.0d0 * K * d; ELSE etDvr := 0.0d0; END END END END Accum_e_from_vr; PROCEDURE Distribute_eDvr(iu, iv, iw, ix, iy: CARDINAL; eDvr: LONGREAL) = (* Accumulates in "eDc" the gradient of "e" relative to the corners of the two tetrahedrons "iu iv iw ix", and "iu iv iw iy" given the derivative "eDv" of "e" relative to volume ratio of tetrahedrons "vr". *) PROCEDURE CalcPartialDerivatives( READONLY u,v,w,x : CARDINAL; VAR sum2 : LONGREAL; VAR voDu,voDv,voDw,voDx: LR4.T; ) = VAR term : LONGREAL; BEGIN WITH u = c[u], v = c[v], w = c[w], x = c[x], u1 = u[0], u2 = u[1], u3 = u[2], u4 = u[3], v1 = v[0], v2 = v[1], v3 = v[2], v4 = v[3], w1 = w[0], w2 = w[1], w3 = w[2], w4 = w[3], x1 = x[0], x2 = x[1], x3 = x[2], x4 = x[3], d1 = u1 * (v2 * (w3-x3) - v3 * (w2-x2) + w2*x3-w3*x2) -u2 * (v1 * (w3-x3) - v3 * (w1-x1) + w1*x3-w3*x1) +u3 * (v1 * (w2-x2) - v2 * (w1-x1) + w1*x2-x1*w2) -(v1*(w2*x3-x2*w3)-v2*(w1*x3-x1*w3)+v3*(w1*x2-x1*w2)), d2 = u1 * (v2 * (w4-x4) - v4 * (w2-x2) + w2*x4-x2*w4) -u2 * (v1 * (w4-x4) - v4 * (w1-x1) + w1*x4-x1*w4 ) +u4 * (v1 * (w2-x2) - v2 * (w1-x1) + w1*x2-x1*w2) -(v1*(w2*x4-x2*w4)-v2*(w1*x4-x1*w4)+v4*(w1*x2-x1*w2)), d3 = u2 * (v3 * (w4-x4) - v4 * (w3-x3) + w3*x4-x3*w4) -u3 * (v2 * (w4-x4) - v4 * (w2-x2) + w2*x4-x2*w4) +u4 * (v2 * (w3-x3) - v3 * (w2-x2) + w2*x3-x2*w3) -(v2*(w3*x4-x3*w4)-v3*(w2*x4-x2*w4)+v4*(w2*x3-x2*w3)), d4 = u1 * (v3 * (w4-x4) - v4 * (w3-x3) + w3*x4-x3*w4) -u3 * (v1 * (w4-x4) - v4 * (w1-x1) + w1*x4-x1*w4) +u4 * (v1 * (w3-x3) - v3 * (w1-x1) + w1*x3-x1*w3) -(v1*(w3*x4-x3*w4)-v3*(w1*x4-x1*w4)+v4*(w1*x3-x1*w3)), d = LR4.T{d1,d2,d3,d4}, d1Du1 = v2 * (w3-x3) - v3 * (w2-x2) + w2*x3-w3*x2, d2Du1 = v2 * (w4-x4) - v4 * (w2-x2) + w2*x4-x2*w4, d3Du1 = Zero, d4Du1 = v3 * (w4-x4) - v4 * (w3-x3) + w3*x4-x3*w4, dDu1 = LR4.T{d1Du1, d2Du1, d3Du1, d4Du1}, d1Du2 = - (v1 * (w3-x3) - v3 * (w1-x1) + w1*x3-w3*x1), d2Du2 = - (v1 * (w4-x4) - v4 * (w1-x1) + w1*x4-x1*w4 ), d3Du2 = v3 * (w4-x4) - v4 * (w3-x3) + w3*x4-x3*w4, d4Du2 = Zero, dDu2 = LR4.T{d1Du2, d2Du2, d3Du2, d4Du2}, d1Du3 = v1 * (w2-x2) - v2 * (w1-x1) + w1*x2-x1*w2, d2Du3 = Zero, d3Du3 = - (v2 * (w4-x4) - v4 * (w2-x2) + w2*x4-x2*w4), d4Du3 = - (v1 * (w4-x4) - v4 * (w1-x1) + w1*x4-x1*w4), dDu3 = LR4.T{d1Du3, d2Du3, d3Du3, d4Du3}, d1Du4 = Zero, d2Du4 = v1 * (w2-x2) - v2 * (w1-x1) + w1*x2-x1*w2, d3Du4 = v2 * (w3-x3) - v3 * (w2-x2) + w2*x3-x2*w3, d4Du4 = v1 * (w3-x3) - v3 * (w1-x1) + w1*x3-x1*w3, dDu4 = LR4.T{d1Du4, d2Du4, d3Du4, d4Du4}, d1Dv1 = u2 * (x3-w3) + u3 * (w2-x2) - w2*x3+w3*x2, d2Dv1 = u2 * (x4-w4) + u4 * (w2-x2) - w2*x4+x2*w4, d3Dv1 = Zero, d4Dv1 = u3 * (x4-w4) + u4 * (w3-x3) - w3*x4+x3*w4, dDv1 = LR4.T{d1Dv1, d2Dv1, d3Dv1, d4Dv1}, d1Dv2 = u1 * (w3-x3) + u3 * (x1-w1) + w1*x3-w3*x1 , d2Dv2 = u1 * (w4-x4) + u4 * (x1-w1) + w1*x4-x1*w4 , d3Dv2 = u3 * (x4-w4) + u4 * (w3-x3) - w3*x4+x3*w4, d4Dv2 = Zero, dDv2 = LR4.T{d1Dv2, d2Dv2, d3Dv2, d4Dv2}, d1Dv3 = u1 * (x2-w2) + u2 * (w1-x1) - w1*x2+x1*w2, d2Dv3 = Zero, d3Dv3 = u2 * (w4-x4) + u4 * (x2-w2) + w2*x4-x2*w4 , d4Dv3 = u1 * (w4-x4) + u4 * (x1-w1) + w1*x4-x1*w4 , dDv3 = LR4.T{d1Dv3, d2Dv3, d3Dv3, d4Dv3}, d1Dv4 = Zero, d2Dv4 = u1 * (x2-w2) + u2 * (w1-x1) - w1*x2+x1*w2, d3Dv4 = u2 * (x3-w3) + u3 * (w2-x2) - w2*x3+x2*w3, d4Dv4 = u1 * (x3-w3) + u3 * (w1-x1) - w1*x3+x1*w3, dDv4 = LR4.T{d1Dv4, d2Dv4, d3Dv4, d4Dv4}, d1Dw1 = u2 * (v3-x3) + u3 * (x2-v2) + v2*x3-v3*x2, d2Dw1 = u2 * (v4-x4) + u4 * (x2-v2) + v2*x4-x2*v4, d3Dw1 = Zero, d4Dw1 = u3 * (v4-x4) + u4 * (x3-v3) + v3*x4-x3*v4, dDw1 = LR4.T{d1Dw1, d2Dw1, d3Dw1, d4Dw1}, d1Dw2 = u1 * (x3-v3) + u3 * (v1-x1) - v1*x3+v3*x1 , d2Dw2 = u1 * (x4-v4) + u4 * (v1-x1) - v1*x4+x1*v4 , d3Dw2 = u3 * (v4-x4) + u4 * (x3-v3) + v3*x4-x3*v4, d4Dw2 = Zero, dDw2 = LR4.T{d1Dw2, d2Dw2, d3Dw2, d4Dw2}, d1Dw3 = u1 * (v2-x2) + u2 * (x1-v1) + v1*x2-x1*v2, d2Dw3 = Zero, d3Dw3 = u2 * (x4-v4) + u4 * (v2-x2) - v2*x4+x2*v4 , d4Dw3 = u1 * (x4-v4) + u4 * (v1-x1) - v1*x4+x1*v4 , dDw3 = LR4.T{d1Dw3, d2Dw3, d3Dw3, d4Dw3}, d1Dw4 = Zero, d2Dw4 = u1 * (v2-x2) + u2 * (x1-v1) + v1*x2-x1*v2, d3Dw4 = u2 * (v3-x3) + u3 * (x2-v2) + v2*x3-x2*v3, d4Dw4 = u1 * (v3-x3) + u3 * (x1-v1) + v1*x3-x1*v3, dDw4 = LR4.T{d1Dw4, d2Dw4, d3Dw4, d4Dw4}, d1Dx1 = u2 * (w3-v3) + u3 * (v2-w2) - v2*w3+v3*w2, d2Dx1 = u2 * (w4-v4) + u4 * (v2-w2) - v2*w4+w2*v4, d3Dx1 = Zero, d4Dx1 = u3 * (w4-v4) + u4 * (v3-w3) - v3*w4+w3*v4, dDx1 = LR4.T{d1Dx1, d2Dx1, d3Dx1, d4Dx1}, d1Dx2 = u1 * (v3-w3) + u3 * (w1-v1) + v1*w3-v3*w1 , d2Dx2 = u1 * (v4-w4) + u4 * (w1-v1) + v1*w4-w1*v4 , d3Dx2 = u3 * (w4-v4) + u4 * (v3-w3) + v4*w3-v3*w4, d4Dx2 = Zero, dDx2 = LR4.T{d1Dx2, d2Dx2, d3Dx2, d4Dx2}, d1Dx3 = u1 * (w2-v2) + u2 * (v1-w1) - v1*w2+w1*v2, d2Dx3 = Zero, d3Dx3 = u2 * (v4-w4) + u4 * (w2-v2) + v2*w4-w2*v4 , d4Dx3 = u1 * (v4-w4) + u4 * (w1-v1) + v1*w4-w1*v4 , dDx3 = LR4.T{d1Dx3, d2Dx3, d3Dx3, d4Dx3}, d1Dx4 = Zero, d2Dx4 = u1 * (w2-v2) + u2 * (v1-w1) - v1*w2+w1*v2, d3Dx4 = u2 * (w3-v3) + u3 * (v2-w2) - v2*w3+w2*v3, d4Dx4 = u1 * (w3-v3) + u3 * (v1-w1) - v1*w3+w1*v3, dDx4 = LR4.T{d1Dx4, d2Dx4, d3Dx4, d4Dx4} DO sum2 := d1*d1 + d2*d2 + d3*d3 + d4*d4; term := 1.0d0/Math.sqrt(sum2); voDu[0] := term * LR4.Dot(d,dDu1); voDu[1] := term * LR4.Dot(d,dDu2); voDu[2] := term * LR4.Dot(d,dDu3); voDu[3] := term * LR4.Dot(d,dDu4); voDv[0] := term * LR4.Dot(d,dDv1); voDv[1] := term * LR4.Dot(d,dDv2); voDv[2] := term * LR4.Dot(d,dDv3); voDv[3] := term * LR4.Dot(d,dDv4); voDw[0] := term * LR4.Dot(d,dDw1); voDw[1] := term * LR4.Dot(d,dDw2); voDw[2] := term * LR4.Dot(d,dDw3); voDw[3] := term * LR4.Dot(d,dDw4); voDx[0] := term * LR4.Dot(d,dDx1); voDx[1] := term * LR4.Dot(d,dDx2); voDx[2] := term * LR4.Dot(d,dDx3); voDx[3] := term * LR4.Dot(d,dDx4); voDu := LR4.T{voDu[0], voDu[1], voDu[2], voDu[3]}; voDv := LR4.T{voDv[0], voDv[1], voDv[2], voDv[3]}; voDw := LR4.T{voDw[0], voDw[1], voDw[2], voDw[3]}; voDx := LR4.T{voDx[0], voDx[1], voDx[2], voDx[3]}; END; END CalcPartialDerivatives; VAR vpDu,vpDv,vpDw,vpDx,vnDu,vnDv,vnDw,vnDy : LR4.T; sum1, sum2 : LONGREAL; BEGIN CalcPartialDerivatives(iu,iv,iw,ix,sum1,vpDu,vpDv,vpDw,vpDx); CalcPartialDerivatives(iu,iv,iw,iy,sum2,vnDu,vnDv,vnDw,vnDy); WITH vrDu1 = (sqrt(sum2) * vpDu[0] - sqrt(sum1) * vnDu[0])/sum2, vrDu2 = (sqrt(sum2) * vpDu[1] - sqrt(sum1) * vnDu[1])/sum2, vrDu3 = (sqrt(sum2) * vpDu[2] - sqrt(sum1) * vnDu[2])/sum2, vrDu4 = (sqrt(sum2) * vpDu[3] - sqrt(sum1) * vnDu[3])/sum2, vrDv1 = (sqrt(sum2) * vpDv[0] - sqrt(sum1) * vnDv[0])/sum2, vrDv2 = (sqrt(sum2) * vpDv[1] - sqrt(sum1) * vnDv[1])/sum2, vrDv3 = (sqrt(sum2) * vpDv[2] - sqrt(sum1) * vnDv[2])/sum2, vrDv4 = (sqrt(sum2) * vpDv[3] - sqrt(sum1) * vnDv[3])/sum2, vrDw1 = (sqrt(sum2) * vpDw[0] - sqrt(sum1) * vnDw[0])/sum2, vrDw2 = (sqrt(sum2) * vpDw[1] - sqrt(sum1) * vnDw[1])/sum2, vrDw3 = (sqrt(sum2) * vpDw[2] - sqrt(sum1) * vnDw[2])/sum2, vrDw4 = (sqrt(sum2) * vpDw[3] - sqrt(sum1) * vnDw[3])/sum2, vrDx1 = (sqrt(sum2) * vpDx[0] )/sum2, vrDx2 = (sqrt(sum2) * vpDx[1] )/sum2, vrDx3 = (sqrt(sum2) * vpDx[2] )/sum2, vrDx4 = (sqrt(sum2) * vpDx[3] )/sum2, vrDy1 = -(sqrt(sum1) * vnDy[0])/sum2, vrDy2 = -(sqrt(sum1) * vnDy[1])/sum2, vrDy3 = -(sqrt(sum1) * vnDy[2])/sum2, vrDy4 = -(sqrt(sum1) * vnDy[3])/sum2, eDu1 = eDvr * vrDu1, eDu2 = eDvr * vrDu2, eDu3 = eDvr * vrDu3, eDu4 = eDvr * vrDu4, eDv1 = eDvr * vrDv1, eDv2 = eDvr * vrDv2, eDv3 = eDvr * vrDv3, eDv4 = eDvr * vrDv4, eDw1 = eDvr * vrDw1, eDw2 = eDvr * vrDw2, eDw3 = eDvr * vrDw3, eDw4 = eDvr * vrDw4, eDx1 = eDvr * vrDx1, eDx2 = eDvr * vrDx2, eDx3 = eDvr * vrDx3, eDx4 = eDvr * vrDx4, eDy1 = eDvr * vrDy1, eDy2 = eDvr * vrDy2, eDy3 = eDvr * vrDy3, eDy4 = eDvr * vrDy4 DO IF vVar[iu] THEN eDc[iu,0] := eDc[iu,0] + eDu1; eDc[iu,1] := eDc[iu,1] + eDu2; eDc[iu,2] := eDc[iu,2] + eDu3; eDc[iu,3] := eDc[iu,3] + eDu4; END; IF vVar[iv] THEN eDc[iv,0] := eDc[iv,0] + eDv1; eDc[iv,1] := eDc[iv,1] + eDv2; eDc[iv,2] := eDc[iv,2] + eDv3; eDc[iv,3] := eDc[iv,3] + eDv4; END; IF vVar[iw] THEN eDc[iw,0] := eDc[iw,0] + eDw1; eDc[iw,1] := eDc[iw,1] + eDw2; eDc[iw,2] := eDc[iw,2] + eDw3; eDc[iw,3] := eDc[iw,3] + eDw4; END; IF vVar[ix] THEN eDc[ix,0] := eDc[ix,0] + eDx1; eDc[ix,1] := eDc[ix,1] + eDx2; eDc[ix,2] := eDc[ix,2] + eDx3; eDc[ix,3] := eDc[ix,3] + eDx4; END; IF vVar[iy] THEN eDc[iy,0] := eDc[iy,0] + eDy1; eDc[iy,1] := eDc[iy,1] + eDy2; eDc[iy,2] := eDc[iy,2] + eDy3; eDc[iy,3] := eDc[iy,3] + eDy4; END; END; END Distribute_eDvr; BEGIN (* Clear volume ratio accumulators: *) FOR j := 0 TO NF-1 DO vr[j] := 0.0d0 END; (* Enumerate faces and accumulate volume ratio of polyhedrons incidents. *) FOR j := 0 TO NF-1 DO IF faceRelevant[j] THEN WITH f = face[j], a = f.pa^, un = OrgV(a).num, vn = OrgV(Enext(a)).num, wn = OrgV(Enext_1(a)).num, xn = OrgV(Enext_1(Fnext(a))).num, yn = OrgV(Enext_1(Fnext_1(a))).num DO Accum_vr(c[un], c[vn], c[wn], c[xn], c[yn], vr[j]) END END END; (* Compute energy "e" from volumes ratios, and the gradient "eDvr": *) e := 0.0d0; FOR j := 0 TO NF-1 DO IF faceRelevant[j] THEN Accum_e_from_vr(vr[j], e, eDvr[j]) ELSE eDvr[j] := 0.0d0 END END; (* Now distribute "eDvr" over "eDc": *) FOR i := 0 TO NV-1 DO eDc[i] := LR4.T{0.0d0, ..} END; IF grad THEN FOR j := 0 TO NF-1 DO IF faceRelevant[j] THEN WITH f = face[j], a = f.pa^, un = OrgV(a).num, vn = OrgV(Enext(a)).num, wn = OrgV(Enext_1(a)).num, xn = OrgV(Enext_1(Fnext(a))).num, yn = OrgV(Enext_1(Fnext_1(a))).num DO Distribute_eDvr(un, vn, wn, xn, yn, eDvr[j]) END END END END END END END Eval; PROCEDURE Name(<*UNUSED*> erg: T): TEXT = BEGIN RETURN "Unequal()"; END Name; BEGIN END UneqVolEnergy. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/VStar.m3 MODULE VStar; (* This module contain procedures to build several structures such as: n-gons, triangles and squares, and solid polyhedra: cube, ball, bigcube (3D array of cube) with procedures for the gluing two such bigcubes. *) IMPORT Octf, Triangulation, R3; FROM Octf IMPORT Enext_1, Clock, Fnext, Enext, SetFnext, SetEdgeAll, Fnext_1, Spin, SetFaceAll; FROM Triangulation IMPORT Pair, Org, MakeVertex, SetAllOrgs, OrgV, SetAllPneg, MakePolyhedron, Node, Vertex, Glue, Ppos, MakeTetraTopo; FROM Squared IMPORT MakeTetrahedron, MakeTriangle; (* Procedures to build V-stars *) PROCEDURE MakeTetrahedronTriang() : ARRAY [0..3] OF Pair = BEGIN WITH t = MakeTetrahedron() DO SubdivideTetrahedron(t[0]); RETURN t; END; END MakeTetrahedronTriang; PROCEDURE SubdivideTetrahedron(a: Pair) = (* Subdivide the tetrahedron Pneg(a) into four new tetrahedra through the insertion of a new medial vertex of type "VP", six new faces, and four edges. *) VAR y: Node; BEGIN (* Create the medial vertex "VP" *) y := MakeVertex(); WITH v = NARROW(y, Vertex) DO v.exists:= TRUE; v.label := "VP"; v.num := 0; END; WITH b = Fnext_1(a), c = Enext_1(b), d = Fnext(c), e = Enext_1(a), f_ = Fnext_1(e), g = Enext_1(f_), h = Fnext(g), fa = a.facetedge.face, fb = b.facetedge.face, fg = g.facetedge.face, fh = h.facetedge.face, ea = a.facetedge.edge, ec = c.facetedge.edge, ee = e.facetedge.edge, eh = h.facetedge.edge, eeb =Enext(b).facetedge.edge, eea =Enext(a).facetedge.edge, i = Enext(a), j = Fnext_1(i), k = Enext(b), l = Fnext(k), u = Org(a), v = Org(Clock(a)), w = Org(c), x = Org(e), f1 = MakeTriangle(), f2 = MakeTriangle(), f3 = MakeTriangle(), f4 = MakeTriangle(), f5 = MakeTriangle(), f6 = MakeTriangle(), q1 = MakePolyhedron(), q2 = MakePolyhedron(), q3 = MakePolyhedron(), q4 = MakePolyhedron() DO (* save attributes for the original faces: "fa", "fb", "fg", "fh". *) fa.exists := TRUE; fa.color := R3.T{1.00, 1.00, 0.20}; fa.transp := R3.T{0.70, 0.70, 0.70}; fb.exists := TRUE; fb.color := R3.T{1.00, 1.00, 0.20}; fb.transp := R3.T{0.70, 0.70, 0.70}; fg.exists := TRUE; fg.color := R3.T{1.00, 1.00, 0.20}; fg.transp := R3.T{0.70, 0.70, 0.70}; fh.exists := TRUE; fh.color := R3.T{1.00, 1.00, 0.20}; fh.transp := R3.T{0.70, 0.70, 0.70}; ea.exists := TRUE; ea.color := R3.T{0.0, 0.0, 0.0}; ea.transp := R3.T{0.0, 0.0, 0.0}; ea.radius := 0.004; ec.exists := TRUE; ec.color := R3.T{0.0, 0.0, 0.0}; ec.transp := R3.T{0.0, 0.0, 0.0}; ec.radius := 0.004; ee.exists := TRUE; ee.color := R3.T{0.0, 0.0, 0.0}; ee.transp := R3.T{0.0, 0.0, 0.0}; ee.radius := 0.004; eh.exists := TRUE; eh.color := R3.T{0.0, 0.0, 0.0}; eh.transp := R3.T{0.0, 0.0, 0.0}; eh.radius := 0.004; eea.exists := TRUE; eea.color := R3.T{0.0, 0.0, 0.0}; eea.transp := R3.T{0.0, 0.0, 0.0}; eea.radius := 0.004; eeb.exists := TRUE; eeb.color := R3.T{0.0, 0.0, 0.0}; eeb.transp := R3.T{0.0, 0.0, 0.0}; eeb.radius := 0.004; (* insert f1 *) SetFnext(b,f1); SetFnext(f1,a); (* insert f2 *) SetFnext(c,f2); SetFnext(f2,d); (* insert f3 *) SetFnext(f_,f3); SetFnext(f3,e); (* set the relations among f1,f2 and f3 *) SetFnext(Clock(Enext(f2)),Enext_1(f1)); SetFnext(Enext_1(f1),Clock(Enext(f3))); SetFnext(Clock(Enext(f3)),Clock(Enext(f2))); SetEdgeAll(Enext_1(f1), Enext_1(f1).facetedge.edge); (* insert f4 *) SetFnext(j,f4); SetFnext(f4,i); (* insert f5 *) SetFnext(k,f5); SetFnext(f5,l); (* insert f6 *) SetFnext(g,f6); SetFnext(f6,h); (* set the internal relations along edge "yv" *) SetFnext(Enext_1(f5),Enext_1(f4)); SetFnext(Enext_1(f4),Clock(Enext(f1))); SetFnext(Clock(Enext(f1)), Enext_1(f5)); SetEdgeAll(Clock(Enext(f1)),Clock(Enext(f1)).facetedge.edge); (* set the internal relations along edge "wy" *) SetFnext(Enext(f5),Clock(Enext_1(f6))); SetFnext(Clock(Enext_1(f6)),Clock(Enext_1(f2))); SetFnext(Clock(Enext_1(f2)),Enext(f5)); SetEdgeAll(Enext(f5),Enext(f5).facetedge.edge); (* set the internal relations along edge "xy" *) SetFnext(Enext(f6), Enext(f4)); SetFnext(Enext(f4), Clock(Enext_1(f3))); SetFnext(Clock(Enext_1(f3)), Enext(f6)); SetEdgeAll(Enext(f4), Enext(f4).facetedge.edge); (* set the overall edge component *) SetEdgeAll(a, ea); SetEdgeAll(c, ec); SetEdgeAll(e, ee); SetEdgeAll(i, eea); SetEdgeAll(k, eeb); SetEdgeAll(h, eh); SetFaceAll(a, fa); SetFaceAll(b, fb); SetFaceAll(g, fg); SetFaceAll(h, fh); (* set the origins *) SetAllOrgs(a,u); SetAllOrgs(Clock(a),v); SetAllOrgs(c,w); SetAllOrgs(e,x); SetAllOrgs(Enext_1(f1),y); (* set the polyhedrons *) SetAllPneg(a,q1); SetAllPneg(Spin(b),q2); SetAllPneg(Spin(g),q3); SetAllPneg(Spin(f6),q4); END; END SubdivideTetrahedron; PROCEDURE MakeOctahedronTriang() : ARRAY[0..7] OF Pair = (* Builds a triangulated octahedron, with eight tetrahedra, and return one facet-edge pair by original face. *) VAR a : ARRAY[0..7] OF ARRAY[0..7] OF Pair; b : ARRAY[0..7] OF Pair; BEGIN FOR i := 0 TO 7 DO a[i] := Triangulation.MakeTetraTopo(1,1); END; (* first level gluing tetrahedra *) EVAL Glue(Spin(a[1][1]),a[0][0],1); EVAL Glue(Spin(a[2][1]),a[1][0],1); EVAL Glue(Spin(a[3][1]),a[2][0],1); EVAL Glue(Spin(a[0][1]),a[3][0],1); (* second level gluing tetrahedra *) EVAL Glue(Spin(a[0][3]),a[4][2],1); EVAL Glue(Spin(a[1][3]),a[5][2],1); EVAL Glue(Spin(a[2][3]),a[6][2],1); EVAL Glue(Spin(a[3][3]),a[7][2],1); (* gluing between levels *) EVAL Glue(Spin(a[5][1]),a[4][0],1); EVAL Glue(Spin(a[6][1]),a[5][0],1); EVAL Glue(Spin(a[7][1]),a[6][0],1); EVAL Glue(Spin(a[4][1]),a[7][0],1); b[0] := a[0][2]; b[1] := a[1][2]; b[2] := a[2][2]; b[3] := a[3][2]; b[4] := a[4][3]; b[5] := a[5][3]; b[6] := a[6][3]; b[7] := a[7][3]; RETURN b; END MakeOctahedronTriang; PROCEDURE MakeIcosahedronTriang() : ARRAY[0..19] OF Pair = (* Builds a triangualted icosahedron, with twenty tetrahedra, and return one facet-edge pair by original face (i.e. 20). *) VAR a : ARRAY[0..19] OF ARRAY[0..7] OF Pair; b : ARRAY[0..19] OF Pair; (* this variable will be retuned *) BEGIN FOR i := 0 TO 19 DO a[i] := MakeTetraTopo(1,1); END; (* inside the first level *) EVAL Glue(Spin(a[1][1]),a[0][0],1); EVAL Glue(Spin(a[2][1]),a[1][0],1); EVAL Glue(Spin(a[3][1]),a[2][0],1); EVAL Glue(Spin(a[4][1]),a[3][0],1); EVAL Glue(Spin(a[0][1]),a[4][0],1); (* between the first and second level *) EVAL Glue(Spin(a[0][3]),a[5][2],1); EVAL Glue(Spin(a[1][3]),a[6][2],1); EVAL Glue(Spin(a[2][3]),a[7][2],1); EVAL Glue(Spin(a[3][3]),a[8][2],1); EVAL Glue(Spin(a[4][3]),a[9][2],1); (* inside the second level *) EVAL Glue(Spin(Enext(a[10][1])), a[5][0], 1); EVAL Glue(Spin(a[6][1]), Enext(a[10][0]),1); EVAL Glue(Spin(Enext(a[11][1])), a[6][0], 1); EVAL Glue(Spin(a[7][1]), Enext(a[11][0]),1); EVAL Glue(Spin(Enext(a[12][1])), a[7][0], 1); EVAL Glue(Spin(a[8][1]), Enext(a[12][0]),1); EVAL Glue(Spin(Enext(a[13][1])), a[8][0], 1); EVAL Glue(Spin(a[9][1]), Enext(a[13][0]),1); EVAL Glue(Spin(Enext(a[14][1])), a[9][0], 1); EVAL Glue(Spin(a[5][1]), Enext(a[14][0]),1); (* between the second and third level *) EVAL Glue (Spin(a[10][3]), a[15][2],1); EVAL Glue (Spin(a[11][3]), a[16][2],1); EVAL Glue (Spin(a[12][3]), a[17][2],1); EVAL Glue (Spin(a[13][3]), a[18][2],1); EVAL Glue (Spin(a[14][3]), a[19][2],1); (* inside the third level *) EVAL Glue(Spin(a[16][1]),a[15][0],1); EVAL Glue(Spin(a[17][1]),a[16][0],1); EVAL Glue(Spin(a[18][1]),a[17][0],1); EVAL Glue(Spin(a[19][1]),a[18][0],1); EVAL Glue(Spin(a[15][1]),a[19][0],1); (* Rescue the pairs to be returned *) FOR i := 0 TO 4 DO b[i] := a[i,2] END; FOR i := 5 TO 9 DO b[i] := a[i,3] END; FOR i := 10 TO 14 DO b[i] := a[i,2] END; FOR i := 15 TO 19 DO b[i] := a[i,3] END; (* some assertions *) FOR i := 0 TO 4 DO <* ASSERT Fnext(b[i+5]) = Spin(b[i]) *> END; FOR i := 10 TO 14 DO <* ASSERT Fnext(b[i+5]) = Spin(b[i]) *> END; RETURN b; END MakeIcosahedronTriang; PROCEDURE MakeDodecahedronTriang() : ARRAY[0..11] OF ARRAY [0..4] OF Pair = (* Builds a triangulated Dodecahedron, with 60 tetrahedra, trough the automatic gluing of tetrahedra. *) TYPE Row4I = ARRAY[0..3] OF CARDINAL; VAR cell4 : REF ARRAY OF Row4I; tetra : REF ARRAY OF ARRAY [0..3] OF Pair; cellnum: CARDINAL; dode : ARRAY[0..11] OF ARRAY [0..4] OF Pair; PROCEDURE Gluing(Ti,Tj,Ci,Cj: CARDINAL) : Pair = (* Gluing the tetrahedra Ti with Tj through the free faces Ci and Cj respectively. *) BEGIN IF (* 1 *) Ci = 0 AND Cj = 0 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1], Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Dj) AND (Di=Oj) THEN EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; ELSIF (* 2 *) Ci = 0 AND Cj = 1 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1], Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi = Oj) AND (Di = Dj) THEN EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; ELSIF (* 3 *) Ci = 0 AND Cj = 2 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1], Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi = Oj) AND (Di = Dj) THEN EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END ELSIF (* 4 *) Ci = 0 AND Cj = 3 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1], Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi = Dj) AND (Di = Oj) THEN EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; ELSIF (* 5 *) Ci = 1 AND Cj = 0 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1], Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi = Oj) AND (Di = Dj) THEN EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; ELSIF (* 6 *) Ci = 1 AND Cj = 1 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1], Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Dj) AND (Di=Oj) THEN EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; ELSIF (* 7 *) Ci = 1 AND Cj = 2 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1], Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi=Dj) AND (Di=Oj) THEN EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; ELSIF (* 8 *) Ci = 1 AND Cj = 3 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1], Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi = Oj) AND (Di = Dj) THEN EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; ELSIF (* 9 *) Ci = 2 AND Cj = 0 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3], Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Oj) AND (Di=Dj) THEN EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; ELSIF (* 10 *) Ci = 2 AND Cj = 1 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3], Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Dj) AND (Di=Oj) THEN EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; ELSIF (* 11 *) Ci = 2 AND Cj = 2 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3], Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi=Dj) AND (Di=Oj) THEN EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; ELSIF (* 12 *) Ci = 2 AND Cj = 3 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3], Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi=Oj) AND (Di=Dj) THEN EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; ELSIF (* 13 *) Ci = 3 AND Cj = 0 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3], Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Dj) AND (Di=Oj) THEN EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; ELSIF (* 14 *) Ci = 3 AND Cj = 1 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3], Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Oj) AND (Di=Dj) THEN EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; ELSIF (* 15 *) Ci = 3 AND Cj = 2 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3], Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi=Oj) AND (Di=Dj) THEN EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END ELSIF (* 16 *) Ci = 3 AND Cj = 3 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3], Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi=Dj) AND (Di=Oj) THEN EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END END; RETURN tetra[Ti,0]; END Gluing; PROCEDURE SetCornersTetra(Ti: CARDINAL; row: Row4I) = (* Set the labels "row" in the tetrahedron Ti. *) BEGIN WITH a = OrgV(tetra[Ti,0]), b = OrgV(Clock(tetra[Ti,0])), c = OrgV(Enext_1(tetra[Ti,1])), d = OrgV(Enext_1(tetra[Ti,0])) DO a.num := row[0]; b.num := row[1]; c.num := row[2]; d.num := row[3]; END; END SetCornersTetra; PROCEDURE SaveFreeCorners() = (* Save the free corners on the triangulated dodecahedron, such allow us to use this polyhedron as the unglued scheme for the 3D maps obtained by the gluing of opposite faces on the dode- cahedron. *) PROCEDURE AssignmentOnFace(b: Pair; i: CARDINAL) = BEGIN IF Octf.SpinBit(b) = 0 THEN dode[i,0] := b; FOR j := 1 TO 4 DO dode[i,j] := Clock(Enext(Fnext(Enext_1(dode[i,j-1])))); END; ELSIF Octf.SpinBit(b) = 1 THEN dode[i,0] := b; FOR j := 1 TO 4 DO dode[i,j] := Clock(Enext_1(Fnext(Enext(dode[i,j-1])))); END END END AssignmentOnFace; VAR m,n: CARDINAL := 0; BEGIN FOR i := 0 TO 59 DO FOR j := 0 TO 3 DO WITH a = tetra[i,j], d = Octf.DegreeFaceRing(a) DO IF d # 1 AND Ppos(a) = NIL THEN dode[m,n] := tetra[i,j]; INC(n); IF n = 5 THEN INC(m); n := 0; END; END END END END; WITH a = dode[0,0] DO AssignmentOnFace(a,0) END; dode[1,0] := Spin(Fnext(dode[0,0])); AssignmentOnFace(dode[1,0],1); dode[2,0] := Spin(Fnext(dode[0,4])); AssignmentOnFace(dode[2,0],2); dode[3,0] := Spin(Fnext(dode[0,3])); AssignmentOnFace(dode[3,0],3); dode[4,0] := Spin(Fnext(dode[0,2])); AssignmentOnFace(dode[4,0],4); dode[5,0] := Spin(Fnext(dode[0,1])); AssignmentOnFace(dode[5,0],5); dode[8, 0] := Spin(Fnext(dode[4,2])); AssignmentOnFace(dode[8,0],8); dode[6, 0] := Spin(Fnext(dode[8,3])); AssignmentOnFace(dode[6,0],6); dode[7, 0] := Spin(Fnext(dode[6,1])); AssignmentOnFace(dode[7,0], 7); dode[9, 0] := Spin(Fnext(dode[6,4])); AssignmentOnFace(dode[9,0], 9); dode[10,0] := Spin(Fnext(dode[6,3])); AssignmentOnFace(dode[10,0],10); dode[11,0] := Spin(Fnext(dode[6,2])); AssignmentOnFace(dode[11,0],11); (* the free corners are computed follows the scheme bellow: /|\ /|\ / | \ / | \ / | \ / | \ / 3 | 2 \ / 3 | 2 \ / | \ / | \ /-----|-----\ /-----|-----\ \ 4 / \ 1 / \ 4 / \ 1 / \ / 0 \ / \ / 0 \ / \/_____\/ \/_____\/ <--- ---> SpinBit = 0 SpinBit = 1 *) END SaveFreeCorners; PROCEDURE MustBeGlue(Ti,Tj: Pair) : BOOLEAN = (* Return TRUE if the faces "Ti.facetedge.face" and "Tj.facetedge.face" have coherent orientations and must be glued. *) BEGIN WITH a = OrgV(Ti).num, ae = OrgV(Enext(Ti)).num, ae_1 = OrgV(Enext_1(Ti)).num, b = OrgV(Tj).num, be = OrgV(Enext(Tj)).num, be_1 = OrgV(Enext_1(Tj)).num DO IF (a = b AND ae = be AND ae_1 = be_1) OR (a = b AND ae = be_1 AND ae_1 = be) THEN RETURN TRUE END; RETURN FALSE END; END MustBeGlue; PROCEDURE EnextK(Ti: Pair; k : CARDINAL) : Pair = (* Given a pair "Ti", this procedure return Enext^{k}(Ti). *) BEGIN IF k = 0 THEN RETURN Ti ELSIF k = 1 THEN RETURN Enext(Ti) ELSIF k = 2 THEN RETURN Enext(Enext(Ti)) END; RETURN Ti; END EnextK; VAR poly : REF ARRAY OF ARRAY [0..7] OF Pair; count : CARDINAL := 1; faces : REF ARRAY OF Pair; glues : REF ARRAY OF Row4I; BEGIN cellnum := 60; cell4 := NEW(REF ARRAY OF Row4I, cellnum); poly := NEW(REF ARRAY OF ARRAY [0..7] OF Pair,cellnum); tetra := NEW(REF ARRAY OF ARRAY [0..3] OF Pair,cellnum); faces := NEW(REF ARRAY OF Pair, 4*cellnum); glues := NEW(REF ARRAY OF Row4I, 2*cellnum); (* creating topological tetrahedra *) FOR i := 0 TO cellnum-1 DO poly[i] := MakeTetraTopo(1,1); END; (* creating the tetrahedra *) FOR i := 0 TO cellnum-1 DO FOR j := 0 TO 3 DO tetra[i,j] := poly[i,j]; <* ASSERT Ppos(tetra[i,j]) = NIL *> END END; (* cells with corners perfectly assigments *) cell4[ 0]:=Row4I{100,500, 0, 1}; cell4[ 1]:=Row4I{100,500, 1, 4}; cell4[ 2]:=Row4I{100,500, 4, 7}; cell4[ 3]:=Row4I{100,500, 7, 2}; cell4[ 4]:=Row4I{100,500, 2, 0}; cell4[ 5]:=Row4I{500,101, 0, 1}; cell4[ 6]:=Row4I{500,101, 1, 5}; cell4[ 7]:=Row4I{500,101, 5, 8}; cell4[ 8]:=Row4I{500,101, 8, 3}; cell4[ 9]:=Row4I{500,101, 3, 0}; cell4[ 10]:=Row4I{500,102, 2, 0}; cell4[ 11]:=Row4I{500,102, 0, 3}; cell4[ 12]:=Row4I{500,102, 3, 9}; cell4[ 13]:=Row4I{500,102, 9, 6}; cell4[ 14]:=Row4I{500,102, 6, 2}; cell4[ 15]:=Row4I{103,500, 6, 2}; cell4[ 16]:=Row4I{500,103, 7, 2}; cell4[ 17]:=Row4I{103,500, 7, 13}; cell4[ 18]:=Row4I{103,500, 13, 12}; cell4[ 19]:=Row4I{500,103, 6, 12}; cell4[ 20]:=Row4I{500,104, 1, 4}; cell4[ 21]:=Row4I{500,104, 4, 10}; cell4[ 22]:=Row4I{500,104, 10, 11}; cell4[ 23]:=Row4I{500,104, 11, 5}; cell4[ 24]:=Row4I{500,104, 5, 1}; cell4[ 25]:=Row4I{500,105, 9, 3}; cell4[ 26]:=Row4I{500,105, 3, 8}; cell4[ 27]:=Row4I{500,105, 8, 14}; cell4[ 28]:=Row4I{500,105, 14, 15}; cell4[ 29]:=Row4I{500,105, 15, 9}; cell4[ 30]:=Row4I{500,106, 12, 6}; cell4[ 31]:=Row4I{500,106, 6, 9}; cell4[ 32]:=Row4I{500,106, 9, 15}; cell4[ 33]:=Row4I{500,106, 15, 18}; cell4[ 34]:=Row4I{500,106, 18, 12}; cell4[ 35]:=Row4I{500,107, 4, 7}; cell4[ 36]:=Row4I{500,107, 7, 13}; cell4[ 37]:=Row4I{500,107, 13, 16}; cell4[ 38]:=Row4I{500,107, 16, 10}; cell4[ 39]:=Row4I{500,107, 10, 4}; cell4[ 40]:=Row4I{108,500, 5, 8}; cell4[ 41]:=Row4I{108,500, 8, 14}; cell4[ 42]:=Row4I{108,500, 14, 17}; cell4[ 43]:=Row4I{108,500, 17, 11}; cell4[ 44]:=Row4I{108,500, 11, 5}; cell4[ 45]:=Row4I{109,500, 18, 12}; cell4[ 46]:=Row4I{109,500, 12, 13}; cell4[ 47]:=Row4I{109,500, 13, 16}; cell4[ 48]:=Row4I{109,500, 16, 19}; cell4[ 49]:=Row4I{109,500, 19, 18}; cell4[ 50]:=Row4I{500,110, 18, 15}; cell4[ 51]:=Row4I{500,110, 15, 14}; cell4[ 52]:=Row4I{500,110, 14, 17}; cell4[ 53]:=Row4I{500,110, 17, 19}; cell4[ 54]:=Row4I{500,110, 19, 18}; cell4[ 55]:=Row4I{111,500, 10, 11}; cell4[ 56]:=Row4I{111,500, 11, 17}; cell4[ 57]:=Row4I{111,500, 17, 19}; cell4[ 58]:=Row4I{111,500, 19, 16}; cell4[ 59]:=Row4I{111,500, 16, 10}; (* set the labels for each tetrahedra *) FOR i := 0 TO cellnum-1 DO SetCornersTetra(i,cell4[i]); END; (* builds the table of faces for choose which tetrahedra must be gluing. *) FOR i := 0 TO cellnum-1 DO FOR k := 0 TO 3 DO faces[(4*i)+k] := tetra[i,k]; END END; (* computing which cells must be gluing. *) FOR k := 0 TO LAST(faces^) DO FOR l := k+1 TO LAST(faces^) DO FOR m := 0 TO 2 DO WITH e = EnextK(faces[l],m) DO IF MustBeGlue(faces[k],e) THEN WITH kc = k MOD 4, kt = k DIV 4, lc = l MOD 4, lt = l DIV 4 DO glues[count-1] := Row4I{kt,lt,kc,lc}; INC(count); END END END END END END; (* Do the automatic gluing of tetrahedra *) FOR i := 0 TO LAST(glues^) DO WITH c = glues[i] DO IF c # Row4I{0,0,0,0} THEN EVAL Gluing(c[0],c[1],c[2],c[3]); END END END; (* setting the origins. *) FOR i := 0 TO cellnum-1 DO FOR j := 0 TO 3 DO WITH a = tetra[i,j], b = Enext(a), c = Enext_1(a) DO Triangulation.SetAllOrgs(a,OrgV(a)); Triangulation.SetAllOrgs(b,OrgV(b)); Triangulation.SetAllOrgs(c,OrgV(c)); END END END; SaveFreeCorners(); RETURN dode; END MakeDodecahedronTriang; BEGIN END VStar. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/VarKamSpring.m3 MODULE VarKamSpring; (* Last Version: 18-11-2000 *) IMPORT LR4, Triangulation, Fmt, Stdio, Wr, Thread, Octf, Math; FROM Triangulation IMPORT Topology, OrgV, Pneg; FROM Energy IMPORT Coords, Gradient; FROM Stdio IMPORT stderr; FROM Octf IMPORT Pair, Clock, Fnext; CONST inf = 10.0E30; TYPE BOOL = BOOLEAN; BOOLS = ARRAY OF BOOL; LONG = LONGREAL; LONGS = ARRAY OF LONG; NAT = CARDINAL; NATS = ARRAY OF NAT; DistanceMatrix = ARRAY OF ARRAY OF REAL; REVEAL T = Public BRANDED OBJECT top: Topology; (* The topology *) termVar: REF BOOLS; (* TRUE if vertex is variable & existing *) m : REF DistanceMatrix; (* Matrix of initial distances *) eDdif: REF ARRAY OF LONGS; (* (Work) Gradient of "e" rel. to "dif" *) L : LONG; (* length of spring *) OVERRIDES init := Init; defTop := DefTop; defVar := DefVar; eval := Eval; name := Name; END; PROCEDURE Init(erg: T): T = BEGIN RETURN erg END Init; PROCEDURE DefTop(erg: T; READONLY top: Topology) = VAR dmax : LONG; BEGIN WITH NV = top.NV DO erg.m := ComputeDistanceMatrix(top); (*PrintHalfMatrix(erg.m, NV);*) ShortestPath(erg.m, NV); (* PrintHalfMatrix(erg.m, NV); *) dmax := FLOAT(FindMaxDistance(erg.m, NV), LONG); erg.L := FLOAT(erg.length,LONG)/dmax; erg.top := top; erg.termVar := NEW(REF BOOLS, NV); erg.eDdif := NEW(REF ARRAY OF LONGS, NV, NV); (*PrintHalfMatrix(erg.k, NV);*) (* Just in case the client forgets to call "defVar": *) FOR i := 0 TO top.NV-1 DO erg.termVar^[i] := FALSE END; END END DefTop; PROCEDURE DefVar(erg: T; READONLY variable: BOOLS) = BEGIN (* Decide which vertices are relevant to kamada energy. A vertex is relevant iff it is variable. *) WITH NV = erg.top.NV, termVar = erg.termVar^ DO (* Find the relevant vertices: *) <* ASSERT NUMBER(variable) = NV *> FOR v := 0 TO NV-1 DO termVar[v] := variable[v]; END END END DefVar; PROCEDURE ComputeDistanceMatrix( READONLY top : Triangulation.Topology; ) : REF DistanceMatrix = VAR m: REF DistanceMatrix; BEGIN m := NEW(REF ARRAY OF ARRAY OF REAL, top.NV, top.NV); FOR i := 0 TO top.NV-1 DO FOR j := 0 TO top.NV-1 DO m[i,j] := inf; END; m[i,i] := 0.0; END; WITH cdg = ComputeCorrectedDegrees(top)^ DO FOR i := 0 TO top.NE-1 DO WITH a = top.edge[i].pa, b = Clock(a), i = OrgV(a).num, j = OrgV(b).num, ni = FLOAT(cdg[i], LONG), nj = FLOAT(cdg[j], LONG), lij = FLOAT(Math.sqrt(ni/nj + nj/ni), REAL) DO m[i,j] := lij; m[j,i] := lij; END END END; RETURN m; END ComputeDistanceMatrix; PROCEDURE ComputeCorrectedDegrees(READONLY top: Topology): REF NATS = (* Computes the corrected degree of each vertex, defined as the true degree for interior vertices, and the true degree plus the interior degree for border vertices. *) BEGIN WITH rd = NEW(REF NATS, top.NV), d = rd^, border = NEW(REF BOOLS, top.NV)^ DO FOR i := 0 TO LAST(d) DO d[i] := 0; border[i] := FALSE END; (* Tally interior edges twice, border edegs once: *) FOR i := 0 TO top.NE-1 DO WITH a = top.edge[i].pa, b = Clock(a), un = OrgV(a).num, vn = OrgV(b).num DO IF EdgeIsBorder(a) THEN border[un] := TRUE; border[vn] := TRUE; INC(d[un]); INC(d[vn]) ELSE INC(d[un],2); INC(d[vn],2) END; END END; (* Correct count for non-border vertices: *) FOR i := 0 TO LAST(d) DO IF NOT border[i] THEN <* ASSERT d[i] MOD 2 = 0 *> d[i] := d[i] DIV 2 END END; RETURN rd END END ComputeCorrectedDegrees; PROCEDURE EdgeIsBorder(a: Pair): BOOL = VAR b: Pair := a; BEGIN REPEAT IF Pneg(a) = NIL THEN RETURN TRUE END; b := Fnext(b); UNTIL b = a; RETURN FALSE END EdgeIsBorder; PROCEDURE FindMaxDistance( READONLY m: REF DistanceMatrix; n: INTEGER; ) : REAL = VAR max := 0.0; BEGIN FOR i := 0 TO n-1 DO FOR j := 0 TO i DO IF m[i,j] > max THEN max := m[i,j]; END END END; RETURN max; END FindMaxDistance; PROCEDURE CalculateStrength(dist: REAL) : LONG = BEGIN IF dist = 0.0 THEN RETURN 0.0d0 ELSE WITH d = FLOAT(dist, LONG) DO RETURN 1.0d0/(d*d); END END END CalculateStrength; PROCEDURE CalculateLength(dist : REAL) : LONG = BEGIN IF dist = 0.0 THEN RETURN 0.0d0 ELSE WITH d = FLOAT(dist, LONG) DO RETURN d; END END END CalculateLength; <* UNUSED *> PROCEDURE PrintDistanceMatrix(READONLY m : REF DistanceMatrix; n: INTEGER) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN FOR i := 0 TO n-1 DO FOR j := 0 TO n-1 DO IF m[i,j] = inf THEN Wr.PutText(stderr, "# "); ELSE Wr.PutText(stderr, Fmt.Real(m[i,j], prec:=2, style:=Fmt.Style.Fix) & " "); END; END; Wr.PutText(stderr, "\n"); END; END PrintDistanceMatrix; <* UNUSED *> PROCEDURE PrintHalfMatrix(READONLY m : REF DistanceMatrix; n: INTEGER) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN FOR i := 0 TO n-1 DO FOR j := 0 TO i DO IF m[i,j] = inf THEN Wr.PutText(stderr, "# "); ELSE Wr.PutText(stderr, Fmt.Real(m[i,j], prec:=2, style:=Fmt.Style.Fix) & " "); END; END; Wr.PutText(stderr, "\n"); END; END PrintHalfMatrix; PROCEDURE ShortestPath(VAR m : REF DistanceMatrix; n : INTEGER) = VAR s : REAL; BEGIN FOR i := 0 TO n-1 DO FOR j := 0 TO n-1 DO IF m[j,i] < inf THEN FOR k := 0 TO n-1 DO IF m[i,k] < inf THEN s := m[j,i] + m[i,k]; IF s < m[j,k] THEN m[j,k] := s END; END END END END END END ShortestPath; PROCEDURE Eval( erg: T; READONLY c: Coords; VAR e: LONG; grad: BOOL; VAR eDc: Gradient; ) = BEGIN WITH NV = erg.top.NV, eDdif = erg.eDdif^, termVar = erg.termVar, length = erg.L, strength = FLOAT(erg.strength, LONG), m = erg.m^ DO PROCEDURE AccumTerm(READONLY u: NAT) = (* Adds to "e" the energy term corresponding to a vertex "u". Returns also the gradient "eDdif". *) CONST Epsilon = 1.0d-10; BEGIN WITH cu = c[u] DO FOR i := u+1 TO NV-1 DO WITH cv = c[i], n = LR4.Sub(cu,cv), dif = LR4.Norm(n), d2 = dif * dif + Epsilon, duv = m[u,i], luv = length * CalculateLength(duv), kuv = strength * CalculateStrength(duv), l2 = luv * luv + Epsilon, d3 = d2 * dif + Epsilon DO e := e + kuv * ( (d2/l2) + (l2/d2) - 2.0d0 ); IF grad THEN eDdif[u,i] := 2.0d0 * kuv * ( (dif/l2) - (l2/d3) ); eDdif[i,u] := eDdif[u,i]; ELSE eDdif[u,i] := 0.0d0; eDdif[i,u] := eDdif[u,i]; END END END END END AccumTerm; PROCEDURE Distribute_eDdif(READONLY u: NAT) = (* Distribute eDdif on endpoints "c[u]" and "c[v]" *) CONST Epsilon = 1.0d-10; BEGIN WITH cu = c[u] DO FOR i := u+1 TO NV-1 DO WITH ci = c[i], n = LR4.Sub(cu,ci), dif = LR4.Norm(n)+Epsilon, eDi = eDc[i], eDu = eDc[u], difDcu = LR4.Scale(1.0d0/dif, n), difDci = LR4.Scale(-1.0d0/dif,n), eDcu = LR4.Scale(eDdif[u,i], difDcu), eDci = LR4.Scale(eDdif[u,i], difDci) DO IF termVar[i] THEN eDi := LR4.Add(eDi, eDci); END; IF termVar[u] THEN eDu := LR4.Add(eDu, eDcu); END END END END; END Distribute_eDdif; BEGIN FOR i := 0 TO NV-1 DO eDc[i]:=LR4.T{0.0d0, 0.0d0, 0.0d0, 0.0d0} END; e := 0.0d0; FOR l := 0 TO NV-1 DO IF termVar[l] THEN AccumTerm(l); IF grad THEN Distribute_eDdif(l); END END END END END END Eval; PROCEDURE Name(erg: T): TEXT = BEGIN RETURN "VarKamada(length := " & Fmt.Real(erg.length,Fmt.Style.Fix,prec := 3) & " strength := " & Fmt.Real(erg.strength,Fmt.Style.Fix,prec:= 3) & ")"; END Name; BEGIN END VarKamSpring. (* Last edited on 2001-05-21 02:36:15 by stolfi *) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/VarWindingEnergy.m3 MODULE VarWindingEnergy; IMPORT Triangulation, LR4, LR3, LR3Extras, Math, Fmt, Wr, Thread; FROM Octf IMPORT Enext, Enext_1, Fnext, DegreeFaceRing; FROM Triangulation IMPORT OrgV, Topology, Pair, Pneg; FROM Energy IMPORT Coords, Gradient; FROM Stdio IMPORT stderr; TYPE BOOL = BOOLEAN; BOOLS = ARRAY OF BOOL; NAT = CARDINAL; NATS = ARRAY OF CARDINAL; Coords3D = ARRAY OF LR3.T; REVEAL T = Public BRANDED OBJECT K: LONGREAL; (* The energy normalization factor *) top: Topology; (* The topology *) termOK: REF BOOLS; (* The terms that should be included in the energy. *) term: REF Terms; (* Vertices in each term. *) rDpw, sDpw: REF Coords3D; (* Work areas for "Eval". *) OVERRIDES init := Init; defTop := DefTop; defVar := DefVar; eval := Eval; name := Name; END; TYPE Term = RECORD (* Vertex numbers included in some energy term. *) un, vn: NAT; (* Endpoints of some edge. *) wn: REF NATS; (* Tips of faces incident to that edge. *) ex: REF BOOLS; (* "ex[i]" = cell between wn[i] and wn[i-1] exists. *) END; Terms = ARRAY OF Term; CONST Debug = FALSE; PROCEDURE Init(erg: T): T = BEGIN RETURN erg END Init; PROCEDURE DefTop(erg: T; READONLY top: Topology) = BEGIN erg.K := 1.0d0/FLOAT(top.NE, LONGREAL); erg.top := top; erg.termOK := NEW(REF BOOLS, top.NE); erg.term := CollectTerms(top); (* Size of "rDpw", "sDpw" is maximum edge degree: *) WITH maxDeg = MaxEdgeDegree(erg.term^) DO erg.rDpw := NEW(REF Coords3D, maxDeg); erg.sDpw := NEW(REF Coords3D, maxDeg); END; (* Just in case the client forgets to call "defVar": *) FOR i := 0 TO top.NE-1 DO erg.termOK[i] := FALSE END; END DefTop; PROCEDURE CollectTerms(READONLY top: Topology): REF Terms = (* Collects relevant vertices for each edge. *) VAR b: Pair; k: NAT; BEGIN WITH NE = top.NE, termr = NEW(REF Terms, NE), term = termr^ DO FOR i := 0 TO NE-1 DO WITH e = top.edge[i], a = e.pa, deg = DegreeFaceRing(a), wnr = NEW(REF NATS, deg), wn = wnr^, exr = NEW(REF BOOLS, deg), ex = exr^, un = OrgV(a).num, vn = OrgV(Enext(a)).num DO b := a; k := 0; REPEAT wn[k] := OrgV(Enext_1(b)).num; ex[k] := Pneg(b) # NIL; b := Fnext(b); INC(k) UNTIL b = a; <* ASSERT k = deg *> term[i] := Term{un := un, vn := vn, wn := wnr, ex := exr} END END; RETURN termr END END CollectTerms; PROCEDURE MaxEdgeDegree(READONLY term: Terms): NAT = VAR maxDeg: NAT := 0; BEGIN FOR i := 0 TO LAST(term) DO maxDeg := MAX(maxDeg, NUMBER(term[i].wn^)) END; RETURN maxDeg END MaxEdgeDegree; PROCEDURE DefVar(erg: T; READONLY variable: BOOLS) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN (* Decide which edges are relevant to "VarWinding" energy. A edge is relevant iff its star includes at least one variable vertex.*) WITH termOK = erg.termOK^, edge = erg.top.edge^ DO <* ASSERT NUMBER(variable) = erg.top.NV *> Wr.PutText(stderr, "VarWindingEnergy: relevant edges = { "); FOR i := 0 TO LAST(termOK) DO WITH e = edge[i] DO <* ASSERT e.num = i *> termOK[i] := e.exists AND EdgeStarIsVariable(e.pa, variable); IF termOK[i] THEN Wr.PutText(stderr, " " & Fmt.Int(i)) END; END END; Wr.PutText(stderr, " }\n"); END END DefVar; PROCEDURE EdgeStarIsVariable(a: Pair; READONLY variable: BOOLS): BOOL = VAR b: Pair; BEGIN WITH u = OrgV(a), v = OrgV(Enext(a)) DO IF variable[u.num] OR variable[v.num] THEN RETURN TRUE ELSE b := a; REPEAT WITH w = OrgV(Enext_1(b)) DO IF variable[w.num] THEN RETURN TRUE END END; b := Fnext(b) UNTIL b = a; RETURN FALSE END END END EdgeStarIsVariable; PROCEDURE Eval( erg: T; READONLY c: Coords; VAR e: LONGREAL; grad: BOOL; VAR eDc: Gradient; ) = BEGIN WITH NV = erg.top.NV, NE = erg.top.NE, termOK = erg.termOK^, term = erg.term^, K = erg.K, rDpw = erg.rDpw^, sDpw = erg.sDpw^ DO e := 0.0d0; (* Clear gradient accumulators *) FOR i := 0 TO NV-1 DO eDc[i] := LR4.T{0.0d0, ..} END; (* Enumerate edges and compute edge sums: *) FOR i := 0 TO NE-1 DO IF termOK[i] THEN AddTerm(term[i], c, K, grad, e, eDc, rDpw, sDpw) END END; END END Eval; PROCEDURE AddTerm( READONLY term: Term; READONLY c: Coords; K: LONGREAL; grad: BOOL; VAR (*IO*) e: LONGREAL; VAR (*IO*) eDc: Gradient; VAR rDpw, sDpw: Coords3D; (* Work areas. *) ) = (* Adds one term of the energy to "e". If "grad" is set, also adds the gradient of that term to "eDc". *) VAR r, s: LONGREAL; (* Radial and perimetral sums for term. *) rDpu, rDpv: LR3.T; (* Derivatives of "r" wrt edge endpoints. *) sDpu, sDpv: LR3.T; (* Derivatives of "s" wrt edge endpoints. *) t: LONGREAL; (* An energy term, corresponding to a single edge. *) tDr, tDs: LONGREAL; (* Derivatives of "t" w.r.t. "r" and "s". *) gaps: NAT; (* Degree of "e", and num of missing cells. *) SNorm, RNorm: LONGREAL; (* Normalization factors for "r" and "s". *) CONST Epsilon = 1.0d-20; (* To avoid divide by zero. *) Pi = 3.1415926535897932d0; (* Pi *) HfPi = 1.5707963267948966d0; (* Pi/2 *) BEGIN WITH un = term.un, pu = SUBARRAY(c[un], 0, 3), vn = term.vn, pv = SUBARRAY(c[vn], 0, 3), h = LR3.Sub(pv, pu), h2 = LR3.Dot(h, h), hm = Math.sqrt(h2), wn = term.wn^, ex = term.ex^, N = FLOAT(NUMBER(wn), LONGREAL) DO PROCEDURE Compute_r_s_Perimeter() = (* Returns in "r" and "s" the sums corresponding to the given term of the energy ("Perimeter" formula). Also, if "grad" is set, computes the gradients "rDpu", "rDPv", "rDpw[k]" of "r" relative to the 3D coordinates of relevant vertices, and similarly for "s". Also defines the geometry-independent constants "RNorm" and "SNorm", such that a regular edge star of height "h" and radius "r" has "r = RNorm·h^2·b^2" and "s = SNorm·h^2·b^2". *) VAR kx, xn: CARDINAL ; px: LR3.T; gaps: NAT; BEGIN r := Epsilon; s := Epsilon; gaps := 0; IF grad THEN rDpu := LR3.T{0.0d0,..}; rDpv := LR3.T{0.0d0,..}; sDpu := LR3.T{0.0d0,..}; sDpv := LR3.T{0.0d0,..}; FOR i := 0 TO LAST(wn) DO rDpw[i] := LR3.T{0.0d0,..}; sDpw[i] := LR3.T{0.0d0,..} END END; kx := LAST(wn); xn := wn[kx]; px := SUBARRAY(c[xn], 0, 3); FOR ky := 0 TO LAST(wn) DO WITH yn = wn[ky], py = SUBARRAY(c[yn], 0, 3), fy = LR3.Sub(py, pu), ry = LR3Extras.Cross(h, fy), rb = LR3.Dot(ry,ry), gy = LR3.Sub(py, px), sy = LR3Extras.Cross(h, gy), sb = LR3.Dot(sy,sy) DO r := r + rb; IF ex[ky] THEN s := s + sb ELSE INC(gaps) END; IF grad THEN WITH rbDry = LR3.Scale(2.0d0, ry), rbDfy = LR3Extras.Cross(rbDry, h), rbDh = LR3Extras.Cross(fy, rbDry) DO IF Debug THEN PrL("rb = ", rb); PrEOL(); PrV("rbDfy = ", rbDfy); PrEOL(); PrV("rbDh = ", rbDh); PrEOL(); END; rDpw[ky] := LR3.Add(rDpw[ky], rbDfy); rDpu := LR3.Sub(rDpu, LR3.Add(rbDfy, rbDh)); rDpv := LR3.Add(rDpv, rbDh); IF ex[ky] THEN WITH sbDsy = LR3.Scale(2.0d0, sy), sbDgy = LR3Extras.Cross(sbDsy, h), sbDh = LR3Extras.Cross(gy, sbDsy) DO IF Debug THEN PrL("sb = ", sb); PrEOL(); PrV("sbDgy = ", sbDgy); PrEOL(); PrV("sbDh = ", sbDh); PrEOL(); END; sDpw[ky] := LR3.Add(sDpw[ky], sbDgy); sDpw[kx] := LR3.Sub(sDpw[kx], sbDgy); sDpu := LR3.Sub(sDpu, sbDh); sDpv := LR3.Add(sDpv, sbDh); END END END END; kx := ky; xn := yn; px := py; END; END; IF Debug THEN PrL("r = ", r); PrEOL(); PrV("rDpu = ", rDpu); PrEOL(); PrV("rDpv = ", rDpv); PrEOL(); PrL("s = ", s); PrEOL(); PrV("sDpu = ", sDpu); PrEOL(); PrV("sDpv = ", sDpv); PrEOL(); PrEOL(); END; RNorm := N; IF gaps = 0 THEN (* Edge is interior; ideally, winding number should be ±1 *) WITH sn = Math.sin(Pi/N) DO SNorm := 4.0d0*N*sn*sn END ELSE <* ASSERT gaps < NUMBER(wn) *> (* Edge is on border; winding number should be ±1/2, with fencepost correction *) WITH G = FLOAT(gaps, LONGREAL), sn = Math.sin(HfPi/(N-G)) DO SNorm := 4.0d0*(N-G)*sn*sn END END END Compute_r_s_Perimeter; PROCEDURE Compute_r_s_Area() = (* Returns in "r" and "s" the sums corresponding to the given term of the energy ("Area" formula). Also, if "grad" is set, computes the gradients "rDpu", "rDPv", "rDpw[k]" of "r" relative to the 3D coordinates of relevant vertices, and similarly for "s". Also defines the geometry-independent constants "RNorm" and "SNorm", such that a regular edge star of height "h" and radius "r" has "r = RNorm·h^2·b^2" and "s = SNorm·h^2·b^2". *) VAR kx, xn: CARDINAL ; px: LR3.T; gaps: NAT; BEGIN r := Epsilon; s := Epsilon; gaps := 0; IF grad THEN rDpu := LR3.T{0.0d0,..}; rDpv := LR3.T{0.0d0,..}; sDpu := LR3.T{0.0d0,..}; sDpv := LR3.T{0.0d0,..}; FOR i := 0 TO LAST(wn) DO rDpw[i] := LR3.T{0.0d0,..}; sDpw[i] := LR3.T{0.0d0,..} END END; kx := LAST(wn); xn := wn[kx]; px := SUBARRAY(c[xn], 0, 3); FOR ky := 0 TO LAST(wn) DO WITH yn = wn[ky], py = SUBARRAY(c[yn], 0, 3), fy = LR3.Sub(py, pu), ry = LR3Extras.Cross(h, fy), rb = LR3.Dot(ry,ry), dy = LR3Extras.Cross(fx,fy), sb = LR3.Dot(h, dy) DO r := r + rb; IF ex[ky] THEN s := s + sb ELSE INC(gaps) END; IF grad THEN WITH rbDry = LR3.Scale(2.0d0, ry), rbDfy = LR3Extras.Cross(rbDry, h), rbDh = LR3Extras.Cross(fy, rbDry) DO IF Debug THEN PrL("rb = ", rb); PrEOL(); PrV("rbDfy = ", rbDfy); PrEOL(); PrV("rbDh = ", rbDh); PrEOL(); END; rDpw[ky] := LR3.Add(rDpw[ky], rbDfy); rDpu := LR3.Sub(rDpu, LR3.Add(rbDfy, rbDh)); rDpv := LR3.Add(rDpv, rbDh); IF ex[ky] THEN WITH sbDdy = fx, sbDry = LR3Extras.Cross(h, sbDdy), sbDfy = - sbDry * h × , sbDfx = , sbDgy = LR3Extras.Cross(sbDsy, h), sbDh = LR3Extras.Cross(gy, sbDsy) DO IF Debug THEN PrL("sb = ", sb); PrEOL(); PrV("sbDgy = ", sbDgy); PrEOL(); PrV("sbDh = ", sbDh); PrEOL(); END; sDpw[ky] := LR3.Add(sDpw[ky], sbDgy); sDpw[kx] := LR3.Sub(sDpw[kx], sbDgy); sDpu := LR3.Sub(sDpu, sbDh); sDpv := LR3.Add(sDpv, sbDh); END END END END; kx := ky; xn := yn; px := py; END; END; IF Debug THEN PrL("r = ", r); PrEOL(); PrV("rDpu = ", rDpu); PrEOL(); PrV("rDpv = ", rDpv); PrEOL(); PrL("s = ", s); PrEOL(); PrV("sDpu = ", sDpu); PrEOL(); PrV("sDpv = ", sDpv); PrEOL(); PrEOL(); END; END Compute_r_s_Area; PROCEDURE Compute_RNorm_SNorm_Perimeter() = (* Defines "RNorm,SNorm" which are the expected values of "r,s", for a regular edge star, divided by "h^2·b^2" where "h" is the length of the edge and "b" is the radius of the star. *) BEGIN RNorm := N; IF gaps = 0 THEN (* Edge is interior; ideally, winding number should be ±1 *) WITH sn = Math.sin(Pi/N) DO SNorm := 4.0d0*N*sn*sn END ELSE <* ASSERT gaps < NUMBER(wn) *> (* Edge is on border; winding number should be ±1/2, with fencepost correction *) WITH G = FLOAT(gaps, LONGREAL), sn = Math.sin(HfPi/(N-G)) DO SNorm := 4.0d0*(N-G)*sn*sn END END END Compute_RNorm_SNorm; PROCEDURE Compute_t_from_r_s() = (* Returns in "t" the energy term corresponding to an edge with sums "r" and "s" Also, if "grad" is true, stores in "tDr" and "tDs" the derivatives of the term relative to those sums. *) BEGIN WITH R = r/RNorm, S = s/SNorm, f = R/S, g = S/R, y = f + g, z = y*y DO t := K * (z - 4.0d0); IF Debug THEN PrL("R = ", R); PrL("S = ", S); PrL("t = ", t); PrEOL(); END; IF grad THEN WITH zDy = 2.0d0 * y, zDr = zDy*(1.0d0/S - g/R)/RNorm, zDs = zDy*(1.0d0/R - f/S)/SNorm DO tDr := K * zDr; tDs := K * zDs END ELSE tDr := 0.0d0; tDs := 0.0d0; END END END Compute_t_from_r_s; PROCEDURE Distribute_tDr_tDs() = (* Accumulates in "eDc" the gradient of an energy term "t" relative to the vertices in the star of the corresponding edge "Edg(a)", given the derivatives "tDr" and "tDs" of the term relative to the edge sums "r" and "s". *) PROCEDURE AddGradientToVertex(vn: NAT; rDpv, sDpv: LR3.T) = (* Adds to "eDc" the contribution due to vertex "vn". *) BEGIN WITH eDcv = eDc[vn] DO eDcv[0] := eDcv[0] + tDr * rDpv[0] + tDs * sDpv[0]; eDcv[1] := eDcv[1] + tDr * rDpv[1] + tDs * sDpv[1]; eDcv[2] := eDcv[2] + tDr * rDpv[2] + tDs * sDpv[2] END END AddGradientToVertex; BEGIN AddGradientToVertex(un, rDpu, sDpu); AddGradientToVertex(vn, rDpv, sDpv); FOR k := 0 TO LAST(wn) DO AddGradientToVertex(wn[k], rDpw[k], sDpw[k]) END END Distribute_tDr_tDs; BEGIN Compute_r_s(); Compute_t_from_r_s(); e := e + t; IF grad THEN Distribute_tDr_tDs() END END END END AddTerm; PROCEDURE Name(<*UNUSED*>erg: T) : TEXT = BEGIN RETURN "VarWinding()" END Name; PROCEDURE PrI(prefix: TEXT; x: INTEGER) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(stderr, " "); Wr.PutText(stderr, prefix); Wr.PutText(stderr, Fmt.Pad(Fmt.Int(x), 12)); END PrI; PROCEDURE PrL(prefix: TEXT; x: LONGREAL) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(stderr, " "); Wr.PutText(stderr, prefix); Wr.PutText(stderr, Fmt.Pad(Fmt.LongReal(x, style := Fmt.Style.Fix, prec := 8), 22) ); END PrL; PROCEDURE PrV(prefix: TEXT; x: LR3.T) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(stderr, " "); Wr.PutText(stderr, prefix); FOR i := 0 TO 2 DO Wr.PutText(stderr, Fmt.Pad(Fmt.LongReal(x[i], style := Fmt.Style.Fix, prec := 8), 21) & " " ) END; END PrV; PROCEDURE PrEOL() = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(stderr, "\n"); END PrEOL; BEGIN END VarWindingEnergy. (* Last edited on 2001-05-20 19:47:15 by stolfi *) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/lib/WindingEnergy.m3 MODULE WindingEnergy; IMPORT Triangulation, LR4, LR3, LR3Extras, Math, Fmt, Wr, Thread; FROM Octf IMPORT Enext, Enext_1, Fnext, DegreeFaceRing; FROM Triangulation IMPORT OrgV, Topology, Pair, Pneg; FROM Energy IMPORT Coords, Gradient; FROM Stdio IMPORT stderr; TYPE BOOL = BOOLEAN; BOOLS = ARRAY OF BOOL; NAT = CARDINAL; NATS = ARRAY OF CARDINAL; Coords3D = ARRAY OF LR3.T; REVEAL T = Public BRANDED OBJECT K: LONGREAL; (* The energy normalization factor *) top: Topology; (* The topology *) termOK: REF BOOLS; (* The terms that should be included in the energy. *) term: REF Terms; (* Vertices in each term. *) rDpw, sDpw: REF Coords3D; (* Work areas for "Eval". *) OVERRIDES init := Init; defTop := DefTop; defVar := DefVar; eval := Eval; name := Name; END; TYPE Term = RECORD (* Vertex numbers included in some energy term. *) un, vn: NAT; (* Endpoints of some edge. *) wn: REF NATS; (* Tips of faces incident to that edge. *) ex: REF BOOLS; (* "ex[i]" = cell between wn[i] and wn[i-1] exists. *) END; Terms = ARRAY OF Term; CONST Debug = FALSE; PROCEDURE Init(erg: T): T = BEGIN RETURN erg END Init; PROCEDURE DefTop(erg: T; READONLY top: Topology) = BEGIN erg.K := 1.0d0/FLOAT(top.NE, LONGREAL); erg.top := top; erg.termOK := NEW(REF BOOLS, top.NE); erg.term := CollectTerms(top); (* Size of "rDpw", "sDpw" is maximum edge degree: *) WITH maxDeg = MaxEdgeDegree(erg.term^) DO erg.rDpw := NEW(REF Coords3D, maxDeg); erg.sDpw := NEW(REF Coords3D, maxDeg); END; (* Just in case the client forgets to call "defVar": *) FOR i := 0 TO top.NE-1 DO erg.termOK[i] := FALSE END; END DefTop; PROCEDURE CollectTerms(READONLY top: Topology): REF Terms = (* Collects relevant vertices for each edge. *) VAR b: Pair; k: NAT; BEGIN WITH NE = top.NE, termr = NEW(REF Terms, NE), term = termr^ DO FOR i := 0 TO NE-1 DO WITH e = top.edge[i], a = e.pa, deg = DegreeFaceRing(a), wnr = NEW(REF NATS, deg), wn = wnr^, exr = NEW(REF BOOLS, deg), ex = exr^, un = OrgV(a).num, vn = OrgV(Enext(a)).num DO b := a; k := 0; REPEAT wn[k] := OrgV(Enext_1(b)).num; ex[k] := Pneg(b) # NIL; b := Fnext(b); INC(k) UNTIL b = a; <* ASSERT k = deg *> term[i] := Term{un := un, vn := vn, wn := wnr, ex := exr} END END; RETURN termr END END CollectTerms; PROCEDURE MaxEdgeDegree(READONLY term: Terms): NAT = VAR maxDeg: NAT := 0; BEGIN FOR i := 0 TO LAST(term) DO maxDeg := MAX(maxDeg, NUMBER(term[i].wn^)) END; RETURN maxDeg END MaxEdgeDegree; PROCEDURE DefVar(erg: T; READONLY variable: BOOLS) = BEGIN (* Decide which edges are relevant to "Winding" energy. A edge is relevant iff its star includes at least one variable vertex.*) WITH termOK = erg.termOK^, edge = erg.top.edge^ DO <* ASSERT NUMBER(variable) = erg.top.NV *> FOR i := 0 TO LAST(termOK) DO WITH e = edge[i] DO <* ASSERT e.num = i *> termOK[i] := e.exists AND EdgeStarIsVariable(e.pa, variable); END END END END DefVar; PROCEDURE EdgeStarIsVariable(a: Pair; READONLY variable: BOOLS): BOOL = VAR b: Pair; BEGIN WITH u = OrgV(a), v = OrgV(Enext(a)) DO IF variable[u.num] OR variable[v.num] THEN RETURN TRUE ELSE b := a; REPEAT WITH w = OrgV(Enext_1(b)) DO IF variable[w.num] THEN RETURN TRUE END END; b := Fnext(b) UNTIL b = a; RETURN FALSE END END END EdgeStarIsVariable; PROCEDURE Eval( erg: T; READONLY c: Coords; VAR e: LONGREAL; grad: BOOL; VAR eDc: Gradient; ) = BEGIN WITH NV = erg.top.NV, NE = erg.top.NE, termOK = erg.termOK^, term = erg.term^, K = erg.K, rDpw = erg.rDpw^, sDpw = erg.sDpw^ DO e := 0.0d0; (* Clear gradient accumulators *) FOR i := 0 TO NV-1 DO eDc[i] := LR4.T{0.0d0, ..} END; (* Enumerate edges and compute edge sums: *) FOR i := 0 TO NE-1 DO IF termOK[i] THEN AddTerm(term[i], c, K, grad, e, eDc, rDpw, sDpw) END END; END END Eval; PROCEDURE AddTerm( READONLY term: Term; READONLY c: Coords; K: LONGREAL; grad: BOOL; VAR (*IO*) e: LONGREAL; VAR (*IO*) eDc: Gradient; VAR rDpw, sDpw: Coords3D; (* Work areas. *) ) = (* Adds one term of the energy to "e". If "grad" is set, also adds the gradient of that term to "eDc". *) VAR r, s: LONGREAL; (* Radial and perimetral sums for term. *) rDpu, rDpv: LR3.T; (* Derivatives of "r" wrt edge endpoints. *) sDpu, sDpv: LR3.T; (* Derivatives of "s" wrt edge endpoints. *) t: LONGREAL; (* An energy term, corresponding to a single edge. *) tDr, tDs: LONGREAL; (* Derivatives of "t" w.r.t. "r" and "s". *) SNorm, RNorm: LONGREAL; (* Normalization factors for "r" and "s". *) CONST Epsilon = 1.0d-20; (* To avoid divide by zero. *) Pi = 3.1415926535897932d0; (* Pi *) HfPi = 1.5707963267948966d0; (* Pi/2 *) BEGIN WITH un = term.un, pu = SUBARRAY(c[un], 0, 3), vn = term.vn, pv = SUBARRAY(c[vn], 0, 3), h = LR3.Sub(pv, pu), wn = term.wn^, ex = term.ex^, N = FLOAT(NUMBER(wn), LONGREAL) DO PROCEDURE Compute_r_s() = (* Returns in "r" and "s" the sums corresponding to the given term of the energy. Also, if "grad" is set, computes the gradients "rDpu", "rDPv", "rDpw[k]" of "r" relative to the 3D coordinates of relevant vertices, and similarly for "s". Also defines the geometry-independent constants "RNorm" and "SNorm", such that a regular edge star of height "h" and radius "r" has "r = RNorm·h^2·b^2" and "s = SNorm·h^2·b^2". *) VAR kx, xn: CARDINAL ; px: LR3.T; gaps: NAT; BEGIN r := Epsilon; s := Epsilon; gaps := 0; IF grad THEN rDpu := LR3.T{0.0d0,..}; rDpv := LR3.T{0.0d0,..}; sDpu := LR3.T{0.0d0,..}; sDpv := LR3.T{0.0d0,..}; FOR i := 0 TO LAST(wn) DO rDpw[i] := LR3.T{0.0d0,..}; sDpw[i] := LR3.T{0.0d0,..} END END; kx := LAST(wn); xn := wn[kx]; px := SUBARRAY(c[xn], 0, 3); FOR ky := 0 TO LAST(wn) DO WITH yn = wn[ky], py = SUBARRAY(c[yn], 0, 3), fy = LR3.Sub(py, pu), ry = LR3Extras.Cross(h, fy), rb = LR3.Dot(ry,ry), gy = LR3.Sub(py, px), sy = LR3Extras.Cross(h, gy), sb = LR3.Dot(sy,sy) DO r := r + rb; IF ex[ky] THEN s := s + sb ELSE INC(gaps) END; IF grad THEN WITH rbDry = LR3.Scale(2.0d0, ry), rbDfy = LR3Extras.Cross(rbDry, h), rbDh = LR3Extras.Cross(fy, rbDry) DO IF Debug THEN PrL("rb = ", rb); PrEOL(); PrV("rbDfy = ", rbDfy); PrEOL(); PrV("rbDh = ", rbDh); PrEOL(); END; rDpw[ky] := LR3.Add(rDpw[ky], rbDfy); rDpu := LR3.Sub(rDpu, LR3.Add(rbDfy, rbDh)); rDpv := LR3.Add(rDpv, rbDh); IF ex[ky] THEN WITH sbDsy = LR3.Scale(2.0d0, sy), sbDgy = LR3Extras.Cross(sbDsy, h), sbDh = LR3Extras.Cross(gy, sbDsy) DO IF Debug THEN PrL("sb = ", sb); PrEOL(); PrV("sbDgy = ", sbDgy); PrEOL(); PrV("sbDh = ", sbDh); PrEOL(); END; sDpw[ky] := LR3.Add(sDpw[ky], sbDgy); sDpw[kx] := LR3.Sub(sDpw[kx], sbDgy); sDpu := LR3.Sub(sDpu, sbDh); sDpv := LR3.Add(sDpv, sbDh); END END END END; kx := ky; xn := yn; px := py; END; END; IF Debug THEN PrL("r = ", r); PrEOL(); PrV("rDpu = ", rDpu); PrEOL(); PrV("rDpv = ", rDpv); PrEOL(); PrL("s = ", s); PrEOL(); PrV("sDpu = ", sDpu); PrEOL(); PrV("sDpv = ", sDpv); PrEOL(); PrEOL(); END; RNorm := N; IF gaps = 0 THEN (* Edge is interior. *) (* Ideally, winding number should be ±1. *) WITH sn = Math.sin(Pi/N) DO SNorm := 4.0d0*N*sn*sn END ELSE <* ASSERT gaps < NUMBER(wn) *> (* Edge is on border. *) (* Winding number should be ±1/2, with fencepost correction. *) WITH G = FLOAT(gaps, LONGREAL), sn = Math.sin(HfPi/(N-G)) DO SNorm := 4.0d0*(N-G)*sn*sn END END END Compute_r_s; PROCEDURE Compute_t_from_r_s() = (* Returns in "t" the energy term corresponding to an edge with sums "r" and "s" Also, if "grad" is true, stores in "tDr" and "tDs" the derivatives of the term relative to those sums. *) BEGIN WITH R = r/RNorm, S = s/SNorm, f = R/S, g = S/R, z = f + g DO t := K * (z - 2.0d0); IF Debug THEN PrL("R = ", R); PrL("S = ", S); PrL("t = ", t); PrEOL(); END; IF grad THEN WITH zDr = (1.0d0/S - g/R)/RNorm, zDs = (1.0d0/R - f/S)/SNorm DO tDr := K * zDr; tDs := K * zDs END ELSE tDr := 0.0d0; tDs := 0.0d0; END END END Compute_t_from_r_s; PROCEDURE Distribute_tDr_tDs() = (* Accumulates in "eDc" the gradient of an energy term "t" relative to the vertices in the star of the corresponding edge "Edg(a)", given the derivatives "tDr" and "tDs" of the term relative to the edge sums "r" and "s". *) PROCEDURE AddGradientToVertex(vn: NAT; rDpv, sDpv: LR3.T) = (* Adds to "eDc" the contribution due to vertex "vn". *) BEGIN WITH eDcv = eDc[vn] DO eDcv[0] := eDcv[0] + tDr * rDpv[0] + tDs * sDpv[0]; eDcv[1] := eDcv[1] + tDr * rDpv[1] + tDs * sDpv[1]; eDcv[2] := eDcv[2] + tDr * rDpv[2] + tDs * sDpv[2] END END AddGradientToVertex; BEGIN AddGradientToVertex(un, rDpu, sDpu); AddGradientToVertex(vn, rDpv, sDpv); FOR k := 0 TO LAST(wn) DO AddGradientToVertex(wn[k], rDpw[k], sDpw[k]) END END Distribute_tDr_tDs; BEGIN Compute_r_s(); Compute_t_from_r_s(); e := e + t; IF grad THEN Distribute_tDr_tDs() END END END END AddTerm; PROCEDURE Name(<*UNUSED*>erg: T) : TEXT = BEGIN RETURN "Winding()" END Name; <*UNUSED*> PROCEDURE PrI(prefix: TEXT; x: INTEGER) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(stderr, " "); Wr.PutText(stderr, prefix); Wr.PutText(stderr, Fmt.Pad(Fmt.Int(x), 12)); END PrI; PROCEDURE PrL(prefix: TEXT; x: LONGREAL) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(stderr, " "); Wr.PutText(stderr, prefix); Wr.PutText(stderr, Fmt.Pad(Fmt.LongReal(x, style := Fmt.Style.Fix, prec := 8), 22) ); END PrL; PROCEDURE PrV(prefix: TEXT; x: LR3.T) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(stderr, " "); Wr.PutText(stderr, prefix); FOR i := 0 TO 2 DO Wr.PutText(stderr, Fmt.Pad(Fmt.LongReal(x[i], style := Fmt.Style.Fix, prec := 8), 21) & " " ) END; END PrV; PROCEDURE PrEOL() = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(stderr, "\n"); END PrEOL; BEGIN END WindingEnergy. (* Last edited on 2001-05-21 02:44:07 by stolfi *) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/Anaglyphs.m3 MODULE Anaglyphs EXPORTS Main; IMPORT Triangulation, FileWr, ParseParams, OSError, Process, Wr, Thread, Stdio, Tridimensional, R3, Text, LR4, LR4Extras; FROM Triangulation IMPORT Topology, OrgV, Pair, TetraNegPosVertices; FROM Stdio IMPORT stderr; FROM Tridimensional IMPORT Coord3D; FROM Octf IMPORT Enext, Enext_1; FROM Pov IMPORT WritePOVCylinder, WritePOVSphere, WritePOVTriangle, WritePOVSquare, WritePOVTriangleTex; TYPE Quad = RECORD u, v, w, x: CARDINAL END; Options = RECORD inFileTp: TEXT; inFileSt3: TEXT; outFile: TEXT; wire : BOOLEAN; all: BOOLEAN; texture: BOOLEAN; silhouette: BOOLEAN;(* TRUE draws the silhouette faces *) opacity: REAL; (* faces; Transparent (opacity=1) Opaque (opacity=0)*) END; PROCEDURE Sign(d: LONGREAL) : BOOLEAN = (* Return TRUE iff the longreal value is positive, FALSE c.c. *) BEGIN <* ASSERT d # 0.0d0 *> IF d < 0.0d0 THEN RETURN FALSE ELSE RETURN TRUE END; END Sign; PROCEDURE DoIt() = BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToTaMa(o.inFileTp), rc3 = Tridimensional.ReadState3D(o.inFileSt3), top = tc.top, c3 = rc3^, color1 = "RED", color2 = "CYAN" DO WritePOVFile(top, c3, o, color1); WritePOVFile(top, c3, o, color2); END END DoIt; PROCEDURE WritePOVFile( READONLY top: Topology; READONLY c3: Tridimensional.Coord3D; READONLY o: Options; color : TEXT; ) = <* FATAL Wr.Failure, Thread.Alerted, OSError.E *> BEGIN WITH wr = FileWr.Open(o.outFile & color & ".inc") DO Wr.PutText(wr, "// Include File: <" & o.outFile & ".inc>\n"); WritePOV(wr, top, c3, o, color); Wr.Close(wr) END END WritePOVFile; PROCEDURE WritePOV( wr: Wr.T; READONLY top: Topology; READONLY c3: Coord3D; READONLY o: Options; color : TEXT; ) = <* FATAL Wr.Failure, Thread.Alerted *> PROCEDURE FindOriR3(q: Quad) : LONGREAL = (* For each tetrahedron with extremus vertices numbers u,v,w,x computes its orientation in R^{3} through the 4x4 determinant: _ _ | c3[q.u][0] c3[q.u][1] c3[q.u][2] 1.0d0 | B = | c3[q.v][0] c3[q.v][1] c3[q.v][2] 1.0d0 | | c3[q.w][0] c3[q.w][1] c3[q.w][2] 1.0d0 | | c3[q.x][0] c3[q.x][1] c3[q.x][2] 1.0d0 | - - *) BEGIN WITH a = LR4.T{c3[q.u][0], c3[q.u][1], c3[q.u][2], 1.0d0}, b = LR4.T{c3[q.v][0], c3[q.v][1], c3[q.v][2], 1.0d0}, c = LR4.T{c3[q.w][0], c3[q.w][1], c3[q.w][2], 1.0d0}, d = LR4.T{c3[q.x][0], c3[q.x][1], c3[q.x][2], 1.0d0} DO RETURN LR4Extras.Det(a,b,c,d); END END FindOriR3; PROCEDURE SilhouetteFaces(a: Pair) : BOOLEAN = (* Return TRUE iff the face associated to the pair "a" is a silhouette face, FALSE c.c. *) BEGIN WITH t = TetraNegPosVertices(a), un = t[0].num, vn = t[1].num, wn = t[2].num, xn = t[3].num, yn = t[4].num, t1 = Quad{un,vn,wn,xn}, t2 = Quad{un,vn,wn,yn}, d1 = FindOriR3(t1), d2 = FindOriR3(t2) DO IF (Sign(d1) AND Sign(d2)) OR ((NOT Sign(d1)) AND (NOT Sign(d2))) THEN RETURN TRUE ELSE RETURN FALSE END END END SilhouetteFaces; VAR cor: R3.T; BEGIN (* Drawing edges *) IF Text.Equal(color,"RED") THEN cor := R3.T{1.0,0.0,0.0}; ELSE cor := R3.T{0.0,1.0,1.0} END; IF NOT (o.wire AND o.all) THEN FOR i := 0 TO top.NE-1 DO WITH e = top.edge[i] DO IF e.exists OR o.all THEN WITH o = e.vertex[0].num, d = e.vertex[1].num, t3 = e.transp, transp = (t3[0] + t3[1] + t3[2]) / 3.0 DO WritePOVCylinder(wr,c3[o],c3[d],e.radius,cor,transp); END END END END END; IF (o.wire AND o.all) THEN FOR i := 0 TO top.NE-1 DO WITH e = top.edge[i], o = e.vertex[0].num, d = e.vertex[1].num, t = e.transp, transp = (t[0] + t[1] + t[2]) / 3.0 DO IF e.exists THEN WritePOVCylinder(wr,c3[o],c3[d],e.radius,cor,transp); ELSE WritePOVCylinder(wr,c3[o],c3[d],(e.radius)*0.75,cor,transp); END END END END; (* Drawing vertices *) FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i] DO IF (v.exists AND v.radius > 0.0) OR o.all THEN WITH t3 = v.transp, transp = (t3[0] + t3[1] + t3[2]) / 3.0 DO IF v.exists THEN WritePOVSphere(wr,c3[i],v.radius,cor,transp); ELSE WritePOVSphere(wr,c3[i],v.radius*0.75,cor,transp); END END END END END; IF NOT o.wire THEN (* drawing faces *) FOR i := 0 TO top.NF-1 DO WITH f = top.face[i] DO IF f.exists OR o.all THEN IF top.der = 3 THEN WITH a = f.pa, an = OrgV(a).num, bn = OrgV(Enext(a)).num, cn = OrgV(Enext(Enext(a))).num, t3 = f.transp, transp = (t3[0] + t3[1] + t3[2]) / 3.0 DO IF NOT o.texture THEN WritePOVTriangle(wr,c3[an],c3[bn],c3[cn],cor,transp); ELSE WritePOVTriangleTex(wr,c3[an],c3[bn],c3[cn],cor,transp); END END ELSIF top.der = 4 THEN WITH a = f.pa, an = OrgV(a).num, bn = OrgV(Enext(a)).num, cn = OrgV(Enext(Enext(a))).num, dn = OrgV(Enext_1(a)).num, t3 = f.transp, transp = (t3[0] + t3[1] + t3[2]) / 3.0 DO WritePOVSquare(wr,c3[an],c3[bn],c3[cn],c3[dn],cor,transp); END END END END END; IF o.silhouette AND (top.der = 3) THEN FOR i := 0 TO top.NF-1 DO WITH f = top.face[i], a = f.pa, un = OrgV(a).num, vn = OrgV(Enext(a)).num, wn = OrgV(Enext_1(a)).num, t = o.opacity DO IF SilhouetteFaces(a) AND (NOT f.exists) THEN WritePOVTriangle(wr,c3[un], c3[vn], c3[wn],cor,t); END END END END; END; Wr.Flush(wr); END WritePOV; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFileTp"); o.inFileTp := pp.getNext(); pp.getKeyword("-inFileSt3"); o.inFileSt3 := pp.getNext(); IF pp.keywordPresent("-outFile") THEN o.outFile := pp.getNext() ELSE o.outFile := o.inFileTp END; o.wire := pp.keywordPresent("-wire"); o.all := pp.keywordPresent("-all"); o.texture := pp.keywordPresent("-texture"); IF pp.keywordPresent("-silhouette") THEN o.silhouette := TRUE; IF pp.keywordPresent("-opacity") THEN o.opacity := pp.getNextReal(0.0,1.0); ELSE o.opacity := 0.85; END END; pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: Anaglyphs \\\n"); Wr.PutText(stderr," -inFileTp -inFileSt3 \\\n"); Wr.PutText(stderr," [ -outFile ] \\\n"); Wr.PutText(stderr," [ -wire ] [ -all ] [ -texture ] \\\n"); Wr.PutText(stderr," [ -silhouette [ -opacity ] ]\n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt(); END Anaglyphs. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/AngleConse.m3 (* Programa que calcula os angulos diedrais de faces consecutivas incidentes a cada uma das arestas da triangulacao Created by L. P. Lozada *) MODULE AngleConse EXPORTS Main; IMPORT Triangulation, Fmt, Stdio, Wr, Thread, Process, ParseParams, LR4, Stat, Math; FROM Stdio IMPORT stderr, stdout; FROM Triangulation IMPORT FaceBarycenter; CONST Pi = Math.Pi; TYPE Options = RECORD inFile: TEXT; (* Initial guess file name (minus ".top") *) END; Edge = Triangulation.Edge; Face = Triangulation.Face; EndPoint = ARRAY [0..1] OF CARDINAL; DRF = REF ARRAY OF CARDINAL; Tri = RECORD u, v, w: CARDINAL END; PROCEDURE WriteCoord(wr: Wr.T; x: LONGREAL) = <* FATAL Thread.Alerted, Wr.Failure *> BEGIN Wr.PutText(wr, Fmt.Pad(Fmt.LongReal(x, Fmt.Style.Fix, prec := 2), 6) & " "); END WriteCoord; <* UNUSED *> PROCEDURE WritePoint(wr: Wr.T; READONLY c: LR4.T) = <* FATAL Thread.Alerted, Wr.Failure *> BEGIN WriteCoord(wr, c[0]); Wr.PutText(wr, " "); WriteCoord(wr, c[1]); Wr.PutText(wr, " "); WriteCoord(wr, c[2]); Wr.PutText(wr, " "); WriteCoord(wr, c[3]); Wr.PutText(wr, " "); END WritePoint; <* UNUSED *> PROCEDURE ExtremusFace(READONLY f: Face) : Tri = BEGIN WITH fun = f.vertex[0].num, fvn = f.vertex[1].num, fwn = f.vertex[2].num, tri = Tri{fun, fvn, fwn} DO RETURN tri; END; END ExtremusFace; PROCEDURE ExtremusEdge(READONLY e: Edge) : EndPoint = VAR stack : ARRAY [0..1] OF CARDINAL; BEGIN WITH eun = e.vertex[0].num, evn = e.vertex[1].num DO stack[0] := eun; stack[1] := evn; RETURN stack; END; END ExtremusEdge; <* UNUSED *> PROCEDURE EdgeCommon(READONLY f1,f2 : Face) : EndPoint = VAR stack : ARRAY [0..1] OF CARDINAL; n : CARDINAL := 0; BEGIN FOR j := 0 TO 2 DO FOR i := 0 TO 2 DO WITH f1j = f1.vertex[j].num, f2i = f2.vertex[i].num DO IF f1j = f2i THEN stack[n] := f1j; INC(n); END; END; END; END; RETURN stack END EdgeCommon; PROCEDURE DoIt() = <* FATAL Thread.Alerted, Wr.Failure *> VAR sta: Stat.T; drf : DRF; n : CARDINAL; BEGIN Stat.Init(sta); WITH o = GetOptions(), tc = Triangulation.Read(o.inFile), top = tc.top, c = tc.c^ DO PROCEDURE ComputeDegreeRingFacets() : DRF = VAR drf := NEW(REF ARRAY OF CARDINAL, top.NE); BEGIN FOR l := 0 TO top.NE-1 DO WITH e = top.edge[l], fie = CollectFaces(e) DO drf^[l] := NUMBER(fie^); END; END; RETURN drf; END ComputeDegreeRingFacets; <* UNUSED *> PROCEDURE CollectIncidentFaces(READONLY e: Edge): REF ARRAY OF Tri = VAR NT: CARDINAL := 0; ct : CARDINAL; BEGIN WITH NF = top.NF, t = NEW(REF ARRAY OF Tri, NF)^ DO FOR i := 0 TO NF-1 DO ct := 0; WITH f = top.face[i], fun = f.vertex[0].num, fvn = f.vertex[1].num, fwn = f.vertex[2].num, eun = e.vertex[0].num, evn = e.vertex[1].num DO IF (fun=eun OR fun=evn) THEN INC(ct) END; IF (fvn=eun OR fvn=evn) THEN INC(ct) END; IF (fwn=eun OR fwn=evn) THEN INC(ct) END; IF ct = 2 THEN t[NT] := Tri{fun, fvn, fwn}; INC(NT); END; END; END; WITH r = NEW(REF ARRAY OF Tri, NT) DO r^ := SUBARRAY(t,0,NT); RETURN r; END; END; END CollectIncidentFaces; PROCEDURE CollectFaces(READONLY e: Edge): REF ARRAY OF Face = VAR NT: CARDINAL := 0; ct : CARDINAL; BEGIN WITH NF = top.NF, t = NEW(REF ARRAY OF Face, NF)^ DO FOR i := 0 TO NF-1 DO ct := 0; WITH f = top.face[i], fun = f.vertex[0].num, fvn = f.vertex[1].num, fwn = f.vertex[2].num, eun = e.vertex[0].num, evn = e.vertex[1].num DO IF (fun=eun OR fun=evn) THEN INC(ct) END; IF (fvn=eun OR fvn=evn) THEN INC(ct) END; IF (fwn=eun OR fwn=evn) THEN INC(ct) END; IF ct = 2 THEN t[NT] := f; INC(NT); END; END; END; WITH r = NEW(REF ARRAY OF Face, NT) DO r^ := SUBARRAY(t,0,NT); RETURN r; END; END; END CollectFaces; PROCEDURE ComputeAverageDiedralAngle(READONLY fie: REF ARRAY OF Face; bi : EndPoint; grau: CARDINAL) : LONGREAL = VAR tetham : LONGREAL := 0.0d0; BEGIN WITH fie = fie, de = grau, bi = bi DO FOR i := 0 TO de-1 DO WITH f1 = fie[i], af1 = f1.pa^, f2 = fie[(i+1) MOD de], af2 = f2.pa^, bf1 = FaceBarycenter(af1,c), bf2 = FaceBarycenter(af2,c), tetha = Angle(bf1,bf2,bi) DO tetham := tetham + tetha; END END; tetham := tetham/FLOAT(de, LONGREAL); RETURN tetham; END END ComputeAverageDiedralAngle; PROCEDURE Angle(READONLY bf1,bf2 : LR4.T; e : EndPoint ) : LONGREAL = VAR cos,tethar,tetha : LONGREAL; BEGIN WITH e0 = e[0], e1 = e[1], be = LR4.Scale(1.0d0/2.0d0, LR4.Add(c[e0],c[e1])), a = LR4.Sub(be,bf1), b = LR4.Sub(be,bf2) DO cos := LR4.Cos(a,b); tethar := Math.sqrt( 2.0d0*(1.0d0-cos) ); <* ASSERT (0.0d0 <= tethar) AND (tethar <= FLOAT(Pi,LONGREAL) ) *> tetha := (180.0d0*tethar)/FLOAT(Pi, LONGREAL); RETURN tetha; END; END Angle; VAR tethat, tetham, medio, dif : LONGREAL; diff : REAL; BEGIN drf := NEW(REF ARRAY OF CARDINAL, top.NE); FOR l:= 0 TO top.NE-1 DO WITH e = top.edge[l], fie = CollectFaces(e), bi = ExtremusEdge(e), drf = LAST(fie^)+1 DO medio := ComputeAverageDiedralAngle(fie,bi,drf); (* Wr.PutText(Stdio.stdout, "Aresta[" & Fmt.Int(e.num) & "]: " & " Vertices Extremos: " & Fmt.Int(bi[0]) & "-" & Fmt.Int(bi[1]) & " , "); Wr.PutText(Stdio.stdout,"DegreeRingFacets: " & Fmt.Int(drf) & ", Angulo ideal: " & Fmt.LongReal(360.0d0/FLOAT(drf,LONGREAL)) & "\n"); Wr.PutText(Stdio.stdout, "Faces Incidentes: \n"); *) dif := ABS(medio - 360.0d0/FLOAT(drf,LONGREAL)); diff := FLOAT(dif, REAL); Stat.Accum(sta,diff); (* FOR i := 0 TO LAST(fie^) DO WITH fun = fie^[i].vertex[0].num, fvn = fie^[i].vertex[1].num, fwn = fie^[i].vertex[2].num DO Wr.PutText(Stdio.stdout, Fmt.Int(fun) & " " & Fmt.Int(fvn) & " " & Fmt.Int(fwn) & "\n"); END; END; Wr.PutText(Stdio.stdout, "Angles consecutives: "); tethat := 0.0d0; FOR j := 0 TO drf-1 DO WITH f1 = fie[j], af1 = f1.pa^, f2 = fie[(j+1) MOD drf], af2 = f2.pa^, bf1 = FaceBarycenter(af1,c), bf2 = FaceBarycenter(af2,c), tetha = Angle(bf1,bf2,bi) DO WriteCoord(stdout,tetha); tethat := tethat + tetha; END; END; tetham := tethat/FLOAT(drf, LONGREAL); Wr.PutText(Stdio.stdout, " => Total: " & Fmt.Pad(Fmt.LongReal(tethat, Fmt.Style.Fix, prec := 1), 5) & " "); Wr.PutText(Stdio.stdout, " => Average: " & Fmt.Pad(Fmt.LongReal(tetham, Fmt.Style.Fix, prec := 1), 5) & "\n"); END; Wr.PutText(Stdio.stdout, "\n"); *) END; Wr.PutText(stdout, "\nWeight statistics of diference between ideal and average diedral Angle:\n"); Stat.Print(stdout, sta); Wr.PutText(stdout, "\n"); (* drf := ComputeDegreeRingFacets(); n := ComputeDegreeTotal(drf); Wr.PutText(Stdio.stdout, "Degree Ring Facets Total is : " & Fmt.Int(n) & "\n"); *) END; END; END DoIt; PROCEDURE ComputeDegreeTotal(READONLY drf: DRF) : CARDINAL = VAR n : CARDINAL := 0; BEGIN FOR l := 0 TO LAST(drf^) DO WITH d = drf^[l] DO n := n + d; END; END; RETURN n; END ComputeDegreeTotal; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFile"); o.inFile := pp.getNext(); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: AngleConse" ); Wr.PutText(stderr, " -inFile " ); Wr.PutText(stderr, "\n"); Process.Exit (1); END; END; RETURN o END GetOptions; BEGIN DoIt() END AngleConse. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/AutoDodeIco.m3 MODULE AutoDodeIco EXPORTS Main; (* This program implements the automatic gluing of cells (tetrahedra, triangulated octahedra) for the 4D non-regular polytope: "pentaocta" *) IMPORT Stdio, Wr, Fmt, Thread, Mis, Triangulation, Octf, Process, ParseParams, Text, FileWr, OSError; FROM Triangulation IMPORT Pair, MakeTetraTopo, Glue, OrgV, MakeTopology, Ppos; FROM Stdio IMPORT stderr; FROM Octf IMPORT Spin, Clock, Enext_1, Enext, SpinBit; TYPE Row2I = ARRAY[0..1] OF CARDINAL; Row4I = ARRAY[0..3] OF CARDINAL; Shape = {Dodecahedron, Icosahedron}; Options = RECORD detail: BOOLEAN; free : BOOLEAN; shape : Shape; shapeName: TEXT; END; VAR cell4 : REF ARRAY OF Row4I; tetra : REF ARRAY OF ARRAY [0..3] OF Pair; o : Options; cellnum: CARDINAL; <* UNUSED *> PROCEDURE WriteCells(READONLY g: REF ARRAY OF Row4I) = <* FATAL Wr.Failure, Thread.Alerted, OSError.E *> BEGIN WITH st = FileWr.Open(o.shapeName) DO PROCEDURE WriteVertex(x: CARDINAL) = BEGIN Wr.PutText(st, Fmt.Pad(Fmt.Int(x),7)); END WriteVertex; PROCEDURE WriteCell(READONLY c: Row4I) = BEGIN WriteVertex(c[0]); Wr.PutText(st, " "); WriteVertex(c[1]); Wr.PutText(st, " "); WriteVertex(c[2]); Wr.PutText(st, " "); WriteVertex(c[3]); END WriteCell; BEGIN FOR i := 0 TO LAST(g^) DO WriteVertex(i); WriteCell(g[i]); Wr.PutText(st, "\n"); END; END; Wr.Close(st); END; END WriteCells; PROCEDURE DoIt() = <* FATAL Thread.Alerted, Wr.Failure *> PROCEDURE Gluing(Ti,Tj,Ci,Cj: CARDINAL) : Pair = (* Gluing the tetrahedra Ti with Tj through the free faces Ci and Cj respectively. *) PROCEDURE PrintInfo(case: CARDINAL;oi,oj,di,dj: CARDINAL) = (* Prints information about the three possible cases in the gluing procedure. *) BEGIN Wr.PutText(stderr, "case " & Fmt.Int(case) & ": "); Wr.PutText(stderr, Fmt.Int(oi) & " " & Fmt.Int(di)&"\n"); Wr.PutText(stderr, " "); Wr.PutText(stderr, Fmt.Int(oj) & " " & Fmt.Int(dj)&"\n\n"); END PrintInfo; PROCEDURE UngluedInfo(ci,cj,ti,tj: CARDINAL) = (* Prints information about unglued case in the gluing procedure. This procedure cause the halt of the program. *) BEGIN Wr.PutText(stderr, "Not glue this case " & Fmt.Int(ci) & " " & Fmt.Int(cj) & "\n"); Wr.PutText(stderr, " Tetrahedra " & Fmt.Int(ti) & " " & Fmt.Int(tj) & "\n"); Process.Exit(1); END UngluedInfo; BEGIN IF o.detail THEN Wr.PutText(stderr,"Ci="&Fmt.Int(Ci)&" Cj="&Fmt.Int(Cj)&", "); END; IF (* 1 *) Ci = 0 AND Cj = 0 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1] DO WITH Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,3] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,0] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext_1(tetra[Tj,Cj])); END; END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 2 *) Ci = 0 AND Cj = 1 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1] DO WITH Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,2] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,2], Dj = cell4[Tj,0] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 3 *) Ci = 0 AND Cj = 2 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1] DO WITH Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,0] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,0], Dj = cell4[Tj,2] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 4 *) Ci = 0 AND Cj = 3 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1] DO WITH Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi = Dj) AND (Di = Oj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,1] DO IF (Oi = Dj) AND (Di = Oj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,2] DO IF (Oi = Dj) AND (Di = Oj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END; ELSIF (* 5 *) Ci = 1 AND Cj = 0 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1] DO WITH Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,3] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,0] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END; ELSIF (* 6 *) Ci = 1 AND Cj = 1 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1] DO WITH Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,2] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,2], Dj = cell4[Tj,0] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END; ELSIF (* 7 *) Ci = 1 AND Cj = 2 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1] DO WITH Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,0] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,0], Dj = cell4[Tj,2] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END; ELSIF (* 8 *) Ci = 1 AND Cj = 3 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1] DO WITH Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,1] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,2] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END; ELSIF (* 9 *) Ci = 2 AND Cj = 0 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3] DO WITH Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,3] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,0] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 10 *) Ci = 2 AND Cj = 1 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3] DO WITH Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,2] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,2], Dj = cell4[Tj,0] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 11 *) Ci = 2 AND Cj = 2 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3] DO WITH Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,0] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,0], Dj = cell4[Tj,2] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 12 *) Ci = 2 AND Cj = 3 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3] DO WITH Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,1] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,2] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 13 *) Ci = 3 AND Cj = 0 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3] DO WITH Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,3] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,0] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 14 *) Ci = 3 AND Cj = 1 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3] DO WITH Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,2] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,2], Dj = cell4[Tj,0] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 15 *) Ci = 3 AND Cj = 2 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3] DO WITH Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,0] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,0], Dj = cell4[Tj,2] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 16 *) Ci = 3 AND Cj = 3 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3] DO WITH Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,1] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,2] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END END; RETURN tetra[Ti,0]; END Gluing; PROCEDURE SetCornersTetra(Ti: CARDINAL; row: Row4I) = (* Set the labels "row" in the tetrahedron Ti. *) BEGIN WITH a = OrgV(tetra[Ti,0]), b = OrgV(Clock(tetra[Ti,0])), c = OrgV(Enext_1(tetra[Ti,1])), d = OrgV(Enext_1(tetra[Ti,0])) DO a.num := row[0]; b.num := row[1]; c.num := row[2]; d.num := row[3]; END; END SetCornersTetra; PROCEDURE SetGhostVertex(Ti: CARDINAL; node:CARDINAL) = (* Set one vertex onto the tetrahedra "Ti" as non-existing. *) BEGIN WITH a = OrgV(tetra[Ti,0]), b = OrgV(Clock(tetra[Ti,0])), c = OrgV(Enext_1(tetra[Ti,1])), d = OrgV(Enext_1(tetra[Ti,0])) DO IF a.num = node THEN a.exists := FALSE; END; IF b.num = node THEN b.exists := FALSE; END; IF c.num = node THEN c.exists := FALSE; END; IF d.num = node THEN d.exists := FALSE; END END END SetGhostVertex; PROCEDURE SetGhostEdge(Ti: CARDINAL; node:CARDINAL) = (* Set all edges incidents in the vertex "node" as non-existing.*) BEGIN WITH a = OrgV(tetra[Ti,0]).num, b = OrgV(Clock(tetra[Ti,0])).num, c = OrgV(Enext_1(tetra[Ti,1])).num, d = OrgV(Enext_1(tetra[Ti,0])).num, e0 = tetra[Ti,0].facetedge.edge, e1 = tetra[Ti,2].facetedge.edge, e2 = Enext (tetra[Ti,2]).facetedge.edge, e3 = Enext_1(tetra[Ti,2]).facetedge.edge, e4 = Enext (tetra[Ti,0]).facetedge.edge, e5 = Enext (tetra[Ti,1]).facetedge.edge DO IF a = node OR b = node THEN e0.exists := FALSE; END; IF c = node OR d = node THEN e1.exists := FALSE; END; IF a = node OR d = node THEN e2.exists := FALSE; END; IF a = node OR c = node THEN e3.exists := FALSE; END; IF b = node OR d = node THEN e4.exists := FALSE; END; IF b = node OR c = node THEN e5.exists := FALSE; END; END END SetGhostEdge; PROCEDURE SetGhostFace(Ti: CARDINAL; node: CARDINAL) = (* Set all facese incidents in the vertex "node" as non-existing.*) BEGIN WITH a = OrgV(tetra[Ti,0]).num, b = OrgV(Clock(tetra[Ti,0])).num, c = OrgV(Enext_1(tetra[Ti,1])).num, d = OrgV(Enext_1(tetra[Ti,0])).num, f0 = tetra[Ti,0].facetedge.face, f1 = tetra[Ti,1].facetedge.face, f2 = tetra[Ti,2].facetedge.face, f3 = tetra[Ti,3].facetedge.face DO IF a = node OR b = node OR d = node THEN f0.exists := FALSE; END; IF a = node OR b = node OR c = node THEN f1.exists := FALSE; END; IF a = node OR c = node OR d = node THEN f2.exists := FALSE; END; IF b = node OR c = node OR d = node THEN f3.exists := FALSE; END END END SetGhostFace; PROCEDURE MustBeGlue(Ti,Tj: Pair) : BOOLEAN = (* Return TRUE if the faces "Ti.facetedge.face" and "Tj.facetedge.face" have coherent orientations and must be glued. *) BEGIN WITH a = OrgV(Ti).num, ae = OrgV(Enext(Ti)).num, ae_1 = OrgV(Enext_1(Ti)).num, b = OrgV(Tj).num, be = OrgV(Enext(Tj)).num, be_1 = OrgV(Enext_1(Tj)).num DO IF (a = b AND ae = be AND ae_1 = be_1) OR (a = b AND ae = be_1 AND ae_1 = be) THEN RETURN TRUE END; RETURN FALSE END; END MustBeGlue; PROCEDURE BadAttribution(Ti,Tj: Pair) : BOOLEAN = (* Return TRUE if the faces "Ti.facetedge.face" and "Tj.facetedge.face" have incoherent orientations. *) BEGIN WITH i0 = OrgV(Ti).num, i1 = OrgV(Enext(Ti)).num, i2 = OrgV(Enext_1(Ti)).num, j0 = OrgV(Tj).num, j1 = OrgV(Enext(Tj)).num, j2 = OrgV(Enext_1(Tj)).num DO IF SpinBit(Ti) # SpinBit(Tj) THEN IF (i0 = j0 AND i1 = j2 AND i2 = j1) OR (i0 = j2 AND i1 = j1 AND i2 = j0) OR (i0 = j1 AND i1 = j0 AND i2 = j2) THEN RETURN TRUE END; END; IF SpinBit(Ti) = SpinBit(Tj) THEN IF (i0 = j0 AND i1 = j1 AND i2 = j2) OR (i0 = j2 AND i0 = j0 AND i2 = j1) OR (i0 = j1 AND i1 = j2 AND i2 = j0) THEN RETURN TRUE END; END; RETURN FALSE END; END BadAttribution; PROCEDURE EnextK(Ti: Pair; k : CARDINAL) : Pair = (* Given a pair "Ti", this procedure return Enext^{k}(Ti). *) BEGIN IF k = 0 THEN RETURN Ti ELSIF k = 1 THEN RETURN Enext(Ti) ELSIF k = 2 THEN RETURN Enext(Enext(Ti)) END; RETURN Ti; END EnextK; PROCEDURE PrintCorners(Ti: CARDINAL) = (* Print the corners of the triangular face "Ti". *) BEGIN WITH a = OrgV(faces[Ti]).num, ae = OrgV(Enext(faces[Ti])).num, ae_1 = OrgV(Enext_1(faces[Ti])).num DO Wr.PutText(stderr, Fmt.Pad(Fmt.Int(a),3) & " " & Fmt.Pad(Fmt.Int(ae),3) & " " & Fmt.Pad(Fmt.Int(ae_1),3) & " "); END; END PrintCorners; PROCEDURE PrintFreeCorners(number: CARDINAL) = BEGIN FOR i := 0 TO number-1 DO FOR j := 0 TO 3 DO WITH a = tetra[i,j], d = Octf.DegreeFaceRing(a) DO IF d # 1 AND Ppos(a) = NIL THEN Wr.PutText(stderr, "tetra[" & Fmt.Pad(Fmt.Int(i),2) & "," & Fmt.Pad(Fmt.Int(j),2) & "]\n") END END END END; END PrintFreeCorners; VAR poly : REF ARRAY OF ARRAY [0..7] OF Pair; id : CARDINAL := 0; count : CARDINAL := 1; faces : REF ARRAY OF Pair; glues : REF ARRAY OF Row4I; BEGIN o := GetOptions(); IF o.shape = Shape.Dodecahedron THEN cellnum := 60; cell4 := NEW(REF ARRAY OF Row4I, cellnum); ELSIF o.shape = Shape.Icosahedron THEN cellnum := 20; cell4 := NEW(REF ARRAY OF Row4I, cellnum); END; poly := NEW(REF ARRAY OF ARRAY [0..7] OF Pair,cellnum); tetra := NEW(REF ARRAY OF ARRAY [0..3] OF Pair,cellnum); faces := NEW(REF ARRAY OF Pair, 4*cellnum); glues := NEW(REF ARRAY OF Row4I, 2*cellnum); (* creating topological tetrahedra *) FOR i := 0 TO cellnum-1 DO poly[i] := MakeTetraTopo(1,1); END; (* creating the tetrahedra *) FOR i := 0 TO cellnum-1 DO FOR j := 0 TO 3 DO tetra[i,j] := poly[i,j]; <* ASSERT Ppos(tetra[i,j]) = NIL *> END END; (* cells with corners perfectly assigments *) IF o.shape = Shape.Dodecahedron THEN cell4[ 0]:=Row4I{100,500, 0, 1}; cell4[ 1]:=Row4I{100,500, 1, 4}; cell4[ 2]:=Row4I{100,500, 4, 7}; cell4[ 3]:=Row4I{100,500, 7, 2}; cell4[ 4]:=Row4I{100,500, 2, 0}; cell4[ 5]:=Row4I{500,101, 0, 1}; cell4[ 6]:=Row4I{500,101, 1, 5}; cell4[ 7]:=Row4I{500,101, 5, 8}; cell4[ 8]:=Row4I{500,101, 8, 3}; cell4[ 9]:=Row4I{500,101, 3, 0}; cell4[ 10]:=Row4I{500,102, 2, 0}; cell4[ 11]:=Row4I{500,102, 0, 3}; cell4[ 12]:=Row4I{500,102, 3, 9}; cell4[ 13]:=Row4I{500,102, 9, 6}; cell4[ 14]:=Row4I{500,102, 6, 2}; cell4[ 15]:=Row4I{103,500, 6, 2}; cell4[ 16]:=Row4I{500,103, 7, 2}; cell4[ 17]:=Row4I{103,500, 7, 13}; cell4[ 18]:=Row4I{103,500, 13, 12}; cell4[ 19]:=Row4I{500,103, 6, 12}; cell4[ 20]:=Row4I{500,104, 1, 4}; cell4[ 21]:=Row4I{500,104, 4, 10}; cell4[ 22]:=Row4I{500,104, 10, 11}; cell4[ 23]:=Row4I{500,104, 11, 5}; cell4[ 24]:=Row4I{500,104, 5, 1}; cell4[ 25]:=Row4I{500,105, 9, 3}; cell4[ 26]:=Row4I{500,105, 3, 8}; cell4[ 27]:=Row4I{500,105, 8, 14}; cell4[ 28]:=Row4I{500,105, 14, 15}; cell4[ 29]:=Row4I{500,105, 15, 9}; cell4[ 30]:=Row4I{500,106, 12, 6}; cell4[ 31]:=Row4I{500,106, 6, 9}; cell4[ 32]:=Row4I{500,106, 9, 15}; cell4[ 33]:=Row4I{500,106, 15, 18}; cell4[ 34]:=Row4I{500,106, 18, 12}; cell4[ 35]:=Row4I{500,107, 4, 7}; cell4[ 36]:=Row4I{500,107, 7, 13}; cell4[ 37]:=Row4I{500,107, 13, 16}; cell4[ 38]:=Row4I{500,107, 16, 10}; cell4[ 39]:=Row4I{500,107, 10, 4}; cell4[ 40]:=Row4I{108,500, 5, 8}; cell4[ 41]:=Row4I{108,500, 8, 14}; cell4[ 42]:=Row4I{108,500, 14, 17}; cell4[ 43]:=Row4I{108,500, 17, 11}; cell4[ 44]:=Row4I{108,500, 11, 5}; cell4[ 45]:=Row4I{109,500, 18, 12}; cell4[ 46]:=Row4I{109,500, 12, 13}; cell4[ 47]:=Row4I{109,500, 13, 16}; cell4[ 48]:=Row4I{109,500, 16, 19}; cell4[ 49]:=Row4I{109,500, 19, 18}; cell4[ 50]:=Row4I{500,110, 18, 15}; cell4[ 51]:=Row4I{500,110, 15, 14}; cell4[ 52]:=Row4I{500,110, 14, 17}; cell4[ 53]:=Row4I{500,110, 17, 19}; cell4[ 54]:=Row4I{500,110, 19, 18}; cell4[ 55]:=Row4I{111,500, 10, 11}; cell4[ 56]:=Row4I{111,500, 11, 17}; cell4[ 57]:=Row4I{111,500, 17, 19}; cell4[ 58]:=Row4I{111,500, 19, 16}; cell4[ 59]:=Row4I{111,500, 16, 10}; ELSIF o.shape = Shape.Icosahedron THEN cell4[ 0]:=Row4I{100, 0, 1, 2}; cell4[ 1]:=Row4I{ 0,100, 1, 4}; cell4[ 2]:=Row4I{ 2,100, 0, 3}; cell4[ 3]:=Row4I{100, 4, 0, 5}; cell4[ 4]:=Row4I{100, 3, 2, 8}; cell4[ 5]:=Row4I{ 1,100, 2, 6}; cell4[ 6]:=Row4I{ 5,100, 4, 10}; cell4[ 7]:=Row4I{100, 1, 4, 7}; cell4[ 8]:=Row4I{ 8,100, 3, 9}; cell4[ 9]:=Row4I{100, 0, 3, 5}; cell4[ 10]:=Row4I{100, 6, 1, 7}; cell4[ 11]:=Row4I{100, 10, 5, 9}; cell4[ 12]:=Row4I{100, 9, 8, 11}; cell4[ 13]:=Row4I{ 2,100, 8, 6}; cell4[ 14]:=Row4I{ 7,100, 6, 11}; cell4[ 15]:=Row4I{ 9,100, 10, 11}; cell4[ 16]:=Row4I{100, 4, 10, 7}; cell4[ 17]:=Row4I{100, 3, 9, 5}; cell4[ 18]:=Row4I{100, 11, 7, 10}; cell4[ 19]:=Row4I{ 8,100, 11, 6}; END; (* set the labels for each tetrahedra *) FOR i := 0 TO cellnum-1 DO SetCornersTetra(i,cell4[i]); END; (* set the non-existing vertices,edges and faces.*) IF o.shape = Shape.Dodecahedron THEN FOR i := 0 TO cellnum-1 DO SetGhostVertex(i,500); SetGhostEdge(i,500); SetGhostFace(i,500); FOR j := 100 TO 111 DO SetGhostVertex(i,j); SetGhostEdge(i,j); END END ELSIF o.shape = Shape.Icosahedron THEN FOR i := 0 TO cellnum-1 DO SetGhostVertex(i,100); SetGhostEdge(i,100); SetGhostFace(i,100); END END; (*WriteCells(cell4);*) (* builds the table of faces for choose which tetrahedra must be gluing. *) IF o.detail THEN Wr.PutText(stderr, "C id table face\n"); Wr.PutText(stderr, "-------------------------\n"); END; FOR i := 0 TO cellnum-1 DO IF o.detail THEN Wr.PutText(stderr, Fmt.Int(i) & "\n"); END; FOR k := 0 TO 3 DO faces[(4*i)+k] := tetra[i,k]; IF o.detail THEN Wr.PutText(stderr," "& Fmt.Pad(Fmt.Int(id),4)&" "); INC(id); PrintCorners((4*i)+k); Wr.PutText(stderr, " " & Fmt.Int(k) & "\n"); END END END; (* computing which cells must be gluing. *) FOR k := 0 TO LAST(faces^) DO FOR l := k+1 TO LAST(faces^) DO FOR m := 0 TO 2 DO WITH e = EnextK(faces[l],m) DO IF MustBeGlue(faces[k],e) THEN IF o.detail THEN Wr.PutText(stderr, Fmt.Int(count) & "\n"); Wr.PutText(stderr, "must be gluing: faces[" & Fmt.Int(k) & "] with "); Wr.PutText(stderr, "faces[" & Fmt.Int(l) &"]\n"); END; WITH kc = k MOD 4, kt = k DIV 4, lc = l MOD 4, lt = l DIV 4 DO IF o.detail THEN Wr.PutText(stderr, " tetra["&Fmt.Int(kt) & "," & Fmt.Int(kc) & "] and tetra[" & Fmt.Int(lt) & "," & Fmt.Int(lc) & "]\n\n"); END; glues[count-1] := Row4I{kt,lt,kc,lc}; INC(count); IF BadAttribution(faces[k],e) THEN Wr.PutText(stderr, "Bad Attribution " & " tetra["& Fmt.Int(kt) &"] and tetra[" & Fmt.Int(lt) & "]\n"); END END END END END END END; (* Do the automatic gluing of tetrahedra *) FOR i := 0 TO LAST(glues^) DO WITH c = glues[i] DO IF c # Row4I{0,0,0,0} THEN EVAL Gluing(c[0],c[1],c[2],c[3]); END END END; IF o.free THEN Wr.PutText(stderr,"Listing free corners\n"); PrintFreeCorners(cellnum) END; (* setting the origins. *) FOR i := 0 TO cellnum-1 DO FOR j := 0 TO 3 DO WITH a = tetra[i,j], b = Enext(a), c = Enext_1(a) DO Triangulation.SetAllOrgs(a,OrgV(a)); Triangulation.SetAllOrgs(b,OrgV(b)); Triangulation.SetAllOrgs(c,OrgV(c)); END END END; (* Builds and writes the topology. *) IF o.shape = Shape.Dodecahedron THEN Wr.PutText(stderr, "Building the topology of dodecahedron:\n"); ELSIF o.shape = Shape.Icosahedron THEN Wr.PutText(stderr, "Building the topology of icosahedron:\n"); END; WITH a = tetra[cellnum-1,0], t = MakeTopology(a), c = Triangulation.GenCoords(t)^ DO (* seting the elements root for edges and faces.*) FOR i := 0 TO t.NF-1 DO WITH f = t.face[i] DO f.root := f.num; END END; FOR i := 0 TO t.NE-1 DO WITH e = t.edge[i] DO e.root := e.num; END END; Triangulation.WriteTopology(o.shapeName, t, "Created by AutoDodeIco: " & o.shapeName & ".tp on " & Mis.Today() ); Triangulation.WriteMaterials(o.shapeName, t, "Created by AutoDodeIco: " & o.shapeName & ".ma on " & Mis.Today()); Triangulation.WriteState(o.shapeName, t, c, "Created by AutoDodeIco: " & o.shapeName & ".st on " & Mis.Today() &"\nRandom Geometry"); END END DoIt; <* UNUSED *> PROCEDURE PrintRow4I(m: Row4I) = (* Print an array of four integer values. *) <* FATAL Thread.Alerted, Wr.Failure *> BEGIN Wr.PutText(stderr,Fmt.Int(m[0]) & " " & Fmt.Int(m[1]) & " " & Fmt.Int(m[2]) & " " & Fmt.Int(m[3]) & "\n"); END PrintRow4I; <* UNUSED *> PROCEDURE PrintRow2I(m: Row2I) = (* Print an array of two integer values. *) <* FATAL Thread.Alerted, Wr.Failure *> BEGIN Wr.PutText(stderr,Fmt.Int(m[0]) & " " & Fmt.Int(m[1]) & "\n"); END PrintRow2I; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-shape"); o.shapeName := pp.getNext(); IF Text.Equal(o.shapeName, "icosahedron") THEN o.shape := Shape.Icosahedron ELSIF Text.Equal(o.shapeName, "dodecahedron") THEN o.shape := Shape.Dodecahedron ELSE pp.error("Bad shape \"" & pp.getNext() & "\"\n"); END; o.detail := pp.keywordPresent("-detail"); o.free := pp.keywordPresent("-free"); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: AutoDodeIco \\\n"); Wr.PutText(stderr, " -shape { icosahedron | dodecahedron } \\\n"); Wr.PutText(stderr, " [ -free ] [ -detail ] \n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt() END AutoDodeIco. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/AutoGluing.m3 MODULE AutoGluing EXPORTS Main; (* This program implements the automatic gluing of cells (tetrahedra, triangulated octahedra) for the 4D regular and convex polytopes: 5cell, 16cell and 24cell. *) IMPORT Stdio, Wr, Fmt, Thread, FloatMode, FileRd, Mis, Text, Squared, OSError, Lex, Rd, Process, ParseParams, Triangulation, Octf, FileWr, R3, LR3, LR4; FROM Triangulation IMPORT Coords, Pair, MakeTetraTopo, Glue, OrgV, MakeTopology, Ppos; FROM Stdio IMPORT stderr; FROM Octf IMPORT Spin, Clock, Enext_1, Enext, SpinBit, Fnext_1; FROM Pov IMPORT WritePOVCylinder; TYPE Shape = {cell5, cell16, cell24}; Options = RECORD inFile: TEXT; shape : Shape; shapeName: TEXT; draw : BOOLEAN; detail: BOOLEAN; fixed : BOOLEAN; END; Row2I = ARRAY[0..1] OF CARDINAL; Row4I = ARRAY[0..3] OF CARDINAL; Row6I = ARRAY[0..5] OF CARDINAL; CARDI = CARDINAL; Geom = RECORD DER: CARDINAL; (* Degree Edge Ring *) NV : CARDINAL; (* Number of vertex *) NE : CARDINAL; (* Number of edges *) NF : CARDINAL; (* Number of faces *) c : REF Coords; edge: REF ARRAY OF ARRAY OF CARDINAL; face: REF ARRAY OF ARRAY OF CARDINAL; END; CONST AlphaChars = Mis.AlphaChars; IniStackSize = 700; VAR Stack4 := NEW(REF ARRAY OF Row4I, IniStackSize); (* stack of Row4I.*) Stack6 := NEW(REF ARRAY OF Row6I, IniStackSize); (* stack of Row6I.*) Stack := NEW(REF ARRAY OF CARDI, IniStackSize); (* stack of cardinal.*) cellnum, tpst : CARDINAL := 0; (* tops for the stacks above. *) cell4 := NEW(REF ARRAY OF Row4I, IniStackSize); cell6 := NEW(REF ARRAY OF Row6I, IniStackSize); tetra : REF ARRAY OF ARRAY [0..3] OF Pair; octa : REF ARRAY OF ARRAY [0..7] OF Pair; PROCEDURE ReadWire4(name: TEXT): Geom = <* FATAL Rd.Failure, Thread.Alerted, FloatMode.Trap, Lex.Error, OSError.E *> VAR geom: Geom; comments: TEXT; BEGIN WITH rw = FileRd.Open(name & ".w4") DO comments := Mis.ReadCommentsJS(rw, '#'); (* Element counts: *) Lex.Skip(rw, cs := AlphaChars); geom.DER := Lex.Int(rw); Lex.Skip(rw); comments := Mis.ReadCommentsJS(rw, '#'); Lex.Skip(rw, cs := AlphaChars); geom.NV := Lex.Int(rw); geom.c := NEW(REF Coords, geom.NV); (* Read vertex data coordinates: *) FOR j := 0 TO geom.NV-1 DO Lex.Skip(rw); WITH cv = geom.c[j] DO cv[0] := Lex.LongReal(rw); Lex.Skip(rw); cv[1] := Lex.LongReal(rw); Lex.Skip(rw); cv[2] := Lex.LongReal(rw); Lex.Skip(rw); cv[3] := Lex.LongReal(rw); END END; Lex.Skip(rw, cs := AlphaChars); geom.NE := Lex.Int(rw); Lex.Skip(rw); (* Create edge records *) geom.edge := NEW(REF ARRAY OF ARRAY OF CARDINAL, geom.NE,2); (* Read edge extremus *) FOR j := 0 TO geom.NE-1 DO Lex.Skip(rw); WITH ee = geom.edge[j] DO ee[0] := Lex.Int(rw); Lex.Skip(rw); ee[1] := Lex.Int(rw); END END; Lex.Skip(rw, cs := AlphaChars); geom.NF := Lex.Int(rw); Lex.Skip(rw); (* Create face records *) geom.face := NEW(REF ARRAY OF ARRAY OF CARDINAL, geom.NF,geom.DER); (* Read face extremus *) FOR j := 0 TO geom.NF-1 DO Lex.Skip(rw); WITH ff = geom.face[j] DO FOR k := 0 TO geom.DER-1 DO ff[k] := Lex.Int(rw); Lex.Skip(rw); END END END; Rd.Close(rw); RETURN geom END END ReadWire4; PROCEDURE DoIt() = <* FATAL Thread.Alerted, Wr.Failure *> VAR cells: REF ARRAY OF ARRAY OF ARRAY OF CARDINAL; e1 : REF ARRAY OF INTEGER; BEGIN WITH o = GetOptions(), g = ReadWire4(o.shapeName) DO PROCEDURE ComputeTips(x,y,z,w: CARDINAL) : CARDINAL = VAR p: REF ARRAY OF CARDINAL; k: CARDINAL := 0; BEGIN p := NEW(REF ARRAY OF CARDINAL,3); WITH O = x, D = z DO FOR j := 0 TO g.NF-1 DO WITH f = g.face[j], a = f[0], b = f[1], c = f[2] DO IF (O = a) AND (D = b) THEN p[k] := c; INC(k); ELSIF (O = a) AND (D = c) THEN p[k] := b; INC(k); ELSIF (O = b) AND (D = a) THEN p[k] := c; INC(k); ELSIF (O = b) AND (D = c) THEN p[k] := a; INC(k); ELSIF (O = c) AND (D = a) THEN p[k] := b; INC(k); ELSIF (O = c) AND (D = b) THEN p[k] := a; INC(k); END END END; FOR m := 0 TO 2 DO IF p[m] # w AND p[m] # x THEN IF AreAdjacents(p[m],y) AND AreAdjacents(p[m],z) THEN RETURN p[m] END END END END; RETURN 1000; END ComputeTips; PROCEDURE AreAdjacents(a,b: CARDINAL) : BOOLEAN = (* Decides if exists some edge with tips "a" and "b". *) BEGIN FOR m := 0 TO g.NE-1 DO WITH E = g.edge[m], EO = E[0], ED = E[1] DO IF ( (a = EO) AND (b = ED) ) OR ( (a = ED) AND (b = EO) ) THEN RETURN TRUE END END END; RETURN FALSE; END AreAdjacents; PROCEDURE Gluing(Ti,Tj,Ci,Cj: CARDINAL) : Pair = (* Gluing the tetrahedra Ti with Tj through the free faces Ci and Cj respectively. *) PROCEDURE PrintInfo(case: CARDINAL;oi,oj,di,dj: CARDINAL) = (* Prints information about the three possible cases in the gluing procedure. *) BEGIN Wr.PutText(stderr, "case " & Fmt.Int(case) & ": "); Wr.PutText(stderr, Fmt.Int(oi) & " " & Fmt.Int(di)&"\n"); Wr.PutText(stderr, " "); Wr.PutText(stderr, Fmt.Int(oj) & " " & Fmt.Int(dj)&"\n\n"); END PrintInfo; PROCEDURE UngluedInfo(ci,cj,ti,tj: CARDINAL) = (* Prints information about unglued case in the gluing procedure. This procedure cause the halt of the program. *) BEGIN Wr.PutText(stderr, "Not glue this case " & Fmt.Int(ci) & " " & Fmt.Int(cj) & "\n"); Wr.PutText(stderr, " Tetrahedra " & Fmt.Int(ti) & " " & Fmt.Int(tj) & "\n"); Process.Exit(1); END UngluedInfo; BEGIN IF o.detail THEN Wr.PutText(stderr,"Ci="&Fmt.Int(Ci)&" Cj="&Fmt.Int(Cj)&", "); END; IF (* 1 *) Ci = 0 AND Cj = 0 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1] DO WITH Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,3] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,0] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext_1(tetra[Tj,Cj])); END; END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 2 *) Ci = 0 AND Cj = 1 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1] DO WITH Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,2] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,2], Dj = cell4[Tj,0] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 3 *) Ci = 0 AND Cj = 2 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1] DO WITH Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,0] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,0], Dj = cell4[Tj,2] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 4 *) Ci = 0 AND Cj = 3 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1] DO WITH Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi = Dj) AND (Di = Oj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,1] DO IF (Oi = Dj) AND (Di = Oj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,2] DO IF (Oi = Dj) AND (Di = Oj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END; ELSIF (* 5 *) Ci = 1 AND Cj = 0 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1] DO WITH Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,3] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,0] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END; ELSIF (* 6 *) Ci = 1 AND Cj = 1 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1] DO WITH Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,2] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,2], Dj = cell4[Tj,0] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END; ELSIF (* 7 *) Ci = 1 AND Cj = 2 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1] DO WITH Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,0] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,0], Dj = cell4[Tj,2] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END; ELSIF (* 8 *) Ci = 1 AND Cj = 3 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1] DO WITH Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,1] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,2] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END; ELSIF (* 9 *) Ci = 2 AND Cj = 0 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3] DO WITH Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,3] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,0] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 10 *) Ci = 2 AND Cj = 1 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3] DO WITH Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,2] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,2], Dj = cell4[Tj,0] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 11 *) Ci = 2 AND Cj = 2 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3] DO WITH Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,0] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,0], Dj = cell4[Tj,2] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 12 *) Ci = 2 AND Cj = 3 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3] DO WITH Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,1] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,2] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 13 *) Ci = 3 AND Cj = 0 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3] DO WITH Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,3] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,0] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 14 *) Ci = 3 AND Cj = 1 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3] DO WITH Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,2] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,2], Dj = cell4[Tj,0] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 15 *) Ci = 3 AND Cj = 2 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3] DO WITH Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,0] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,0], Dj = cell4[Tj,2] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 16 *) Ci = 3 AND Cj = 3 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3] DO WITH Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,1] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,2] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END END; RETURN tetra[Ti,0]; END Gluing; PROCEDURE CorretAttribution(peak: REF ARRAY OF CARDINAL) : REF ARRAY OF Row2I = (* atribui de maneira correta os vertices extremos de um tetraedro *) VAR Stack2 : REF ARRAY OF Row2I; (* stack for peaks *) topo : CARDINAL := 0; r : Row2I; Ext : REF ARRAY OF Row2I; guardar: CARDINAL; PROCEDURE Present2(array : Row2I) : BOOLEAN = (* Return TRUE if "array" its on the stack, FALSE c.c. *) VAR nstack1: CARDINAL := topo; e1 : REF ARRAY OF CARDINAL; st : REF ARRAY OF CARDINAL; BEGIN e1 := NEW(REF ARRAY OF CARDINAL,2); st := NEW(REF ARRAY OF CARDINAL,2); FOR i := 0 TO 1 DO e1[i] := array[i]; END; Mis.Sort(1,e1); WHILE nstack1 > 0 DO nstack1 := nstack1 - 1; FOR i := 0 TO 1 DO st[i] := Stack2[nstack1][i]; END; Mis.Sort(1,st); IF st^ = e1^ THEN RETURN TRUE END; END; RETURN FALSE; END Present2; PROCEDURE Save2(array : Row2I) = (* Saves the "array" on the stack "Stack2". *) BEGIN Stack2[topo] := array; topo := topo + 1; END Save2; PROCEDURE Coincide(array : Row2I; chave: CARDINAL) : BOOLEAN = BEGIN WITH b = array[0] DO IF b = chave THEN RETURN TRUE END; RETURN FALSE; END END Coincide; PROCEDURE Candidate(array : Row2I; chave: CARDINAL) : BOOLEAN = (* Decides if the array "array" is a possivel candidate to be consider. This is, if any element of the array is equal to the key "chave" then this procedure return TRUE, FALSE c.c. *) BEGIN WITH b = array[0], c = array[1] DO IF (b = chave) OR (c = chave) THEN RETURN TRUE END; RETURN FALSE; END END Candidate; PROCEDURE Same(a,b: Row2I) : BOOLEAN = (* Decides if the arrays "a" and "b" are the same without consider the order between then. *) BEGIN WITH a0 = a[0], a1 = a[1], b0 = b[0], b1 = b[1] DO IF (a0 = b1 AND a1 = b0) OR (a0 = b0 AND a1 = b1) THEN RETURN TRUE END; RETURN FALSE; END END Same; PROCEDURE Report(chave: CARDINAL; indice: CARDINAL) : Row2I = BEGIN FOR j := 0 TO topo-1 DO IF indice = 1 THEN IF NOT Same(Stack2[j],Ext[0]) THEN WITH r = Stack2[j], a = r[0], b = r[1] DO IF Candidate(r,chave) THEN IF Coincide(r,chave) THEN RETURN Row2I{a,b} END; RETURN Row2I{b,a} END END END ELSIF indice = 2 THEN IF NOT Same(Stack2[j],Ext[0]) AND NOT Same(Stack2[j],Ext[1]) THEN WITH r = Stack2[j], a = r[0], b = r[1] DO IF Candidate(r,chave) THEN IF Coincide(r,chave) THEN RETURN Row2I{a,b} END; RETURN Row2I{b,a}; END END END ELSIF indice = 3 THEN IF NOT Same(Stack2[j],Ext[0]) AND NOT Same(Stack2[j],Ext[1]) AND NOT Same(Stack2[j],Ext[2]) THEN WITH r = Stack2[j], a = r[0], b = r[1] DO IF Candidate(r,chave) THEN IF Coincide(r,chave) THEN RETURN Row2I{a,b} END; RETURN Row2I{b,a}; END END END ELSIF indice = 4 THEN IF NOT Same(Stack2[j],Ext[0]) AND NOT Same(Stack2[j],Ext[1]) AND NOT Same(Stack2[j],Ext[2]) AND NOT Same(Stack2[j],Ext[3]) THEN WITH r = Stack2[j], a = r[0], b = r[1] DO IF Candidate(r,chave) THEN IF Coincide(r,chave) THEN RETURN Row2I{a,b} END; RETURN Row2I{b,a}; END END END END END; RETURN Row2I{0,0}; END Report; BEGIN Stack2 := NEW(REF ARRAY OF Row2I, LAST(peak^)+1); Ext := NEW(REF ARRAY OF Row2I, LAST(peak^)+1); FOR i := 0 TO LAST(peak^) DO FOR j := 0 TO LAST(peak^) DO IF i # j AND AreAdjacents(peak[i],peak[j]) THEN r[0] := peak[i]; r[1] := peak[j]; IF NOT Present2(r) THEN Save2(r) END; END END END; (* Correct assigment of labels for each cell. *) Ext[0] := Stack2[0]; guardar := Ext[0][1]; FOR i := 1 TO LAST(peak^) DO Ext[i] := Report(guardar,i); guardar := Ext[i][1]; END; RETURN Ext; END CorretAttribution; BEGIN (* allocating space for the cell informations to be compute. *) IF o.shape = Shape.cell5 THEN cells := NEW(REF ARRAY OF ARRAY OF ARRAY OF CARDINAL, g.NE, 3, 4); ELSIF o.shape = Shape.cell16 THEN cells := NEW(REF ARRAY OF ARRAY OF ARRAY OF CARDINAL, g.NE, 4, 4); ELSIF o.shape = Shape.cell24 THEN cells := NEW(REF ARRAY OF ARRAY OF ARRAY OF CARDINAL, g.NE, 3, 6); END; (* computing the cells information *) FOR i := 0 TO g.NE-1 DO VAR p: REF ARRAY OF CARDINAL; (* the tips of each edge "e". *) k,l: CARDINAL := 0; BEGIN IF o.shape = Shape.cell5 THEN p := NEW(REF ARRAY OF CARDINAL,3); ELSIF o.shape = Shape.cell16 THEN p := NEW(REF ARRAY OF CARDINAL,4); ELSIF o.shape = Shape.cell24 THEN p := NEW(REF ARRAY OF CARDINAL,3); END; WITH e = g.edge[i], O = e[0], d = e[1] DO FOR j := 0 TO g.NF-1 DO WITH f = g.face[j], a = f[0], b = f[1], c = f[2] DO IF (O = a) AND (d = b) THEN p[k] := c; INC(k); ELSIF (O = a) AND (d = c) THEN p[k] := b; INC(k); ELSIF (O = b) AND (d = a) THEN p[k] := c; INC(k); ELSIF (O = b) AND (d = c) THEN p[k] := a; INC(k); ELSIF (O = c) AND (d = a) THEN p[k] := b; INC(k); ELSIF (O = c) AND (d = b) THEN p[k] := a; INC(k); END END END; (* creating the cells *) IF o.shape = Shape.cell5 THEN FOR m := 0 TO 2 DO e1 := NEW(REF ARRAY OF INTEGER,4); e1[0] := O; e1[1] := d; e1[2] := p[m]; e1[3] := p[(m+1) MOD 3]; cells[i][m][0] := e1[0]; cells[i][m][1] := e1[1]; cells[i][m][2] := e1[2]; cells[i][m][3] := e1[3]; IF o.detail THEN PrintRow4I(cells[i][l]); END END ELSIF o.shape = Shape.cell16 THEN WITH ext = CorretAttribution(p) DO FOR j := 0 TO 3 DO cells[i][l][0] := O; cells[i][l][1] := d; cells[i][l][2] := ext[j][0]; cells[i][l][3] := ext[j][1]; IF o.detail THEN PrintRow4I(cells[i][l]); END; INC(l); END; END ELSIF o.shape = Shape.cell24 THEN FOR m := 0 TO 2 DO e1 := NEW(REF ARRAY OF INTEGER,4); e1[0] := O; e1[1] := d; e1[2] := p[m]; e1[3] := p[(m+1) MOD 3]; cells[i][m][0] := e1[0]; cells[i][m][1] := e1[1]; cells[i][m][2] := e1[2]; cells[i][m][3] := e1[3]; cells[i][m][4] := ComputeTips(cells[i][m][0],cells[i][m][2], cells[i][m][3],cells[i][m][1]); cells[i][m][5] := ComputeTips(cells[i][m][1],cells[i][m][2], cells[i][m][3],cells[i][m][0]); <* ASSERT NOT AreAdjacents(cells[i][m][2],cells[i][m][3])*> <* ASSERT NOT AreAdjacents(cells[i][m][4],cells[i][m][1])*> <* ASSERT NOT AreAdjacents(cells[i][m][5],cells[i][m][0])*> <* ASSERT AreAdjacents(cells[i][m][4],cells[i][m][5])*> END END END END END; IF o.shape = Shape.cell5 THEN FOR i := 0 TO g.NE-1 DO FOR j := 0 TO 2 DO IF NOT Present4(cells[i][j]) THEN Save4(cells[i][j]); END END END; ELSIF o.shape = Shape.cell16 THEN FOR i := 0 TO g.NE-1 DO FOR j := 0 TO 3 DO IF NOT Present4(cells[i][j]) THEN Save4(cells[i][j]) END END END; ELSIF o.shape = Shape.cell24 THEN FOR i := 0 TO g.NE-1 DO FOR j := 0 TO 2 DO IF NOT Present6(cells[i][j]) THEN Save6(cells[i][j]); END END END END; IF o.shape = Shape.cell5 OR o.shape = Shape.cell16 THEN FOR i := 0 TO cellnum-1 DO FOR j := 0 TO 3 DO cell4[i][j] := Stack4[i][j]; END END; ELSIF o.shape = Shape.cell24 THEN FOR i := 0 TO cellnum-1 DO FOR j := 0 TO 5 DO cell6[i][j] := Stack6[i][j]; END END END; IF o.detail THEN Wr.PutText(stderr, o.shapeName & "\n"); Wr.PutText(stderr, "cells " & Fmt.Int(cellnum) & "\n"); FOR i := 0 TO cellnum-1 DO Wr.PutText(stderr, Fmt.Pad(Fmt.Int(i),3) & ": "); IF o.shape = Shape.cell5 OR o.shape = Shape.cell16 THEN FOR j := 0 TO 3 DO Wr.PutText(stderr, Fmt.Pad(Fmt.Int(cell4[i][j]), 5) & " "); END; Wr.PutText(stderr, "\n"); ELSIF o.shape = Shape.cell24 THEN FOR j := 0 TO 5 DO Wr.PutText(stderr, Fmt.Pad(Fmt.Int(cell6[i][j]), 5) & " "); END; Wr.PutText(stderr, "\n"); END END END; PROCEDURE SetCornersTetra(Ti: CARDINAL; row: Row4I) = (* Set the labels "row" in the tetrahedron Ti. *) BEGIN WITH a = OrgV(tetra[Ti,0]), b = OrgV(Clock(tetra[Ti,0])), c = OrgV(Enext_1(tetra[Ti,1])), d = OrgV(Enext_1(tetra[Ti,0])) DO a.num := row[0]; b.num := row[1]; c.num := row[2]; d.num := row[3]; END; END SetCornersTetra; <* UNUSED *> PROCEDURE Same4(a,b: Row4I) : BOOLEAN = (* Decides if the arrays "a" and "b" are the same without consider the order between then. *) BEGIN WITH a0 = a[0], a1 = a[1], a2 = a[2], a3 = a[3], b0 = b[0], b1 = b[1], b2 = b[2], b3 = b[3] DO IF (a0 = b0 AND a1 = b1 AND a2 = b2 AND a3 = b3) THEN RETURN TRUE END; RETURN FALSE; END END Same4; PROCEDURE DrawTetra(Ti: CARDINAL; row: Row4I) = (* Draw the tetrahedron "Ti" with the labels "row". *) <* FATAL OSError.E *> BEGIN WITH File = Fmt.Int(Ti), wr = FileWr.Open("Tetrahedron-" & File & ".inc"), color = R3.T{0.0,0.0,0.0}, transp = 0.0, x = LR3.T{0.0d0,0.0d0,0.0d0}, y = LR3.T{0.0d0,-0.7071d0,-0.7071d0}, z = LR3.T{-0.7071d0,-0.7071d0,0.0d0}, w = LR3.T{-0.7071d0,0.0d0,-0.7071d0} DO Wr.PutText(wr, "// Include File: \n"); WritePOVCylinder(wr,x,y,0.004,color,transp,TRUE); WritePOVCylinder(wr,x,z,0.004,color,transp,TRUE); WritePOVCylinder(wr,x,w,0.004,color,transp,TRUE); WritePOVCylinder(wr,y,z,0.004,color,transp,TRUE); WritePOVCylinder(wr,y,w,0.004,color,transp,TRUE); WritePOVCylinder(wr,z,w,0.004,color,transp,TRUE); Wr.PutText(wr, " text { ttf \"timrom.ttf\" \"" & Fmt.Int(row[0]) & "\""); Wr.PutText(wr, " 0.125, 0\n"); Wr.PutText(wr, " scale 0.085\n"); Wr.PutText(wr, " translate <-0.025,-0.12500,-1.0000>\n"); Wr.PutText(wr, " translate 0.275*x\n"); Wr.PutText(wr, " }\n"); Wr.PutText(wr, " text { ttf \"timrom.ttf\" \"" & Fmt.Int(row[1]) & "\""); Wr.PutText(wr, " 0.125, 0\n"); Wr.PutText(wr, " scale 0.125\n"); Wr.PutText(wr, " translate 0*x\n"); Wr.PutText(wr, " translate <-0.550000,-0.0000,-1.0000>\n"); Wr.PutText(wr, " }\n"); Wr.PutText(wr, " text { ttf \"timrom.ttf\" \"" & Fmt.Int(row[3]) & "\""); Wr.PutText(wr, " 0.125, 0\n"); Wr.PutText(wr, " scale 0.085\n"); Wr.PutText(wr, " translate 0*x\n"); Wr.PutText(wr, " translate <0.1350000,-0.6500,-1.0000>\n"); Wr.PutText(wr, " }\n"); Wr.PutText(wr, " text { ttf \"timrom.ttf\" \"" & Fmt.Int(row[2]) & "\""); Wr.PutText(wr, " 0.125, 0\n"); Wr.PutText(wr, " scale 0.095\n"); Wr.PutText(wr, " translate 0*x\n"); Wr.PutText(wr, " translate <-0.2750000,-0.5000,-1.0000>\n"); Wr.PutText(wr, " }\n"); Wr.PutText(wr, " text { ttf \"timrom.ttf\" \"" & Fmt.Int(Ti) & "\""); Wr.PutText(wr, " 0.125, 0\n"); Wr.PutText(wr, " scale 0.1\n"); Wr.PutText(wr, " translate 0*x\n"); Wr.PutText(wr, " translate <-0.1250000,-0.25000,-1.0000>\n"); Wr.PutText(wr, " }\n"); Wr.Close(wr); END END DrawTetra; PROCEDURE DrawOcta(Oi: CARDINAL; row: Row6I) = (* Draw the octahedron "Oi" with the labels "row". *) <* FATAL OSError.E *> BEGIN WITH File = Fmt.Int(Oi), wr = FileWr.Open("Octahedron-" & File & ".inc"), color = R3.T{0.0,0.0,0.0}, transp = 0.0, x = LR3.T{-0.4367d0, 0.3938d0, 0.8087d0}, y = LR3.T{ 0.6782d0, 0.7325d0, 0.0134d0}, z = LR3.T{-0.5818d0, 0.5558d0,-0.5931d0}, w = LR3.T{ 0.5882d0,-0.5574d0, 0.5852d0}, r = LR3.T{-0.6862d0,-0.7250d0,-0.0091d0}, s = LR3.T{ 0.4383d0,-0.3997d0,-0.8051d0} DO Wr.PutText(wr, "// Include File: \n"); WritePOVCylinder(wr,x,y,0.008,color,transp,TRUE); WritePOVCylinder(wr,x,z,0.008,color,transp,TRUE); WritePOVCylinder(wr,y,z,0.008,color,transp,TRUE); WritePOVCylinder(wr,x,w,0.008,color,transp,TRUE); WritePOVCylinder(wr,y,w,0.008,color,transp,TRUE); WritePOVCylinder(wr,r,z,0.008,color,transp,TRUE); WritePOVCylinder(wr,x,r,0.008,color,transp,TRUE); WritePOVCylinder(wr,r,w,0.008,color,transp,TRUE); WritePOVCylinder(wr,s,r,0.008,color,transp,TRUE); WritePOVCylinder(wr,z,s,0.008,color,transp,TRUE); WritePOVCylinder(wr,s,y,0.008,color,transp,TRUE); WritePOVCylinder(wr,w,s,0.008,color,transp,TRUE); Wr.PutText(wr, " text { ttf \"timrom.ttf\" \"" & Fmt.Int(row[0]) & "\""); Wr.PutText(wr, " 0.125, 0\n"); Wr.PutText(wr, " scale 0.1\n"); Wr.PutText(wr, " translate 0*x\n"); Wr.PutText(wr, " translate <-0.4367,0.3938,0.8087>\n"); Wr.PutText(wr, " }\n"); Wr.PutText(wr, " text { ttf \"timrom.ttf\" \"" & Fmt.Int(row[1]) & "\""); Wr.PutText(wr, " 0.125, 0\n"); Wr.PutText(wr, " scale 0.1\n"); Wr.PutText(wr, " translate 0*x\n"); Wr.PutText(wr, " translate <0.6782,0.7325,0.0134>\n"); Wr.PutText(wr, " }\n"); Wr.PutText(wr, " text { ttf \"timrom.ttf\" \"" & Fmt.Int(row[3]) & "\""); Wr.PutText(wr, " 0.125, 0\n"); Wr.PutText(wr, " scale 0.1\n"); Wr.PutText(wr, " translate 0*x\n"); Wr.PutText(wr, " translate <-0.5818,0.5558,-0.5931>\n"); Wr.PutText(wr, " }\n"); Wr.PutText(wr, " text { ttf \"timrom.ttf\" \"" & Fmt.Int(row[2]) & "\""); Wr.PutText(wr, " 0.125, 0\n"); Wr.PutText(wr, " scale 0.1\n"); Wr.PutText(wr, " translate 0*x\n"); Wr.PutText(wr, " translate <-0.6862,-0.7250,-0.0091>\n"); Wr.PutText(wr, " }\n"); Wr.PutText(wr, " text { ttf \"timrom.ttf\" \"" & Fmt.Int(row[4]) & "\""); Wr.PutText(wr, " 0.125, 0\n"); Wr.PutText(wr, " scale 0.1\n"); Wr.PutText(wr, " translate 0*x\n"); Wr.PutText(wr, " translate <0.5882,-0.5574,0.5852>\n"); Wr.PutText(wr, " }\n"); Wr.PutText(wr, " text { ttf \"timrom.ttf\" \"" & Fmt.Int(row[5]) & "\""); Wr.PutText(wr, " 0.125, 0\n"); Wr.PutText(wr, " scale 0.1\n"); Wr.PutText(wr, " translate 0*x\n"); Wr.PutText(wr, " translate <-0.2750000,-0.5000,-1.0000>\n"); Wr.PutText(wr, " }\n"); Wr.PutText(wr, " text { ttf \"timrom.ttf\" \"" & Fmt.Int(Oi) & "\""); Wr.PutText(wr, " 0.125, 0\n"); Wr.PutText(wr, " scale 0.1\n"); Wr.PutText(wr, " translate 0*x\n"); Wr.PutText(wr, " translate <0.4383,-0.3997,-0.8051>\n"); Wr.PutText(wr, " }\n"); Wr.Close(wr); END END DrawOcta; PROCEDURE SetCornersOcta(Oi: CARDINAL; row: Row6I) = (* Set the labels "row" in the octahedron Oi. *) BEGIN WITH a = OrgV(octa[Oi,0]), b = OrgV(octa[Oi,7]), c = OrgV(Enext_1(octa[Oi,7])), d = OrgV(Enext_1(octa[Oi,0])), e = OrgV(octa[Oi,1]), f = OrgV(Clock(octa[Oi,1])) DO a.num := row[0]; b.num := row[1]; c.num := row[2]; d.num := row[3]; e.num := row[4]; f.num := row[5]; END; END SetCornersOcta; PROCEDURE MustBeGlue(Ti,Tj: Pair) : BOOLEAN = (* Return TRUE if the faces "Ti.facetedge.face" and "Tj.facetedge.face" have coherent orientations and must be glued. *) BEGIN WITH a = OrgV(Ti).num, ae = OrgV(Enext(Ti)).num, ae_1 = OrgV(Enext_1(Ti)).num, b = OrgV(Tj).num, be = OrgV(Enext(Tj)).num, be_1 = OrgV(Enext_1(Tj)).num DO IF (a = b AND ae = be AND ae_1 = be_1) OR (a = b AND ae = be_1 AND ae_1 = be) THEN RETURN TRUE END; RETURN FALSE END; END MustBeGlue; PROCEDURE BadAttribution(Ti,Tj: Pair) : BOOLEAN = (* Return TRUE if the faces "Ti.facetedge.face" and "Tj.facetedge.face" have incoherent orientations. *) BEGIN WITH i0 = OrgV(Ti).num, i1 = OrgV(Enext(Ti)).num, i2 = OrgV(Enext_1(Ti)).num, j0 = OrgV(Tj).num, j1 = OrgV(Enext(Tj)).num, j2 = OrgV(Enext_1(Tj)).num DO IF SpinBit(Ti) # SpinBit(Tj) THEN IF (i0 = j0 AND i1 = j2 AND i2 = j1) OR (i0 = j2 AND i1 = j1 AND i2 = j0) OR (i0 = j1 AND i1 = j0 AND i2 = j2) THEN RETURN TRUE END END; IF SpinBit(Ti) = SpinBit(Tj) THEN IF (i0 = j0 AND i1 = j1 AND i2 = j2) OR (i0 = j2 AND i0 = j0 AND i2 = j1) OR (i0 = j1 AND i1 = j2 AND i2 = j0) THEN RETURN TRUE END END; RETURN FALSE END; END BadAttribution; PROCEDURE EnextK(Ti: Pair; k : CARDINAL) : Pair = (* Given a pair "Ti", this procedure return Enext^{k}(Ti). *) BEGIN IF k = 0 THEN RETURN Ti ELSIF k = 1 THEN RETURN Enext(Ti) ELSIF k = 2 THEN RETURN Enext(Enext(Ti)) END; RETURN Ti; END EnextK; PROCEDURE PrintCorners(Ti: CARDINAL) = (* Print the corners of the triangular face "Ti". *) BEGIN WITH a = OrgV(faces[Ti]).num, ae = OrgV(Enext(faces[Ti])).num, ae_1 = OrgV(Enext_1(faces[Ti])).num DO Wr.PutText(stderr, Fmt.Pad(Fmt.Int(a),3) & " " & Fmt.Pad(Fmt.Int(ae),3) & " " & Fmt.Pad(Fmt.Int(ae_1),3) & " "); END; END PrintCorners; VAR poly : REF ARRAY OF ARRAY [0..7] OF Pair; id : CARDINAL := 0; count : CARDINAL := 1; faces : REF ARRAY OF Pair; glues : REF ARRAY OF Row4I; c := NEW(REF Triangulation.Coords, 48); PROCEDURE SetCoorOcta(Oi: CARDINAL; row: Row6I) = (* Set the coord "row" in the octahedron Oi. *) PROCEDURE SetCoords(e: Pair; cv: LR4.T) = (* set the origin vertex od the pair "e" with "cv". *) BEGIN c[OrgV(e).num] := cv; END SetCoords; PROCEDURE BaryOcta( ): LR4.T = (* Return the barycenter of the octahedron.*) VAR b: LR4.T := LR4.T{0.0d0, ..}; BEGIN FOR i := 0 TO 5 DO b := LR4.Add(b, g.c[row[i]]); END; RETURN LR4.Scale(1.0d0/6.0d0, b) END BaryOcta; BEGIN SetCoords(octa[Oi,0], g.c[row[0]]); SetCoords(octa[Oi,7], g.c[row[1]]); SetCoords(Enext_1(octa[Oi,7]),g.c[row[2]]); SetCoords(Enext_1(octa[Oi,0]),g.c[row[3]]); SetCoords(octa[Oi,1], g.c[row[4]]); SetCoords(Clock(octa[Oi,1]), g.c[row[5]]); SetCoords(Enext_1(Fnext_1(octa[Oi,4])), BaryOcta()); Mis.WritePoint(stderr, BaryOcta()); Wr.PutText(stderr,"\n"); END SetCoorOcta; BEGIN poly := NEW(REF ARRAY OF ARRAY [0..7] OF Pair,cellnum); tetra := NEW(REF ARRAY OF ARRAY [0..3] OF Pair,cellnum); octa := NEW(REF ARRAY OF ARRAY [0..7] OF Pair,cellnum); IF o.shape = Shape.cell5 OR o.shape = Shape.cell16 THEN faces := NEW(REF ARRAY OF Pair, 4*cellnum); glues := NEW(REF ARRAY OF Row4I, 2*cellnum); (* creating topological tetrahedra *) FOR i := 0 TO cellnum-1 DO poly[i] := MakeTetraTopo(1,1); END; (* creating the tetrahedra *) FOR i := 0 TO cellnum-1 DO FOR j := 0 TO 3 DO tetra[i,j] := poly[i,j]; <* ASSERT Ppos(tetra[i,j]) = NIL *> END END; ELSIF o.shape = Shape.cell24 THEN faces := NEW(REF ARRAY OF Pair, 8*cellnum); glues := NEW(REF ARRAY OF Row4I, 4*cellnum); (* creating the octahedra *) FOR i := 0 TO cellnum-1 DO FOR j := 0 TO 7 DO octa[i] := Squared.MakeOctahedronTriang(TRUE); <* ASSERT Ppos(octa[i,j]) = NIL *> END END END; (* cells with corners perfectly assigments *) IF o.shape = Shape.cell5 THEN cell4[0] := Row4I{2,3,4,1}; cell4[1] := Row4I{2,3,1,0}; cell4[2] := Row4I{2,3,0,4}; cell4[3] := Row4I{3,4,1,0}; cell4[4] := Row4I{4,2,1,0}; ELSIF o.shape = Shape.cell16 THEN cell4[0] := Row4I{5,6,7,4}; cell4[1] := Row4I{5,6,4,3}; cell4[2] := Row4I{5,6,3,0}; cell4[3] := Row4I{5,6,0,7}; cell4[4] := Row4I{6,7,4,1}; cell4[5] := Row4I{6,7,1,0}; cell4[6] := Row4I{7,5,4,2}; cell4[7] := Row4I{7,5,2,0}; cell4[8] := Row4I{4,6,1,3}; cell4[9] := Row4I{7,4,1,2}; cell4[10] := Row4I{4,5,3,2}; cell4[11] := Row4I{0,6,3,1}; cell4[12] := Row4I{7,0,2,1}; cell4[13] := Row4I{0,5,2,3}; cell4[14] := Row4I{1,4,3,2}; cell4[15] := Row4I{0,1,3,2}; ELSIF o.shape = Shape.cell24 THEN cell6[0] := Row6I{ 0, 8, 9,10,11, 1}; cell6[1] := Row6I{ 0, 8,10,12,14, 3}; cell6[2] := Row6I{ 0, 8,12, 9,13, 2}; cell6[3] := Row6I{ 8, 9, 1, 2,16,17}; cell6[4] := Row6I{ 9, 0,11,13, 7,15}; cell6[5] := Row6I{10, 8, 1, 3,18,16}; cell6[6] := Row6I{ 0,10,11,14,15, 6}; cell6[7] := Row6I{ 1, 9,11,17,19, 7}; cell6[8] := Row6I{10, 1,11,18, 6,19}; cell6[9] := Row6I{ 8,12, 2, 3,16,20}; cell6[10] := Row6I{12, 0,13,14, 5,15}; cell6[11] := Row6I{ 9, 2,13,17, 7,21}; cell6[12] := Row6I{ 2,12,13,20,21, 5}; cell6[13] := Row6I{ 3,10,14,18,22, 6}; cell6[14] := Row6I{12, 3,14,20, 5,22}; cell6[15] := Row6I{ 1,16,17,18,19, 4}; cell6[16] := Row6I{16, 2,17,20, 4,21}; cell6[17] := Row6I{ 3,16,18,20,22, 4}; cell6[18] := Row6I{14,15, 5, 6,22,23}; cell6[19] := Row6I{15,13, 5, 7,23,21}; cell6[20] := Row6I{11,15, 6, 7,19,23}; cell6[21] := Row6I{18,19, 6, 4,22,23}; cell6[22] := Row6I{17, 7,19,21, 4,23}; cell6[23] := Row6I{ 5,23,21,22,20, 4}; END; IF o.draw THEN IF o.shape = Shape.cell5 OR o.shape = Shape.cell16 THEN FOR i := 0 TO cellnum-1 DO Wr.PutText(stderr, "Drawing tetrahedron :" & Fmt.Int(i) & "\n"); DrawTetra(i,cell4[i]); END ELSIF o.shape = Shape.cell24 THEN FOR i := 0 TO cellnum-1 DO Wr.PutText(stderr,"Drawing octahedron :"&Fmt.Int(i) & "\n"); DrawOcta(i,cell6[i]); END END END; IF o.shape = Shape.cell5 OR o.shape = Shape.cell16 THEN (* set the labels for each tetrahedra *) FOR i := 0 TO cellnum-1 DO SetCornersTetra(i,cell4[i]); END; ELSIF o.shape = Shape.cell24 THEN (* set the labels for each octahedra *) FOR i := 0 TO cellnum-1 DO SetCornersOcta(i,cell6[i]); END; IF o.fixed THEN FOR i := 0 TO cellnum-1 DO SetCoorOcta(i,cell6[i]); END END END; (* builds the table of faces for choose which tetrahedra must be gluing. *) IF o.detail THEN Wr.PutText(stderr, "C id table face\n"); Wr.PutText(stderr, "-------------------------\n"); END; FOR i := 0 TO cellnum-1 DO IF o.detail THEN Wr.PutText(stderr, Fmt.Int(i) & "\n"); END; IF o.shape = Shape.cell5 OR o.shape = Shape.cell16 THEN FOR k := 0 TO 3 DO faces[(4*i)+k] := tetra[i,k]; IF o.detail THEN Wr.PutText(stderr," "& Fmt.Pad(Fmt.Int(id),4)&" "); INC(id); PrintCorners((4*i)+k); Wr.PutText(stderr, " " & Fmt.Int(k) & "\n"); END END; ELSIF o.shape = Shape.cell24 THEN FOR k := 0 TO 7 DO faces[(8*i)+k] := octa[i,k]; IF o.detail THEN Wr.PutText(stderr," "&Fmt.Pad(Fmt.Int(id),4)& " "); INC(id); PrintCorners((8*i)+k); Wr.PutText(stderr, " " & Fmt.Int(k) & "\n"); END END END END; (* computing which cells must be gluing. *) FOR k := 0 TO LAST(faces^) DO FOR l := k+1 TO LAST(faces^) DO FOR m := 0 TO 2 DO WITH e = EnextK(faces[l],m) DO IF MustBeGlue(faces[k],e) THEN IF o.detail THEN Wr.PutText(stderr, Fmt.Int(count) & "\n"); Wr.PutText(stderr, "must be gluing: faces[" & Fmt.Int(k) & "] with "); Wr.PutText(stderr, "faces[" & Fmt.Int(l) &"]\n"); END; IF o.shape = Shape.cell5 OR o.shape = Shape.cell16 THEN WITH kc = k MOD 4, kt = k DIV 4, lc = l MOD 4, lt = l DIV 4 DO IF o.detail THEN Wr.PutText(stderr, " tetra["&Fmt.Int(kt) & "," & Fmt.Int(kc) & "] and tetra[" & Fmt.Int(lt) & "," & Fmt.Int(lc) & "]\n\n"); END; glues[count-1] := Row4I{kt,lt,kc,lc}; INC(count); IF BadAttribution(faces[k],e) THEN Wr.PutText(stderr, "Bad Attribution " & " tetra["& Fmt.Int(kt) &"and tetra[" & Fmt.Int(lt) & "]\n"); END; END; ELSIF o.shape = Shape.cell24 THEN WITH kc = k MOD 8, kt = k DIV 8, lc = l MOD 8, lt = l DIV 8 DO IF o.detail THEN Wr.PutText(stderr, " octa["&Fmt.Int(kt) & "," & Fmt.Int(kc) & "] and octa[" & Fmt.Int(lt) & "," & Fmt.Int(lc) & "]\n\n"); END; glues[count-1] := Row4I{kt,lt,kc,lc}; END; INC(count); END END END END END END; IF o.shape = Shape.cell5 OR o.shape = Shape.cell16 THEN (* Do the automatic gluing of tetrahedra *) FOR i := 0 TO 2*cellnum-1 DO WITH c = glues[i] DO EVAL Gluing(c[0],c[1],c[2],c[3]); END END ELSIF o.shape = Shape.cell24 THEN (* Gluing the triangulated octahedra. *) (* 1-5 *) EVAL Glue(Spin(Enext_1(octa[0,0])), octa[6,7], 1); EVAL Glue(Spin(Enext(octa[0,1])), octa[8,7], 1); EVAL Glue(Spin(Enext(octa[0,2])), octa[5,7], 1); EVAL Glue(Spin(octa[0,3]), octa[1,7], 1); EVAL Glue(Clock(Enext_1(octa[0,4])), octa[4,7], 1); (* 6-10 *) EVAL Glue(Clock(Enext(octa[0,5])), octa[7,7], 1); EVAL Glue(Clock(Enext(octa[0,6])), octa[3,7], 1); EVAL Glue(Spin(octa[0,7]), octa[2,3], 1); EVAL Glue(Clock(Enext_1(octa[1,0])), octa[10,3],1); EVAL Glue(Spin(Enext(octa[1,1])), octa[14,7],1); (* 10-15 *) EVAL Glue(Clock(Enext(octa[1,2])), octa[9,3], 1); EVAL Glue(Spin(octa[1,3]), octa[2,7], 1); EVAL Glue(Spin(Enext_1(octa[1,4])), octa[6,3], 1); EVAL Glue(Clock(Enext(octa[1,5])), octa[13,7],1); EVAL Glue(Spin(Enext(octa[1,6])), octa[5,3], 1); (* 16-20 *) EVAL Glue(Clock(Enext_1(octa[2,0])), octa[4,3], 1); EVAL Glue(Spin(Enext(octa[2,1])), octa[11,7],1); EVAL Glue(Clock(Enext(octa[2,2])), octa[3,3], 1); EVAL Glue(Clock(Enext_1(octa[2,4])), octa[10,7],1); EVAL Glue(Clock(Enext(octa[2,5])), octa[12,7],1); (* 21- 25 *) EVAL Glue(Clock(Enext(octa[2,6])), octa[9,7], 1); EVAL Glue(Spin(octa[3,0]), octa[9,4], 1); EVAL Glue(Spin(Enext_1(octa[3,1])), octa[16,7],1); EVAL Glue(Clock(Enext(octa[3,2])), octa[11,3],1); EVAL Glue(Clock(octa[3,4]), octa[5,6], 1); (* 26-30 *) EVAL Glue(Clock(Enext_1(octa[3,5])), octa[15,7],1); EVAL Glue(Spin(Enext(octa[3,6])), octa[7,3], 1); EVAL Glue(Spin(octa[4,0]), octa[11,4],1); EVAL Glue(Clock(Enext(octa[4,1])), octa[19,3],1); EVAL Glue(Spin(octa[4,2]), octa[10,6],1); (* 31-35 *) EVAL Glue(Clock(octa[4,4]), octa[7,6], 1); EVAL Glue(Spin(Enext(octa[4,5])), octa[20,3],1); EVAL Glue(Clock(octa[4,6]), octa[6,4], 1); EVAL Glue(Clock(Enext_1(octa[5,0])), octa[13,3],1); EVAL Glue(Spin(Enext(octa[5,1])), octa[17,7],1); (* 36-39 *) EVAL Glue(Clock(octa[5,2]), octa[9,0], 1); EVAL Glue(Spin(Enext_1(octa[5,4])), octa[8,3], 1); EVAL Glue(Spin(Enext(octa[5,5])), octa[15,3],1); EVAL Glue(Clock(octa[6,0]), octa[10,2],1); (* 40-44 *) EVAL Glue(Clock(Enext_1(octa[6,1])), octa[18,3],1); EVAL Glue(Spin(octa[6,2]), octa[13,6],1); EVAL Glue(Clock(Enext_1(octa[6,5])), octa[20,7],1); EVAL Glue(Clock(octa[6,6]), octa[8,4], 1); EVAL Glue(Spin(octa[7,0]), octa[15,4],1); (* 45-50 *) EVAL Glue(Spin(Enext(octa[7,1])), octa[22,7],1); EVAL Glue(Clock(octa[7,2]), octa[11,0],1); EVAL Glue(Clock(octa[7,4]), octa[8,6], 1); EVAL Glue(Spin(Enext_1(octa[7,5])), octa[20,0],1); EVAL Glue(Clock(octa[8,0]), octa[13,2],1); (* 50-54 *) EVAL Glue(Spin(Enext(octa[8,1])), octa[21,7],1); EVAL Glue(Clock(octa[8,2]), octa[15,0],1); EVAL Glue(Clock(Enext(octa[8,5])), octa[20,4],1); EVAL Glue(Clock(Enext_1(octa[9,1])), octa[17,3],1); EVAL Glue(Clock(Enext(octa[9,2])), octa[14,3],1); (* 55-60 *) EVAL Glue(Spin(Enext_1(octa[9,5])), octa[16,3],1); EVAL Glue(Spin(Enext(octa[9,6])), octa[12,3],1); EVAL Glue(Spin(octa[10,0]), octa[14,4],1); EVAL Glue(Spin(Enext(octa[10,1])), octa[18,7],1); EVAL Glue(Clock(octa[10,4]), octa[12,6],1); EVAL Glue(Clock(Enext(octa[10,5])), octa[19,7],1); (* 61-65 *) EVAL Glue(Clock(Enext_1(octa[11,1])),octa[22,3],1); EVAL Glue(Spin(octa[11,2]), octa[16,6],1); EVAL Glue(Spin(Enext(octa[11,5])), octa[19,2],1); EVAL Glue(Clock(octa[11,6]), octa[12,4],1); EVAL Glue(Clock(octa[12,0]), octa[16,2],1); (* 66-71 *) EVAL Glue(Spin(Enext(octa[12,1])), octa[23,4],1); EVAL Glue(Clock(octa[12,2]), octa[14,0],1); EVAL Glue(Clock(Enext_1(octa[12,5])),octa[19,6],1); EVAL Glue(Spin(octa[13,0]), octa[17,4],1); EVAL Glue(Spin(Enext_1(octa[13,1])), octa[21,4],1); EVAL Glue(Clock(octa[13,4]), octa[14,6],1); (* 72-77 *) EVAL Glue(Spin(Enext_1(octa[13,5])), octa[18,0],1); EVAL Glue(Clock(Enext_1(octa[14,1])),octa[23,0],1); EVAL Glue(Clock(octa[14,2]), octa[17,0],1); EVAL Glue(Clock(Enext(octa[14,5])), octa[18,4],1); EVAL Glue(Clock(Enext_1(octa[15,1])),octa[21,3],1); EVAL Glue(Spin(octa[15,2]), octa[17,6],1); (* 78-82 *) EVAL Glue(Clock(Enext(octa[15,5])), octa[22,4],1); EVAL Glue(Clock(octa[15,6]), octa[16,4],1); EVAL Glue(Clock(octa[16,0]), octa[17,2],1); EVAL Glue(Spin(Enext_1(octa[16,1])), octa[23,5],1); EVAL Glue(Spin(Enext_1(octa[16,5])), octa[22,0],1); (* 83-88 *) EVAL Glue(Clock(Enext(octa[17,1])), octa[23,1],1); EVAL Glue(Spin(Enext_1(octa[17,5])), octa[21,0],1); EVAL Glue(Spin(octa[18,1]), octa[21,5],1); EVAL Glue(Spin(octa[18,2]), octa[20,6],1); EVAL Glue(Spin(Enext(octa[18,5])), octa[23,3],1); EVAL Glue(Clock(octa[18,6]), octa[19,4],1); (* 89-93 *) EVAL Glue(Clock(octa[19,0]), octa[20,2],1); EVAL Glue(Clock(Enext_1(octa[19,1])),octa[22,2],1); EVAL Glue(Clock(Enext_1(octa[19,5])),octa[23,7],1); EVAL Glue(Spin(Enext(octa[20,1])), octa[22,6],1); EVAL Glue(Clock(octa[20,5]), octa[21,6],1); (* 94-96 *) EVAL Glue(Clock(Enext(octa[21,1])), octa[23,2],1); EVAL Glue(Spin(Enext_1(octa[21,2])), octa[22,5],1); EVAL Glue(Spin(octa[22,1]), octa[23,6],1); END; (* Builds and writes the topology. *) Wr.PutText(stderr, "Building the topology of " & o.shapeName & ":\n"); IF o.shape = Shape.cell5 OR o.shape = Shape.cell16 THEN WITH a = tetra[1,1], t = MakeTopology(a,0), c = Triangulation.GenCoords(t)^ DO (* seting the elements root for edges and faces.*) FOR i := 0 TO t.NF-1 DO WITH f = t.face[i] DO f.root := f.num; END END; FOR i := 0 TO t.NE-1 DO WITH e = t.edge[i] DO e.root := e.num; END END; Triangulation.WriteTopology(o.shapeName, t, "Created by AutoGluing: " & o.shapeName & ".tp on " & Mis.Today() ); Triangulation.WriteTable(o.shapeName, t, "Created by AutoGluing: " & o.shapeName & ".tb on " & Mis.Today() ); Triangulation.WriteMaterials(o.shapeName, t, "Created by AutoGluing: " & o.shapeName& ".ma on " & Mis.Today()); Triangulation.WriteState(o.shapeName, t, c, "Created by AutoGluing: " & o.shapeName & ".st on " & Mis.Today() &"\nRandom Geometry"); END ELSIF o.shape = Shape.cell24 THEN WITH a = octa[21,1], t = MakeTopology(a,0), ca = Triangulation.GenCoords(t)^ DO (* seting the elements root for edges and faces.*) FOR i := 0 TO t.NF-1 DO WITH f = t.face[i] DO f.root := f.num; f.exists := TRUE; END END; FOR i := 0 TO t.NE-1 DO WITH e = t.edge[i] DO e.root := e.num; e.exists := TRUE; END END; Triangulation.WriteTopology(o.shapeName, t, "Created by AutoGluing: " & o.shapeName & ".tp on " & Mis.Today() ); Triangulation.WriteMaterials(o.shapeName, t, "Created by AutoGluing: " & o.shapeName& ".ma on " & Mis.Today()); IF NOT o.fixed THEN Triangulation.WriteState(o.shapeName, t, ca, "Created by AutoGluing: " & o.shapeName & ".st on " & Mis.Today() &"\nRandom Geometry"); ELSIF o.fixed THEN Triangulation.WriteState(o.shapeName, t, c^, "Created by AutoGluing: " & o.shapeName & ".st on " & Mis.Today() &"\nFixed Geometry"); END END END END END END END DoIt; (* Procedures for stacking *) PROCEDURE Present4(array : Row4I) : BOOLEAN = (* Return TRUE if "array" its on the stack, FALSE c.c. *) VAR nstack: CARDINAL := cellnum; e1 : REF ARRAY OF CARDINAL; st : REF ARRAY OF CARDINAL; BEGIN e1 := NEW(REF ARRAY OF CARDINAL,4); st := NEW(REF ARRAY OF CARDINAL,4); FOR i := 0 TO 3 DO e1[i] := array[i]; END; Mis.Sort(3,e1); WHILE nstack > 0 DO nstack := nstack - 1; FOR i := 0 TO 3 DO st[i] := Stack4[nstack][i]; END; Mis.Sort(3,st); IF st^ = e1^ THEN RETURN TRUE END; END; RETURN FALSE; END Present4; PROCEDURE Save4(VAR array : Row4I) = (* Saves the array "array" on the stack "Stack4". *) BEGIN Stack4[cellnum] := array; cellnum := cellnum + 1; END Save4; PROCEDURE Present6(array : Row6I) : BOOLEAN = (* Return TRUE if "array" its on the stack "Stack6", FALSE c.c. *) VAR nstack: CARDINAL := cellnum; e1 : REF ARRAY OF CARDINAL; st : REF ARRAY OF CARDINAL; BEGIN e1 := NEW(REF ARRAY OF CARDINAL,6); st := NEW(REF ARRAY OF CARDINAL,6); FOR i := 0 TO 5 DO e1[i] := array[i]; END; Mis.Sort(5,e1); WHILE nstack > 0 DO nstack := nstack - 1; FOR i := 0 TO 5 DO st[i] := Stack6[nstack][i]; END; Mis.Sort(5,st); IF st^ = e1^ THEN RETURN TRUE END; END; RETURN FALSE; END Present6; PROCEDURE Save6(VAR array : Row6I) = (* Saves the array "array" on the stack "Stack6". *) BEGIN Stack6[cellnum] := array; cellnum := cellnum + 1; END Save6; <* UNUSED *> PROCEDURE Present(card : CARDI) : BOOLEAN = (* Return TRUE if "card" its on the stack "STACK", FALSE c.c. *) VAR nstack: CARDINAL := tpst; BEGIN WHILE nstack > 0 DO nstack := nstack-1; IF Stack[nstack] = card THEN RETURN TRUE END; END; RETURN FALSE; END Present; <* UNUSED *> PROCEDURE Save(card : CARDI) = (* Saves the cardinal value "card" on the stack "Stack". *) BEGIN Stack[tpst] := card; tpst := tpst + 1; END Save; (* Procedures for printing *) PROCEDURE PrintRow4I(m: Row4I) = (* Print an array of four integer values. *) <* FATAL Thread.Alerted, Wr.Failure *> BEGIN Wr.PutText(stderr,Fmt.Int(m[0]) & " " & Fmt.Int(m[1]) & " " & Fmt.Int(m[2]) & " " & Fmt.Int(m[3]) & "\n"); END PrintRow4I; <* UNUSED *> PROCEDURE PrintRow6I(m: Row6I) = (* Print an array of six integer values. *) <* FATAL Thread.Alerted, Wr.Failure *> BEGIN Wr.PutText(stderr,Fmt.Int(m[0]) & " " & Fmt.Int(m[1]) & " " & Fmt.Int(m[2]) & " " & Fmt.Int(m[3]) & " " & Fmt.Int(m[4]) & " " & Fmt.Int(m[5]) & "\n"); END PrintRow6I; <* UNUSED *> PROCEDURE PrintRow2I(m: Row2I) = (* Print an array of two integer values. *) <* FATAL Thread.Alerted, Wr.Failure *> BEGIN Wr.PutText(stderr,Fmt.Int(m[0]) & " " & Fmt.Int(m[1]) & "\n"); END PrintRow2I; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-shape"); o.shapeName := pp.getNext(); IF Text.Equal(o.shapeName, "5cell") THEN o.shape := Shape.cell5 ELSIF Text.Equal(o.shapeName, "16cell") THEN o.shape := Shape.cell16 ELSIF Text.Equal(o.shapeName, "24cell") THEN o.shape := Shape.cell24 ELSE pp.error("Bad shape \"" & pp.getNext() & "\"\n"); END; o.draw := pp.keywordPresent("-draw"); o.detail := pp.keywordPresent("-detail"); o.fixed := pp.keywordPresent("-fixed"); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: AutoGluing \\\n"); Wr.PutText(stderr, " -shape { 5cell | 16cell | 24cell }\\\n"); Wr.PutText(stderr, " [ -draw ] [ -detail ] [ -fixed ]\n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt() END AutoGluing. (**************************************************************************) (* *) (* Copyright (C) 2001 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/BarySubdivision.m3 MODULE BarySubdivision EXPORTS Main; (* This program builds the "barycentric subdivision" of one topology (".tp" file) of any given 3D map (without boundary or with boundary). In the case of maps with boundary, this program only considers 3D maps with Degree Ring Face (top.drf) equal to two. So, the compute of a second bary- center subdivision for this case isn't contemplating. See the copyright and authorship futher down. Added the option "net" for simulate textures on existing faces with thin cylinders and small spheres. *) IMPORT Triangulation, Stdio, Wr, Thread, Process, ParseParams, Octf, Bary, R3, Text, Mis, LR4; FROM Stdio IMPORT stderr; FROM Triangulation IMPORT Pair, Org, MakeTopology, PposP, PnegP, OrgV, Vertex, Edge, Face, Pneg, Ppos; FROM Octf IMPORT Fnext, Srot, Clock, Enext, Fnext_1, Enext_1, Spin, Tors; FROM Bary IMPORT Corner, CCorner, SetCorner; CONST order = 2; mid = 1; TYPE Options = RECORD inFile : TEXT; (* Initial guess file name (minus ".tp") *) outFile : TEXT; (* Output file name prefix *) fixed : BOOLEAN; (* Retains the previous geometry *) net : BOOLEAN; (* Implements the net faces *) END; PROCEDURE DoIt() = <* FATAL Wr.Failure, Thread.Alerted *> VAR ps : REF ARRAY OF Pair; nvv,nve,nvf,nvp: CARDINAL:=0; (* number of vertex of types "VV","VE","VF"*) (* and "VP" in the new topology. *) BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToMa(o.inFile), top = tc.top, rc = Triangulation.ReadState(o.inFile), c = rc^, NFE = top.NFE, vlt = "VP", vlf = "VF" DO ps := NEW(REF ARRAY OF Pair, NFE); Wr.PutText(stderr, "Subdividing from: " & o.inFile & ".tp\n"); FOR i := 0 TO NFE-1 DO WITH aposp = PposP(top.facetedge[i]), apneg = PnegP(top.facetedge[i]) DO IF (aposp # NIL) AND (apneg #NIL) THEN (* Make one Topological tetrahedron of 2x2 order, for each facetedge in the topology and set the atributes "ca" for each original facetedge. *) ps[i] := Bary.MakeFacetEdge(order,order); WITH fes = NARROW(ps[i].facetedge, Bary.FacetEdge), fet = top.facetedge[i].facetedge, fn = fet.face.num, en = fet.edge.num, on = OrgV(top.facetedge[i]), dn = OrgV(Clock(top.facetedge[i])), ovr = on.radius, ovc = on.color, ovt = on.transp, ovl = on.label, ove = on.exists, dvr = dn.radius, dvc = dn.color, dvt = dn.transp, dvl = dn.label, dve = dn.exists, era = top.edge[en].radius, eco = top.edge[en].color, eta = top.edge[en].transp, eex = top.edge[en].exists, ero = top.edge[en].root, fco = top.face[fn].color, fta = top.face[fn].transp, fex = top.face[fn].exists, fro = top.face[fn].root DO <* ASSERT Octf.OrientationBit(top.facetedge[i]) = 0 *> fet.ca := fes.ca; SetDual (fet.ca[3],vlt,vlf,FALSE,TRUE); SetPrimal(fet.ca[0],ovr,ovc,ovt,ovl,ove,dvr,dvc, dvt,dvl,dve,era,eco,eta,eex,ero,fco,fta, fex,fro,FALSE,TRUE,o.net); END END END END; IF NOT IsMapWithBorder(top) THEN FOR i := 0 TO NFE-1 DO WITH pa = top.facetedge[i] DO GlueTetra(pa) END END; (* Set the origins for all facetedges in the triangulation *) WITH newtop = MakeTopology(top.facetedge[NFE-1].facetedge.ca[1]), nc = Triangulation.GenCoords(newtop)^, com = "Subdivided from: " & o.inFile & ".tp\n" &"Created by Barycenter Subdivision: "&o.outFile & ".tp on " & Mis.Today() DO FOR i := 0 TO newtop.NV-1 DO WITH v = NARROW(newtop.vertex[i],Vertex), vl = v.label DO IF Text.Equal(vl,"VV") THEN INC(nvv); ELSIF Text.Equal(vl,"VE") THEN INC(nve); ELSIF Text.Equal(vl,"VF") THEN INC(nvf); ELSIF Text.Equal(vl,"VP") THEN INC(nvp); END END END; <* ASSERT newtop.NV = nvv + nve + nvf + nvp *> <* ASSERT newtop.NV = top.NV + top.NE + top.NF + top.NP *> <* ASSERT newtop.NF = 8 * top.NFE *> <* ASSERT newtop.NFE = 24 * top.NFE *> <* ASSERT newtop.NP = 4 * top.NFE *> IF o.net THEN (* we compute the number of existing faces in the previus topology. *) VAR nefp: CARDINAL:= 0; (* existing faces in the previus topology *) neep: CARDINAL:= 0; (* existing edges in the previus topology *) nevp: CARDINAL:= 0; (* existing vert. in the previus topology *) neea: CARDINAL:= 0; (* existing edges in the actual topology *) neva: CARDINAL:= 0; (* existing vert. in the actual topology *) BEGIN FOR i := 0 TO top.NF-1 DO WITH f = top.face[i] DO IF f.exists THEN INC(nefp) END END END; FOR i := 0 TO top.NE-1 DO WITH e = top.edge[i] DO IF e.exists THEN INC(neep) END; END END; FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i] DO IF v.exists THEN INC(nevp) END; END END; FOR i := 0 TO newtop.NE-1 DO WITH e = newtop.edge[i] DO IF e.exists THEN INC(neea) END END END; (*<* ASSERT neea = 2 * top.der * nefp + 2 * neep *>*) FOR i := 0 TO newtop.NV-1 DO WITH v = newtop.vertex[i] DO IF v.exists THEN INC(neva) END END END; (*<* ASSERT neva = nevp + neep + nefp *>*) END END; IF o.fixed THEN (* compute new coordinates for vertices of type "VV" and "VE". *) FOR j := 0 TO top.NFE-1 DO WITH a = top.facetedge[j], ou = OrgV(a).num, ov = OrgV(Clock(a)).num, nu = OrgV(Corner(a)).num, nv = OrgV(Corner(Clock(a))).num, nx = OrgV(Clock(Corner(a))).num DO nc[nu] := c[ou]; nc[nv] := c[ov]; nc[nx] := LR4.Scale(0.5d0, LR4.Add(c[ou], c[ov])); END END; (* compute new coordinates for vertices of type "VF". *) FOR j := 0 TO top.NF-1 DO WITH a = top.face[j].pa, uu = OrgV(Clock(Corner(Srot(a)))), (* type VF *) un = NARROW(uu, Vertex), ul = un.label DO <* ASSERT Text.Equal(ul,"VF") *> nc[un.num] := Triangulation.FaceBarycenter(a,c); END END; (* compute new coordinates for vertices of type "VP". *) FOR j := 0 TO top.NP-1 DO WITH a = top.region[j], p = Triangulation.MakePolyhedronTopology(a), b = Tors(a), uu = OrgV(Corner(Srot(b))), un = NARROW(uu, Vertex) DO VAR ba: LR4.T := LR4.T{0.0d0,0.0d0,0.0d0,0.0d0}; BEGIN FOR k := 0 TO p.NV-1 DO WITH ver = p.vRef[k], num = OrgV(ver).num DO ba := LR4.Add(ba,c[num]); END; END; nc[un.num] := LR4.Scale(1.0d0/FLOAT(p.NV,LONGREAL),ba); END END END END; Triangulation.WriteTopology(o.outFile, newtop, com); IF NOT o.fixed THEN Triangulation.WriteState(o.outFile, newtop, nc, com & "\nRandom Geometry"); ELSE Triangulation.WriteState(o.outFile, newtop, nc, com & "\nFixed Geometry"); END; Triangulation.WriteMaterials(o.outFile, newtop, com); (* unmark all the facetedges *) FOR i := 0 TO NFE-1 DO WITH fet = top.facetedge[i].facetedge DO fet.marks := FALSE; END END END; (***************************************************************** 3D maps with boundary ******************************************************************) ELSIF IsMapWithBorder(top) THEN FOR i := 0 TO NFE-1 DO ps[i] := Bary.MakeFacetEdge(mid,order); WITH fes = NARROW(ps[i].facetedge, Bary.FacetEdge), fet = top.facetedge[i].facetedge DO fet.ca := fes.ca; END END; (* Now, set the attributes for the a topological tetrahedron correspondly to the pair "a", and the tetrahedron correspondly to the adjacent pair "aFnext" *) FOR i := 0 TO NFE-1 DO WITH fet = top.facetedge[i].facetedge, fn = fet.face.num, en = fet.edge.num, on = OrgV(top.facetedge[i]), dn = OrgV(Clock(top.facetedge[i])), ovr = on.radius, ovc = on.color, ovt = on.transp, ovl = on.label, ove = on.exists, dvr = dn.radius, dvc = dn.color, dvt = dn.transp, dvl = dn.label, dve = dn.exists, era = top.edge[en].radius, eco = top.edge[en].color, eta = top.edge[en].transp, eex = top.edge[en].exists, ero = top.edge[en].root, fco = top.face[fn].color, fta = top.face[fn].transp, fex = top.face[fn].exists, fro = top.face[fn].root, pa = top.facetedge[i], paf = Fnext(pa), fef = Fnext(pa).facetedge DO IF NOT fet.marks AND (PposP(pa) = PnegP(paf)) THEN IF PposP(pa) # NIL THEN SetDual (fet.ca[3],vlt,vlf,TRUE,FALSE); SetPrimal(fet.ca[0],ovr,ovc,ovt,ovl,ove,dvr,dvc, dvt,dvl,dve,era,eco,eta,eex,ero,fco,fta, fex,fro,TRUE,FALSE,o.net); fet.marks := TRUE; END END; IF NOT fef.marks THEN SetDual (fet.ca[3],vlt,vlf,TRUE,TRUE); SetPrimal(fet.ca[0],ovr,ovc,ovt,ovl,ove,dvr,dvc, dvt,dvl,dve,era,eco,eta,eex,ero,fco,fta, fex,fro,TRUE,TRUE,o.net); fef.marks := TRUE; END END END; FOR i := 0 TO NFE-1 DO WITH pa = top.facetedge[i] DO GlueTetraBr(pa) END END; WITH newtop = MakeTopology(top.facetedge[NFE-1].facetedge.ca[1]), nc = Triangulation.GenCoords(newtop)^, com = "Subdivided from: " & o.inFile & ".tp\n" &"Created by Barycenter Subdivision: "&o.outFile & ".tp on " & Mis.Today() DO (* checks *) FOR i := 0 TO newtop.NV-1 DO WITH v = NARROW(newtop.vertex[i], Vertex), vl = v.label DO IF Text.Equal(vl,"VV") THEN INC(nvv); ELSIF Text.Equal(vl,"VE") THEN INC(nve); ELSIF Text.Equal(vl,"VF") THEN INC(nvf); ELSIF Text.Equal(vl,"VP") THEN INC(nvp); END END END; <* ASSERT newtop.NV = nvv + nve + nvf + nvp *> <* ASSERT newtop.NV = top.NV + top.NE + top.NF + top.NP *> IF o.fixed THEN FOR j := 0 TO top.NFE-1 DO WITH a = top.facetedge[j], ou = OrgV(a).num, ov = OrgV(Clock(a)).num, nu = OrgV(Corner(a)).num, nv = OrgV(Corner(Clock(a))).num, nx = OrgV(Clock(Corner(a))).num, u = OrgV(Corner(Srot(a))), un = u.num, v = OrgV(Corner(Tors(a))), vn = v.num DO nc[nu] := c[ou]; nc[nv] := c[ov]; nc[nx] := LR4.Scale(0.5d0, LR4.Add(c[ou], c[ov])); WITH u = NARROW(u, Vertex), ul = u.label, v = NARROW(v, Vertex), vl = v.label DO <* ASSERT Text.Equal(ul,"VF") *> nc[un] := Triangulation.FaceBarycenter(a,c); <* ASSERT Text.Equal(vl,"VP") *> nc[vn] := Triangulation.Barycenter(top,c, TRUE); END END END END; Triangulation.WriteTopology(o.outFile, newtop, com); IF NOT o.fixed THEN Triangulation.WriteState(o.outFile, newtop, nc, com & "\nRandom Geometry"); ELSE Triangulation.WriteState(o.outFile, newtop, nc, com & "\nFixed Geometry"); END; Triangulation.WriteMaterials(o.outFile, newtop, com); (* unmark all the facetedges, only for the case (top.bd=1) *) FOR i := 0 TO NFE-1 DO WITH fet = top.facetedge[i].facetedge DO fet.marks := FALSE; END END END END END END DoIt; PROCEDURE GlueTetra(a: Pair) = (* Glues the topological tetrahedra such as the topology. *) BEGIN <* ASSERT a.bits = 0 *> WITH b = Fnext(a), c = Fnext_1(a), d = Enext(a), e = Enext_1(a) DO WITH aa = Corner(a), bb = CCorner(b) DO IF (bb # aa) THEN (* Not yet glued, glue it: *) EVAL Triangulation.Glue(bb, aa, order, TRUE); (* Update Corners to mark this pairs facetedges as glued *) SetCorner(a, bb); SetCorner(Spin(Clock(a)), CCorner(Spin(Clock(b)))); END END; WITH cc = Corner(c), dd = CCorner(a) DO IF (dd # cc) THEN (* Not yet glued, glue it: *) EVAL Triangulation.Glue(dd, cc, order, TRUE); (* Update Corners to mark this pairs facetedges as glued *) SetCorner(c, dd); SetCorner(Spin(Clock(c)), CCorner(Spin(Clock(a)))); END END; WITH ee = Corner(Srot(d)), ff = CCorner(Srot(a)) DO IF (ff # ee) THEN (* Not yet glued, glue it: *) EVAL Triangulation.Glue(ff, ee, order, TRUE); (* Update Corners to mark this pairs facetedges as glued *) SetCorner(Srot(d), ff); SetCorner(Spin(Tors(d)), CCorner(Spin(Tors(a)))); END END; WITH gg = Corner(Srot(a)), hh = CCorner(Srot(e)) DO IF (gg # hh) THEN EVAL Triangulation.Glue(hh, gg, order, TRUE); (* Update Corners to mark this pairs facetedges as glued *) SetCorner(Srot(a), hh); SetCorner(Spin(Tors(a)), CCorner(Spin(Tors(e)))); END END END END GlueTetra; PROCEDURE GlueTetraBr(a: Pair) = (* Glueing the topological tetrahedra such as the topology. *) BEGIN <* ASSERT a.bits = 0 *> WITH e = Enext_1(a), b = Fnext(a) DO WITH gg = Corner(Srot(a)), hh = CCorner(Srot(e)) DO IF (a # e) AND (gg # hh) THEN EVAL Triangulation.Glue(hh, gg, mid, TRUE); (* Update Corners to mark this pairs facetedges as glued *) SetCorner(Srot(a), hh); SetCorner(Spin(Tors(a)), CCorner(Spin(Tors(e)))); END END; WITH aa = Corner(a), bb = CCorner(b) DO IF (a#b) AND (bb # aa) AND (PposP(a) = PnegP(Fnext(a))) THEN IF PnegP(a) # NIL THEN (* Not yet glued, glue it: *) EVAL Triangulation.Glue(bb, aa, order, TRUE); SetCorner(a,bb); SetCorner(Spin(Clock(a)), CCorner(Spin(Clock(b)))); END END END END END GlueTetraBr; PROCEDURE SetPrimal( a: Pair; (* pair hanged on topological tetrahedron 2x2 or 1x2 *) ovr: REAL; (* origen vertex radius *) ovc: R3.T; (* origen vertex color *) ovt: R3.T; (* origen vertex transparency *) ovl: TEXT; (* origen vertex label *) ove: BOOLEAN; dvr: REAL; (* destine vertex radius *) dvc: R3.T; (* destine vertex color *) dvt: R3.T; (* destine vertex transparency *) dvl: TEXT; (* destine vertex label *) dve: BOOLEAN; era: REAL; (* edge radius *) eco: R3.T; (* edge color *) eta: R3.T; (* edge transparency *) eex: BOOLEAN; (* edge exists *) ero: INTEGER; (* edge root *) fco: R3.T; (* face color *) fta: R3.T; (* face transparency *) fex: BOOLEAN; (* face exists *) fro: INTEGER; (* face root *) mid: BOOLEAN; (* TRUE iff the topological tetrahedron is 1x2 *) side: BOOLEAN; (* indicate the side of the topological tetrahedron 1x2 *) net : BOOLEAN; (* simulates a grade with thin cylindres and spheres *) ) = PROCEDURE SetVertex( v: Vertex; e: BOOLEAN; (* exists *) c: R3.T; (* color *) t: R3.T; (* transp *) r: REAL; (* radius *) l: TEXT; (* label *) ) = BEGIN v.exists := e; v.color := c; v.transp := t; v.label := l; v.radius := r; END SetVertex; PROCEDURE SetGhostFace(a: Pair) = BEGIN WITH t = NARROW(a.facetedge.face, Face) DO t.exists := FALSE; END; END SetGhostFace; PROCEDURE NewSetTriangle( b: Pair; e: BOOLEAN; (* exists *) c: R3.T; (* color *) t: R3.T; (* transp *) r: INTEGER; (* root *) ) = BEGIN WITH f = NARROW(b.facetedge.face, Face) DO f.exists := e; f.color := c; f.transp := t; f.root := r; END END NewSetTriangle; PROCEDURE NewSetEdge( b: Pair; e: BOOLEAN; (* exists *) c: R3.T; (* color *) t: R3.T; (* transp *) ra: REAL; (* radius *) ro: INTEGER; (* root *) ) = BEGIN WITH ee = NARROW(b.facetedge.edge, Edge) DO ee.exists := e; ee.color := c; ee.transp := t; ee.radius := ra; ee.root := ro; END END NewSetEdge; BEGIN (* set the origin of the pair ca[0] *) SetVertex(Org(a), ove, ovc, ovt, ovr, ovl); (* set the origin of the pair Clock(ca[0]) *) SetVertex(Org(Clock(a)), eex, eco, eta, era, "VE"); (* set the edge component of the topological tetrahedron *) NewSetEdge(a, eex, eco, eta, era, ero); WITH b = Clock(Enext_1(Fnext(Enext(a)))) DO SetVertex(Org(Clock(b)), dve, dvc, dvt, dvr, dvl); NewSetEdge(b, eex, eco, eta, era, ero); END; IF NOT mid THEN SetGhostFace(a); SetGhostFace(Fnext(a)); NewSetTriangle(Fnext_1(a), fex, fco, fta, fro); WITH b = Clock(Enext_1(Fnext(Enext(a)))) DO SetGhostFace(b); SetGhostFace(Fnext(b)); NewSetTriangle(Fnext_1(b), fex, fco, fta, fro); END; IF net THEN WITH X = Enext_1(Fnext_1(a)).facetedge.edge, Y = Enext (Fnext_1(a)).facetedge.edge, Z = Clock(Enext_1(Fnext(Enext(a)))), W = Enext (Fnext_1(Z)).facetedge.edge, S = OrgV(Enext_1(Fnext_1(a))), co = R3.T{1.00,1.000,0.500}, (* color, transparency and radius *) tp = R3.T{0.00,0.000,0.000}, (* of the thin cylinder and sohere*) ra = 0.0025 DO X.exists := TRUE; Y.exists := TRUE; W.exists := TRUE; S.exists := TRUE; X.color := co; X.radius := ra; X.transp := tp; Y.color := co; Y.radius := ra; Y.transp := tp; W.color := co; W.radius := ra; W.transp := tp; S.color := co; S.radius := ra; S.transp := tp; END END ELSIF mid THEN IF side THEN SetGhostFace(a); NewSetTriangle(Fnext_1(a), fex, fco, fta, fro); WITH b = Clock(Enext_1(Fnext(Enext(a)))) DO SetGhostFace(b); NewSetTriangle(Fnext_1(b), fex, fco, fta, fro); END ELSE SetGhostFace(Fnext_1(a)); NewSetTriangle(a, fex, fco, fta, fro); WITH an = Clock(Enext_1(Fnext_1(Enext(Fnext_1(a))))) DO SetGhostFace(an); NewSetTriangle(Fnext_1(an), fex, fco, fta, fro); END END END END SetPrimal; PROCEDURE SetDual( a: Pair; vlt: TEXT; vlf: TEXT; mid: BOOLEAN; side: BOOLEAN; ) = PROCEDURE SetVertex(v: Vertex; label: TEXT) = BEGIN WITH vv = NARROW(v, Vertex) DO vv.exists := FALSE; vv.label := label; END; END SetVertex; PROCEDURE SetGhostFace(a: Pair) = BEGIN WITH t = NARROW(a.facetedge.face, Face) DO t.exists := FALSE; END; END SetGhostFace; PROCEDURE SetGhostEdge(a: Pair) = BEGIN WITH t = NARROW(a.facetedge.edge, Edge) DO t.exists := FALSE; END; END SetGhostEdge; PROCEDURE SetRowEdge(d: Pair; r: CARDINAL) = VAR dn: Pair := d; BEGIN IF r = 3 THEN FOR j := 0 TO r-1 DO IF j=0 THEN FOR i := 0 TO r-1 DO SetGhostEdge(dn); dn := Enext(dn); END; END; dn := Fnext_1(dn); SetGhostEdge(Enext(dn)); SetGhostEdge(Enext_1(dn)); END; ELSIF r = 2 THEN FOR j := 0 TO r-1 DO IF j=0 THEN FOR i := 0 TO r-1 DO SetGhostEdge(dn); dn := Enext(dn); END; dn := Enext(dn); END; dn := Fnext_1(dn); SetGhostEdge(Enext(dn)); END END; END SetRowEdge; PROCEDURE SetRowTriangle(b: Pair) = BEGIN FOR i := 0 TO 2 DO SetGhostFace(b); b := Fnext_1(b); END; END SetRowTriangle; BEGIN IF mid AND side THEN SetVertex(Org(a), vlf); SetVertex(Org(Clock(a)), vlt); SetRowTriangle(a); SetRowEdge(a,3); ELSIF mid AND (NOT side) THEN SetVertex(Org(a), vlt); SetVertex(Org(Clock(a)), vlf); SetRowTriangle(a); SetRowEdge(a,3); ELSIF NOT mid THEN SetVertex(Org(a), vlt); SetVertex(Org(Clock(a)), vlf); SetRowTriangle(a); SetRowEdge(a,3); WITH an = Enext_1(Fnext(Enext(a))) DO SetVertex(Org(an),vlt); SetRowTriangle(an); SetRowEdge(Clock(an),2); END END END SetDual; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFile"); o.inFile := pp.getNext(); pp.getKeyword("-outFile"); o.outFile := pp.getNext(); o.fixed := pp.keywordPresent("-fixed"); o.net := pp.keywordPresent("-net"); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: BarySubdivision" ); Wr.PutText(stderr, " -inFile -outFile \\\n" ); Wr.PutText(stderr, " [ -fixed ] [ -net ] \n"); Process.Exit (1); END END; RETURN o END GetOptions; PROCEDURE IsMapWithBorder(READONLY top:Triangulation.Topology) : BOOLEAN = BEGIN FOR i := 0 TO top.NFE-1 DO WITH a = top.facetedge[i], n = Pneg(a), p = Ppos(a) DO IF (n=NIL) AND (p=NIL) THEN RETURN TRUE END; END END; RETURN FALSE; END IsMapWithBorder; BEGIN DoIt() END BarySubdivision. (**************************************************************************) (* *) (* Copyright (C) 2001 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/BezierToWire4.m3 MODULE BezierToWire4 EXPORTS Main; (* Writes cubic Bezier curves in the format expected by the "Wire4" - Interactive 4D Wireframe Display Program (".w4"). Last Modification by lozada at 08-03-2000 *) IMPORT ParseParams, Process, Wr, Thread, OSError, FileWr, Mis, LR4, Fmt, LR3, PZGeo4; FROM Stdio IMPORT stderr; FROM PZGeo4 IMPORT CubicBezier; TYPE Row3I = ARRAY [0..2] OF INTEGER; Options = RECORD outFile: TEXT; From4: LR4.T; To4: LR4.T; Up4: LR4.T; Over4: LR4.T; Vangle4: LONGREAL; From3: LR3.T; To3: LR3.T; Up3: LR3.T; Vangle3: LONGREAL; FogDensity : LONGREAL; DepthCueLevels: INTEGER; cp0: LR4.T; cp1: LR4.T; cp2: LR4.T; cp3: LR4.T; END; VAR ne : CARDINAL; vcolor : Row3I := Row3I{100,100,100}; ecolor : Row3I := Row3I{0,255,255}; vradius : REAL := 1.0; eradius : REAL := 1.0; PROCEDURE WriteColor(wr: Wr.T; READONLY c: Row3I) = (* Write colors in RGB mode *) <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Mis.WriteInt(wr,c[0]); Wr.PutText(wr," "); Mis.WriteInt(wr,c[1]); Wr.PutText(wr," "); Mis.WriteInt(wr,c[2]); END WriteColor; PROCEDURE DoIt() = BEGIN WITH o = GetOptions(), comments = "\n Make by SplineToWire4: " & o.outFile & ".w4 on " & Mis.Today() & "\n" DO WriteWire4File(o, comments); END END DoIt; PROCEDURE WriteWire4File(READONLY o: Options; comments: TEXT) = <* FATAL Wr.Failure, Thread.Alerted, OSError.E *> BEGIN WITH w4 = FileWr.Open(o.outFile & ".w4") DO Mis.WriteCommentsJS(w4,comments,'#'); Wr.PutText(w4, "\n"); WriteWire4(o,w4); Wr.Close(w4) END END WriteWire4File; PROCEDURE WriteWire4(READONLY o: Options; w4: Wr.T) = <* FATAL Wr.Failure, Thread.Alerted *> VAR BEGIN PROCEDURE WriteCoord(x: LONGREAL) = BEGIN Wr.PutText(w4, Fmt.Pad(Fmt.LongReal(x, Fmt.Style.Fix, prec := 4), 7)); END WriteCoord; PROCEDURE WritePoint4D(READONLY c: LR4.T) = BEGIN WriteCoord(c[0]); Wr.PutText(w4, " "); WriteCoord(c[1]); Wr.PutText(w4, " "); WriteCoord(c[2]); Wr.PutText(w4, " "); WriteCoord(c[3]); END WritePoint4D; PROCEDURE WritePoint3D(READONLY c: LR3.T) = BEGIN WriteCoord(c[0]); Wr.PutText(w4, " "); WriteCoord(c[1]); Wr.PutText(w4, " "); WriteCoord(c[2]); END WritePoint3D; BEGIN Wr.PutText(w4, "DegreeRingEdges"); Wr.PutText(w4," 0"); Wr.PutText(w4,"\nDepthCueLevels ");Mis.WriteInt(w4,o.DepthCueLevels); Wr.PutText(w4,"\nFogDensity "); Mis.WriteLong(w4, o.FogDensity); Wr.PutText(w4,"\n"); Wr.PutText(w4, "\nFrom4: "); WritePoint4D(o.From4); Wr.PutText(w4, "\nTo4 : "); WritePoint4D(o.To4); Wr.PutText(w4, "\nUp4 : "); WritePoint4D(o.Up4); Wr.PutText(w4, "\nOver4: "); WritePoint4D(o.Over4); Wr.PutText(w4, "\nVangle4: "); Mis.WriteLong(w4, o.Vangle4); Wr.PutText(w4, "\n"); Wr.PutText(w4, "\nFrom3: "); WritePoint3D(o.From3); Wr.PutText(w4, "\nTo3 : "); WritePoint3D(o.To3); Wr.PutText(w4, "\nUp3 : "); WritePoint3D(o.Up3); Wr.PutText(w4, "\nVangle3: "); Mis.WriteLong(w4, o.Vangle3); Wr.PutText(w4, "\n\nVertexList 105 :\n"); FOR i := 0 TO 99 DO WITH t = FLOAT(i,LONGREAL)/99.0d0, P = CubicBezier(t,o.cp0,o.cp1,o.cp2,o.cp3) DO WritePoint4D(P); Wr.PutText(w4, " : "); WriteColor(w4, vcolor); Wr.PutText(w4, " : "); Mis.WriteRadius(w4, vradius); Wr.PutText(w4, "\n"); INC(ne); END END; (* reference axis *) Wr.PutText(w4, " 0 0 0 0 : 255 255 255 : 0\n"); Wr.PutText(w4, " 1 0 0 0 : 255 255 255 : 0\n"); Wr.PutText(w4, " 0 1 0 0 : 255 255 255 : 0\n"); Wr.PutText(w4, " 0 0 1 0 : 255 255 255 : 0\n"); Wr.PutText(w4, " 0 0 0 1 : 255 255 255 : 0\n"); Wr.PutText(w4, "\n"); Wr.PutText(w4, "EdgeList " & Fmt.Int(ne+3) & ":\n"); FOR i := 0 TO ne-1 DO IF i # ne-1 THEN Wr.PutText(w4, Fmt.Pad(Fmt.Int(i), 4) & " " & Fmt.Pad(Fmt.Int(i+1),4) ); Wr.PutText(w4, " : "); (* color *) WriteColor(w4, ecolor); Wr.PutText(w4, " : "); Mis.WriteRadius(w4, eradius); Wr.PutText(w4, "\n"); END END; Wr.PutText(w4, " 100 101 : 125 125 125 : 1\n"); Wr.PutText(w4, " 100 102 : 125 125 125 : 1\n"); Wr.PutText(w4, " 100 103 : 125 125 125 : 1\n"); Wr.PutText(w4, " 100 104 : 125 125 125 : 1\n"); Wr.PutText(w4, "\nFaceList 0\n"); Wr.Close(w4); END END WriteWire4; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-outFile"); o.outFile := pp.getNext(); pp.getKeyword("-cp0"); FOR j := 0 TO 3 DO o.cp0[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; pp.getKeyword("-cp1"); FOR j := 0 TO 3 DO o.cp1[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; pp.getKeyword("-cp2"); FOR j := 0 TO 3 DO o.cp2[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; pp.getKeyword("-cp3"); FOR j := 0 TO 3 DO o.cp3[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; IF pp.keywordPresent("-DepthCueLevels") THEN o.DepthCueLevels := pp.getNextInt(1, 255); ELSE o.DepthCueLevels := 16; END; IF pp.keywordPresent("-FogDensity") THEN o.FogDensity := pp.getNextLongReal(0.0d0, 1.0d0); ELSE o.FogDensity := 0.20d0; END; IF pp.keywordPresent("-From4") THEN FOR j := 0 TO 3 DO o.From4[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.From4 := LR4.T{0.0d0,0.0d0,0.0d0,-5.0d0}; END; IF pp.keywordPresent("-To4") THEN FOR j := 0 TO 3 DO o.To4[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.To4 := LR4.T{0.0d0,0.0d0,0.0d0,0.0d0}; END; IF pp.keywordPresent("-Up4") THEN FOR j := 0 TO 3 DO o.Up4[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.Up4 := LR4.T{0.0d0,1.0d0,0.0d0,0.0d0}; END; IF pp.keywordPresent("-Over4") THEN FOR j := 0 TO 3 DO o.Over4[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.Over4 := LR4.T{0.0d0,0.0d0,1.0d0,0.0d0}; END; IF pp.keywordPresent("-Vangle4") THEN o.Vangle4 := pp.getNextLongReal(1.0d0, 179.0d0); ELSE o.Vangle4 := 45.0d0; END; IF pp.keywordPresent("-From3") THEN FOR j := 0 TO 2 DO o.From3[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.From3 := LR3.T{2.0d0,1.5d0,3.0d0}; END; IF pp.keywordPresent("-To3") THEN FOR j := 0 TO 2 DO o.To3[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.To3 := LR3.T{0.0d0,0.0d0,0.0d0}; END; IF pp.keywordPresent("-Up3") THEN FOR j := 0 TO 2 DO o.Up3[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.Up3 := LR3.T{0.0d0,1.0d0,0.0d0}; END; IF pp.keywordPresent("-Vangle3") THEN o.Vangle3 := pp.getNextLongReal(1.0d0, 179.0d0); ELSE o.Vangle3 := 45.0d0; END; pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: SplineToWire4 \\\n"); Wr.PutText(stderr, " [ -outFile ]\\\n"); Wr.PutText(stderr, " [ -cp0 ] \\\n"); Wr.PutText(stderr, " [ -cp1 ] \\\n"); Wr.PutText(stderr, " [ -cp2 ] \\\n"); Wr.PutText(stderr, " [ -cp3 ] \\\n"); Wr.PutText(stderr, " [ -From4 ] \\\n"); Wr.PutText(stderr, " [ -To4 ] \\\n"); Wr.PutText(stderr, " [ -Up4 ] \\\n"); Wr.PutText(stderr, " [ -Over4 ] \\\n"); Wr.PutText(stderr, " [ -Vangle4 ] \\\n"); Wr.PutText(stderr, " [ -From3 ] \\\n"); Wr.PutText(stderr, " [ -To3 ] \\\n"); Wr.PutText(stderr, " [ -Up3 ] \\\n"); Wr.PutText(stderr, " [ -Vangle3 ] \\\n"); Wr.PutText(stderr, " [ -DepthCueLevels ] \\\n"); Wr.PutText(stderr, " [ -FogDensity ]\n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt(); END BezierToWire4.~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/Build600Cell.m3 MODULE Build600Cell EXPORTS Main; (* This program builds the 600-cell regular polytope which has 120 vertices, 720 edges, 1200 faces and 600 tetrahedral cells. The construction basically follows the techniques so called Heegaard Decomposition that consists in the glue of two solid body called: Handlebody of genus 1. In the end we append the full description due to Don Davis that consists in the glue of two solid torus of 150 tetrahedra more a toroidal sheet of 300 tetrahedra acting as a glue layer between them. *) IMPORT ParseParams, Text, Octf, Triangulation, Wr, Stdio, Thread, Process, Mis, Squared, Fmt; FROM Octf IMPORT Spin, Enext, Enext_1, Clock, Fnext, DegreeFaceRing; FROM Triangulation IMPORT MakeTetraTopo, Glue, Pair, Ppos, Pneg; FROM Stdio IMPORT stderr; TYPE Shape = { SolidTorus, HollowTorus, Tube, cell600, RowAtom, Row }; Options = RECORD shape: Shape; shapeName: TEXT; order: CARDINAL; outFile : TEXT; END; PAIR = ARRAY OF Pair; Free = RECORD tetra : REF ARRAY OF PAIR; pyram : REF ARRAY OF PAIR; END; PROCEDURE DoIt() = <* FATAL Thread.Alerted, Wr.Failure *> BEGIN WITH o = GetOptions(), m = MakeShape(o.shape, o.order), t = Triangulation.MakeTopology(m,1), c = Triangulation.GenCoords(t)^ DO (* setting the "root" attribute for faces and edges. *) FOR i := 0 TO t.NF-1 DO WITH f = t.face[i] DO f.root := f.num; END END; FOR i := 0 TO t.NE-1 DO WITH e = t.edge[i] DO e.root := e.num; END END; Triangulation.WriteTopology( o.outFile, t, "Created by Build600cell: " & o.outFile & ".tp on " & Mis.Today() ); Triangulation.WriteState( o.outFile, t, c,"Created by Build600cell: " & o.outFile & ".st on " & Mis.Today() & "\nRandom Geometry" ); Triangulation.WriteMaterials( o.outFile, t,"Created by Build600cell: " & o.outFile & ".ma on " & Mis.Today() ); WITH n = NumberFreeFaces(t) DO Wr.PutText(stderr,"The number or boundary faces is "&Fmt.Int(n)&"\n"); END; (* tests *) FOR i := 0 TO t.NE-1 DO WITH e = t.edge[i].pa DO IF InternalEdge(e) THEN <* ASSERT DegreeFaceRing(e) = 5 *> END END END END END DoIt; PROCEDURE MakeShape(shape: Shape; or: CARDINAL): Pair = BEGIN CASE shape OF | Shape.SolidTorus => WITH a = MakeSolidTorus() DO RETURN a[0] END; | Shape.RowAtom => RETURN MakeRowAtom(or); | Shape.HollowTorus => RETURN MakeHollowTorus().pyram[5][5]; | Shape.Tube => RETURN MakeTube(); | Shape.Row => RETURN MakeRow().tetra[2][3]; | Shape.cell600 => RETURN Makecell600(); END END MakeShape; PROCEDURE NumberFreeFaces(READONLY top: Triangulation.Topology) : CARDINAL = (* Find the number of boundary faces in the topology "top". *) VAR n : CARDINAL := 0; BEGIN FOR i := 0 TO top.NF-1 DO WITH f = top.face[i].pa DO IF (Ppos(f) = NIL AND Pneg(f) # NIL) OR (Pneg(f) = NIL AND Ppos(f) # NIL) THEN INC(n) END; END END; RETURN n; END NumberFreeFaces; PROCEDURE InternalFace(f: Pair) : BOOLEAN = (* Return TRUE if face "a.facetedge.face" is a internal face *) BEGIN IF (Ppos(f) = NIL AND Pneg(f) # NIL) OR (Pneg(f) = NIL AND Ppos(f) # NIL) THEN RETURN FALSE ELSE RETURN TRUE END END InternalFace; PROCEDURE InternalEdge(a: Pair) : BOOLEAN = (* Return TRUE if edge "a.facetedge.edge" is a internal edge *) VAR an : Pair := a; re : BOOLEAN := TRUE; BEGIN REPEAT IF NOT InternalFace(an) THEN re := FALSE; EXIT; END; an := Fnext(an); UNTIL an = a; RETURN re; END InternalEdge; PROCEDURE Makecell600() : Pair = BEGIN WITH h = MakeHollowTorus(), s1 = MakeSolidTorus(), s2 = MakeSolidTorus() DO (* We attach the 100 triangular faces of the solid torus to the 100 triangular faces of the sheet's inner surface. Additionally we need more 30 glues for close the hollowtorus 10 inferior border glues more 20 left side glues. *) (* 1 *) (* RescueOnFace (Spin(Enext (h.pyram[0][6])), s1[0]); *) EVAL Glue (Spin(Enext (h.pyram[0][6])), s1[0], 1); (* RescueOnFace (Spin(Enext (h.pyram[11][6])),s1[1]); *) EVAL Glue (Spin(Enext (h.pyram[11][6])),s1[1], 1); (* RescueOnFace (Spin(Enext (h.pyram[22][6])),s1[2]); *) EVAL Glue (Spin(Enext (h.pyram[22][6])),s1[2], 1); (* RescueOnFace (Spin(Enext (h.pyram[33][6])),s1[3]); *) EVAL Glue (Spin(Enext (h.pyram[33][6])),s1[3], 1); (* RescueOnFace (Spin(Enext (h.pyram[44][6])),s1[4]); *) EVAL Glue (Spin(Enext (h.pyram[44][6])),s1[4], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[10][2])),s1[5]); *) EVAL Glue (Clock(Enext_1(h.pyram[10][2])),s1[5], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[21][2])),s1[6]); *) EVAL Glue (Clock(Enext_1(h.pyram[21][2])),s1[6], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[32][2])),s1[7]); *) EVAL Glue (Clock(Enext_1(h.pyram[32][2])),s1[7], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[43][2])),s1[8]); *) EVAL Glue (Clock(Enext_1(h.pyram[43][2])),s1[8], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[54][2])),s1[9]); *) EVAL Glue (Clock(Enext_1(h.pyram[54][2])),s1[9], 1); (* 2 *) (* RescueOnFace (Spin(Enext (h.pyram[10][6])),s1[10]); *) EVAL Glue (Spin(Enext (h.pyram[10][6])),s1[10], 1); (* RescueOnFace (Spin(Enext (h.pyram[21][6])),s1[11]); *) EVAL Glue (Spin(Enext (h.pyram[21][6])),s1[11], 1); (* RescueOnFace (Spin(Enext (h.pyram[32][6])),s1[12]); *) EVAL Glue (Spin(Enext (h.pyram[32][6])),s1[12], 1); (* RescueOnFace (Spin(Enext (h.pyram[43][6])),s1[13]); *) EVAL Glue (Spin(Enext (h.pyram[43][6])),s1[13], 1); (* RescueOnFace (Spin(Enext (h.pyram[54][6])),s1[14]); *) EVAL Glue (Spin(Enext (h.pyram[54][6])),s1[14], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[20][2])),s1[15]); *) EVAL Glue (Clock(Enext_1(h.pyram[20][2])),s1[15], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[31][2])),s1[16]); *) EVAL Glue (Clock(Enext_1(h.pyram[31][2])),s1[16], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[42][2])),s1[17]); *) EVAL Glue (Clock(Enext_1(h.pyram[42][2])),s1[17], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[53][2])),s1[18]); *) EVAL Glue (Clock(Enext_1(h.pyram[53][2])),s1[18], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[64][2])),s1[19]); *) EVAL Glue (Clock(Enext_1(h.pyram[64][2])),s1[19], 1); (* 3 *) (* RescueOnFace (Spin(Enext (h.pyram[20][6])),s1[20]); *) EVAL Glue (Spin(Enext (h.pyram[20][6])),s1[20], 1); (* RescueOnFace (Spin(Enext (h.pyram[31][6])),s1[21]); *) EVAL Glue (Spin(Enext (h.pyram[31][6])),s1[21], 1); (* RescueOnFace (Spin(Enext (h.pyram[42][6])),s1[22]); *) EVAL Glue (Spin(Enext (h.pyram[42][6])),s1[22], 1); (* RescueOnFace (Spin(Enext (h.pyram[53][6])),s1[23]); *) EVAL Glue (Spin(Enext (h.pyram[53][6])),s1[23], 1); (* RescueOnFace (Spin(Enext (h.pyram[64][6])),s1[24]); *) EVAL Glue (Spin(Enext (h.pyram[64][6])),s1[24], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[30][2])),s1[25]); *) EVAL Glue (Clock(Enext_1(h.pyram[30][2])),s1[25], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[41][2])),s1[26]); *) EVAL Glue (Clock(Enext_1(h.pyram[41][2])),s1[26], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[52][2])),s1[27]); *) EVAL Glue (Clock(Enext_1(h.pyram[52][2])),s1[27], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[63][2])),s1[28]); *) EVAL Glue (Clock(Enext_1(h.pyram[63][2])),s1[28], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[74][2])),s1[29]); *) EVAL Glue (Clock(Enext_1(h.pyram[74][2])),s1[29], 1); (* 4 *) (* RescueOnFace (Spin(Enext (h.pyram[30][6])),s1[30]); *) EVAL Glue (Spin(Enext (h.pyram[30][6])),s1[30], 1); (* RescueOnFace (Spin(Enext (h.pyram[41][6])),s1[31]); *) EVAL Glue (Spin(Enext (h.pyram[41][6])),s1[31], 1); (* RescueOnFace (Spin(Enext (h.pyram[52][6])),s1[32]); *) EVAL Glue (Spin(Enext (h.pyram[52][6])),s1[32], 1); (* RescueOnFace (Spin(Enext (h.pyram[63][6])),s1[33]); *) EVAL Glue (Spin(Enext (h.pyram[63][6])),s1[33], 1); (* RescueOnFace (Spin(Enext (h.pyram[74][6])),s1[34]); *) EVAL Glue (Spin(Enext (h.pyram[74][6])),s1[34], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[40][2])),s1[35]); *) EVAL Glue (Clock(Enext_1(h.pyram[40][2])),s1[35], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[51][2])),s1[36]); *) EVAL Glue (Clock(Enext_1(h.pyram[51][2])),s1[36], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[62][2])),s1[37]); *) EVAL Glue (Clock(Enext_1(h.pyram[62][2])),s1[37], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[73][2])),s1[38]); *) EVAL Glue (Clock(Enext_1(h.pyram[73][2])),s1[38], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[84][2])),s1[39]); *) EVAL Glue (Clock(Enext_1(h.pyram[84][2])),s1[39], 1); (* 5 *) (* RescueOnFace (Spin(Enext (h.pyram[40][6])),s1[40]); *) EVAL Glue (Spin(Enext (h.pyram[40][6])),s1[40], 1); (* RescueOnFace (Spin(Enext (h.pyram[51][6])),s1[41]); *) EVAL Glue (Spin(Enext (h.pyram[51][6])),s1[41], 1); (* RescueOnFace (Spin(Enext (h.pyram[62][6])),s1[42]); *) EVAL Glue (Spin(Enext (h.pyram[62][6])),s1[42], 1); (* RescueOnFace (Spin(Enext (h.pyram[73][6])),s1[43]); *) EVAL Glue (Spin(Enext (h.pyram[73][6])),s1[43], 1); (* RescueOnFace (Spin(Enext (h.pyram[84][6])),s1[44]); *) EVAL Glue (Spin(Enext (h.pyram[84][6])),s1[44], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[50][2])),s1[45]); *) EVAL Glue (Clock(Enext_1(h.pyram[50][2])),s1[45], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[61][2])),s1[46]); *) EVAL Glue (Clock(Enext_1(h.pyram[61][2])),s1[46], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[72][2])),s1[47]); *) EVAL Glue (Clock(Enext_1(h.pyram[72][2])),s1[47], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[83][2])),s1[48]); *) EVAL Glue (Clock(Enext_1(h.pyram[83][2])),s1[48], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[94][2])),s1[49]); *) EVAL Glue (Clock(Enext_1(h.pyram[94][2])),s1[49], 1); (* 6 *) (* RescueOnFace (Spin(Enext (h.pyram[50][6])),s1[50]); *) EVAL Glue (Spin(Enext (h.pyram[50][6])),s1[50], 1); (* RescueOnFace (Spin(Enext (h.pyram[61][6])),s1[51]); *) EVAL Glue (Spin(Enext (h.pyram[61][6])),s1[51], 1); (* RescueOnFace (Spin(Enext (h.pyram[72][6])),s1[52]); *) EVAL Glue (Spin(Enext (h.pyram[72][6])),s1[52], 1); (* RescueOnFace (Spin(Enext (h.pyram[83][6])),s1[53]); *) EVAL Glue (Spin(Enext (h.pyram[83][6])),s1[53], 1); (* RescueOnFace (Spin(Enext (h.pyram[94][6])),s1[54]); *) EVAL Glue (Spin(Enext (h.pyram[94][6])),s1[54], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[60][2])),s1[55]); *) EVAL Glue (Clock(Enext_1(h.pyram[60][2])),s1[55], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[71][2])),s1[56]); *) EVAL Glue (Clock(Enext_1(h.pyram[71][2])),s1[56], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[82][2])),s1[57]); *) EVAL Glue (Clock(Enext_1(h.pyram[82][2])),s1[57], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[93][2])),s1[58]); *) EVAL Glue (Clock(Enext_1(h.pyram[93][2])),s1[58], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[ 4][2])),s1[59]); *) EVAL Glue (Clock(Enext_1(h.pyram[ 4][2])),s1[59], 1); (* 7 *) (* RescueOnFace (Spin(Enext (h.pyram[60][6])),s1[60]); *) EVAL Glue (Spin(Enext (h.pyram[60][6])),s1[60], 1); (* RescueOnFace (Spin(Enext (h.pyram[71][6])),s1[61]); *) EVAL Glue (Spin(Enext (h.pyram[71][6])),s1[61], 1); (* RescueOnFace (Spin(Enext (h.pyram[82][6])),s1[62]); *) EVAL Glue (Spin(Enext (h.pyram[82][6])),s1[62], 1); (* RescueOnFace (Spin(Enext (h.pyram[93][6])),s1[63]); *) EVAL Glue (Spin(Enext (h.pyram[93][6])),s1[63], 1); (* RescueOnFace (Spin(Enext (h.pyram[ 4][6])),s1[64]); *) EVAL Glue (Spin(Enext (h.pyram[ 4][6])),s1[64], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[70][2])),s1[65]); *) EVAL Glue (Clock(Enext_1(h.pyram[70][2])),s1[65], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[81][2])),s1[66]); *) EVAL Glue (Clock(Enext_1(h.pyram[81][2])),s1[66], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[92][2])),s1[67]); *) EVAL Glue (Clock(Enext_1(h.pyram[92][2])),s1[67], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[ 3][2])),s1[68]); *) EVAL Glue (Clock(Enext_1(h.pyram[ 3][2])),s1[68], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[14][2])),s1[69]); *) EVAL Glue (Clock(Enext_1(h.pyram[14][2])),s1[69], 1); (* 8 *) (* RescueOnFace (Spin(Enext (h.pyram[70][6])),s1[70]); *) EVAL Glue (Spin(Enext (h.pyram[70][6])),s1[70], 1); (* RescueOnFace (Spin(Enext (h.pyram[81][6])),s1[71]); *) EVAL Glue (Spin(Enext (h.pyram[81][6])),s1[71], 1); (* RescueOnFace (Spin(Enext (h.pyram[92][6])),s1[72]); *) EVAL Glue (Spin(Enext (h.pyram[92][6])),s1[72], 1); (* RescueOnFace (Spin(Enext (h.pyram[ 3][6])),s1[73]); *) EVAL Glue (Spin(Enext (h.pyram[ 3][6])),s1[73], 1); (* RescueOnFace (Spin(Enext (h.pyram[14][6])),s1[74]); *) EVAL Glue (Spin(Enext (h.pyram[14][6])),s1[74], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[80][2])),s1[75]); *) EVAL Glue (Clock(Enext_1(h.pyram[80][2])),s1[75], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[91][2])),s1[76]); *) EVAL Glue (Clock(Enext_1(h.pyram[91][2])),s1[76], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[ 2][2])),s1[77]); *) EVAL Glue (Clock(Enext_1(h.pyram[ 2][2])),s1[77], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[13][2])),s1[78]); *) EVAL Glue (Clock(Enext_1(h.pyram[13][2])),s1[78], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[24][2])),s1[79]); *) EVAL Glue (Clock(Enext_1(h.pyram[24][2])),s1[79], 1); (* 9 *) (* RescueOnFace (Spin(Enext (h.pyram[80][6])),s1[80]); *) EVAL Glue (Spin(Enext (h.pyram[80][6])),s1[80], 1); (* RescueOnFace (Spin(Enext (h.pyram[91][6])),s1[81]); *) EVAL Glue (Spin(Enext (h.pyram[91][6])),s1[81], 1); (* RescueOnFace (Spin(Enext (h.pyram[ 2][6])),s1[82]); *) EVAL Glue (Spin(Enext (h.pyram[ 2][6])),s1[82], 1); (* RescueOnFace (Spin(Enext (h.pyram[13][6])),s1[83]); *) EVAL Glue (Spin(Enext (h.pyram[13][6])),s1[83], 1); (* RescueOnFace (Spin(Enext (h.pyram[24][6])),s1[84]); *) EVAL Glue (Spin(Enext (h.pyram[24][6])),s1[84], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[90][2])),s1[85]); *) EVAL Glue (Clock(Enext_1(h.pyram[90][2])),s1[85], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[ 1][2])),s1[86]); *) EVAL Glue (Clock(Enext_1(h.pyram[ 1][2])),s1[86], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[12][2])),s1[87]); *) EVAL Glue (Clock(Enext_1(h.pyram[12][2])),s1[87], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[23][2])),s1[88]); *) EVAL Glue (Clock(Enext_1(h.pyram[23][2])),s1[88], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[34][2])),s1[89]); *) EVAL Glue (Clock(Enext_1(h.pyram[34][2])),s1[89], 1); (* 10 *) (* RescueOnFace (Spin(Enext (h.pyram[90][6])),s1[90]); *) EVAL Glue (Spin(Enext (h.pyram[90][6])),s1[90], 1); (* RescueOnFace (Spin(Enext (h.pyram[ 1][6])),s1[91]); *) EVAL Glue (Spin(Enext (h.pyram[ 1][6])),s1[91], 1); (* RescueOnFace (Spin(Enext (h.pyram[12][6])),s1[92]); *) EVAL Glue (Spin(Enext (h.pyram[12][6])),s1[92], 1); (* RescueOnFace (Spin(Enext (h.pyram[23][6])),s1[93]); *) EVAL Glue (Spin(Enext (h.pyram[23][6])),s1[93], 1); (* RescueOnFace (Spin(Enext (h.pyram[34][6])),s1[94]); *) EVAL Glue (Spin(Enext (h.pyram[34][6])),s1[94], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[ 0][2])),s1[95]); *) EVAL Glue (Clock(Enext_1(h.pyram[ 0][2])),s1[95], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[11][2])),s1[96]); *) EVAL Glue (Clock(Enext_1(h.pyram[11][2])),s1[96], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[22][2])),s1[97]); *) EVAL Glue (Clock(Enext_1(h.pyram[22][2])),s1[97], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[33][2])),s1[98]); *) EVAL Glue (Clock(Enext_1(h.pyram[33][2])),s1[98], 1); (* RescueOnFace (Clock(Enext_1(h.pyram[44][2])),s1[99]); *) EVAL Glue (Clock(Enext_1(h.pyram[44][2])),s1[99], 1); (* gluing the left side border with the rigth side border in the toroidal sheet. *) (* RescueOnFace (Spin(Enext_1(h.tetra[54][2])), h.pyram[0][7]); *) EVAL Glue (Spin(Enext_1(h.tetra[54][2])), h.pyram[0][7], 1); (* RescueOnFace (Spin(Enext(h.pyram [59][7])), h.tetra[5][2]); *) EVAL Glue (Spin(Enext(h.pyram [59][7])), h.tetra[5][2], 1); (* RescueOnFace (Spin(Enext_1(h.tetra[64][2])), h.pyram[10][7]); *) EVAL Glue (Spin(Enext_1(h.tetra[64][2])), h.pyram[10][7], 1); (* RescueOnFace (Spin(Enext(h.pyram [69][7])), h.tetra[15][2]); *) EVAL Glue (Spin(Enext(h.pyram [69][7])), h.tetra[15][2], 1); (* RescueOnFace (Spin(Enext_1(h.tetra[74][2])), h.pyram[20][7]); *) EVAL Glue (Spin(Enext_1(h.tetra[74][2])), h.pyram[20][7], 1); (* RescueOnFace (Spin(Enext(h.pyram [79][7])), h.tetra[25][2]); *) EVAL Glue (Spin(Enext(h.pyram [79][7])), h.tetra[25][2], 1); (* RescueOnFace (Spin(Enext_1(h.tetra[84][2])), h.pyram[30][7]); *) EVAL Glue (Spin(Enext_1(h.tetra[84][2])), h.pyram[30][7], 1); (* RescueOnFace (Spin(Enext(h.pyram [89][7])), h.tetra[35][2]); *) EVAL Glue (Spin(Enext(h.pyram [89][7])), h.tetra[35][2], 1); (* RescueOnFace (Spin(Enext_1(h.tetra[94][2])), h.pyram[40][7]); *) EVAL Glue (Spin(Enext_1(h.tetra[94][2])), h.pyram[40][7], 1); (* RescueOnFace (Spin(Enext(h.pyram [99][7])), h.tetra[45][2]); *) EVAL Glue (Spin(Enext(h.pyram [99][7])), h.tetra[45][2], 1); (* RescueOnFace (Spin(Enext_1(h.tetra[4][2])), h.pyram[50][7]); *) EVAL Glue (Spin(Enext_1(h.tetra[4][2])), h.pyram[50][7], 1); (* RescueOnFace (Spin(Enext(h.pyram [9][7])), h.tetra[55][2]); *) EVAL Glue (Spin(Enext(h.pyram [9][7])), h.tetra[55][2], 1); (* RescueOnFace (Spin(Enext_1(h.tetra[14][2])), h.pyram[60][7]); *) EVAL Glue (Spin(Enext_1(h.tetra[14][2])), h.pyram[60][7], 1); (* RescueOnFace (Spin(Enext(h.pyram [19][7])), h.tetra[65][2]); *) EVAL Glue (Spin(Enext(h.pyram[ 19][7])), h.tetra[65][2], 1); (* RescueOnFace (Spin(Enext_1(h.tetra[24][2])), h.pyram[70][7]); *) EVAL Glue (Spin(Enext_1(h.tetra[24][2])), h.pyram[70][7], 1); (* RescueOnFace (Spin(Enext(h.pyram [29][7])), h.tetra[75][2]); *) EVAL Glue (Spin(Enext(h.pyram [29][7])), h.tetra[75][2], 1); (* RescueOnFace (Spin(Enext_1(h.tetra[34][2])), h.pyram[80][7]); *) EVAL Glue (Spin(Enext_1(h.tetra[34][2])), h.pyram[80][7], 1); (* RescueOnFace (Spin(Enext(h.pyram [39][7])), h.tetra[85][2]); *) EVAL Glue (Spin(Enext(h.pyram [39][7])), h.tetra[85][2], 1); (* RescueOnFace (Spin(Enext_1(h.tetra[44][2])), h.pyram[90][7]); *) EVAL Glue (Spin(Enext_1(h.tetra[44][2])), h.pyram[90][7], 1); (* RescueOnFace (Spin(Enext(h.pyram [49][7])), h.tetra[95][2]); *) EVAL Glue (Spin(Enext(h.pyram [49][7])), h.tetra[95][2], 1); (* gluing the botton border with the top border in the toroidal sheet. *) FOR i := 0 TO 4 DO (* RescueOnFace (Clock(Enext(h.tetra[95+i][0])), h.pyram[i][3]); *) EVAL Glue (Clock(Enext(h.tetra[95+i][0])), h.pyram[i][3], 1); (* RescueOnFace (Spin(Enext(h.pyram[i+95][5])), h.tetra[i][3]); *) EVAL Glue (Spin(Enext(h.pyram[i+95][5])), h.tetra[i][3], 1); END; (* ultima etapa *) (* 1 *) (* RescueOnFace (Spin(Enext_1(h.pyram[95][2])), s2[0]); *) EVAL Glue (Spin(Enext_1(h.pyram[95][2])), s2[0], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[86][2])), s2[1]); *) EVAL Glue (Spin(Enext_1(h.pyram[86][2])), s2[1], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[77][2])), s2[2]); *) EVAL Glue (Spin(Enext_1(h.pyram[77][2])), s2[2], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[68][2])), s2[3]); *) EVAL Glue (Spin(Enext_1(h.pyram[68][2])), s2[3], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[59][2])), s2[4]); *) EVAL Glue (Spin(Enext_1(h.pyram[59][2])), s2[4], 1); (* RescueOnFace (Clock(Enext(h.pyram[85][6])), s2[5]); *) EVAL Glue (Clock(Enext(h.pyram[85][6])), s2[5], 1); (* RescueOnFace (Clock(Enext(h.pyram[76][6])), s2[6]); *) EVAL Glue (Clock(Enext(h.pyram[76][6])), s2[6], 1); (* RescueOnFace (Clock(Enext(h.pyram[67][6])), s2[7]); *) EVAL Glue (Clock(Enext(h.pyram[67][6])), s2[7], 1); (* RescueOnFace (Clock(Enext(h.pyram[58][6])), s2[8]); *) EVAL Glue (Clock(Enext(h.pyram[58][6])), s2[8], 1); (* RescueOnFace (Clock(Enext(h.pyram[49][6])), s2[9]); *) EVAL Glue (Clock(Enext(h.pyram[49][6])), s2[9], 1); (* 2 *) (* RescueOnFace (Spin(Enext_1(h.pyram[85][2])), s2[10]); *) EVAL Glue (Spin(Enext_1(h.pyram[85][2])), s2[10], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[76][2])), s2[11]); *) EVAL Glue (Spin(Enext_1(h.pyram[76][2])), s2[11], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[67][2])), s2[12]); *) EVAL Glue (Spin(Enext_1(h.pyram[67][2])), s2[12], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[58][2])), s2[13]); *) EVAL Glue (Spin(Enext_1(h.pyram[58][2])), s2[13], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[49][2])), s2[14]); *) EVAL Glue (Spin(Enext_1(h.pyram[49][2])), s2[14], 1); (* RescueOnFace (Clock(Enext(h.pyram[75][6])), s2[15]); *) EVAL Glue (Clock(Enext(h.pyram[75][6])), s2[15], 1); (* RescueOnFace (Clock(Enext(h.pyram[66][6])), s2[16]); *) EVAL Glue (Clock(Enext(h.pyram[66][6])), s2[16], 1); (* RescueOnFace (Clock(Enext(h.pyram[57][6])), s2[17]); *) EVAL Glue (Clock(Enext(h.pyram[57][6])), s2[17], 1); (* RescueOnFace (Clock(Enext(h.pyram[48][6])), s2[18]); *) EVAL Glue (Clock(Enext(h.pyram[48][6])), s2[18], 1); (* RescueOnFace (Clock(Enext(h.pyram[39][6])), s2[19]); *) EVAL Glue (Clock(Enext(h.pyram[39][6])), s2[19], 1); (* 3 *) (* RescueOnFace (Spin(Enext_1(h.pyram[75][2])), s2[20]); *) EVAL Glue (Spin(Enext_1(h.pyram[75][2])), s2[20], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[66][2])), s2[21]); *) EVAL Glue (Spin(Enext_1(h.pyram[66][2])), s2[21], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[57][2])), s2[22]); *) EVAL Glue (Spin(Enext_1(h.pyram[57][2])), s2[22], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[48][2])), s2[23]); *) EVAL Glue (Spin(Enext_1(h.pyram[48][2])), s2[23], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[39][2])), s2[24]); *) EVAL Glue (Spin(Enext_1(h.pyram[39][2])), s2[24], 1); (* RescueOnFace (Clock(Enext(h.pyram[65][6])), s2[25]); *) EVAL Glue (Clock(Enext(h.pyram[65][6])), s2[25], 1); (* RescueOnFace (Clock(Enext(h.pyram[56][6])), s2[26]); *) EVAL Glue (Clock(Enext(h.pyram[56][6])), s2[26], 1); (* RescueOnFace (Clock(Enext(h.pyram[47][6])), s2[27]); *) EVAL Glue (Clock(Enext(h.pyram[47][6])), s2[27], 1); (* RescueOnFace (Clock(Enext(h.pyram[38][6])), s2[28]); *) EVAL Glue (Clock(Enext(h.pyram[38][6])), s2[28], 1); (* RescueOnFace (Clock(Enext(h.pyram[29][6])), s2[29]); *) EVAL Glue (Clock(Enext(h.pyram[29][6])), s2[29], 1); (* 4 *) (* RescueOnFace (Spin(Enext_1(h.pyram[65][2])), s2[30]); *) EVAL Glue (Spin(Enext_1(h.pyram[65][2])), s2[30], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[56][2])), s2[31]); *) EVAL Glue (Spin(Enext_1(h.pyram[56][2])), s2[31], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[47][2])), s2[32]); *) EVAL Glue (Spin(Enext_1(h.pyram[47][2])), s2[32], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[38][2])), s2[33]); *) EVAL Glue (Spin(Enext_1(h.pyram[38][2])), s2[33], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[29][2])), s2[34]); *) EVAL Glue (Spin(Enext_1(h.pyram[29][2])), s2[34], 1); (* RescueOnFace (Clock(Enext(h.pyram[55][6])), s2[35]); *) EVAL Glue (Clock(Enext(h.pyram[55][6])), s2[35], 1); (* RescueOnFace (Clock(Enext(h.pyram[46][6])), s2[36]); *) EVAL Glue (Clock(Enext(h.pyram[46][6])), s2[36], 1); (* RescueOnFace (Clock(Enext(h.pyram[37][6])), s2[37]); *) EVAL Glue (Clock(Enext(h.pyram[37][6])), s2[37], 1); (* RescueOnFace (Clock(Enext(h.pyram[28][6])), s2[38]); *) EVAL Glue (Clock(Enext(h.pyram[28][6])), s2[38], 1); (* RescueOnFace (Clock(Enext(h.pyram[19][6])), s2[39]); *) EVAL Glue (Clock(Enext(h.pyram[19][6])), s2[39], 1); (* 5 *) (* RescueOnFace (Spin(Enext_1(h.pyram[55][2])), s2[40]); *) EVAL Glue (Spin(Enext_1(h.pyram[55][2])), s2[40], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[46][2])), s2[41]); *) EVAL Glue (Spin(Enext_1(h.pyram[46][2])), s2[41], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[37][2])), s2[42]); *) EVAL Glue (Spin(Enext_1(h.pyram[37][2])), s2[42], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[28][2])), s2[43]); *) EVAL Glue (Spin(Enext_1(h.pyram[28][2])), s2[43], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[19][2])), s2[44]); *) EVAL Glue (Spin(Enext_1(h.pyram[19][2])), s2[44], 1); (* RescueOnFace (Clock(Enext(h.pyram[45][6])), s2[45]); *) EVAL Glue (Clock(Enext(h.pyram[45][6])), s2[45], 1); (* RescueOnFace (Clock(Enext(h.pyram[36][6])), s2[46]); *) EVAL Glue (Clock(Enext(h.pyram[36][6])), s2[46], 1); (* RescueOnFace (Clock(Enext(h.pyram[27][6])), s2[47]); *) EVAL Glue (Clock(Enext(h.pyram[27][6])), s2[47], 1); (* RescueOnFace (Clock(Enext(h.pyram[18][6])), s2[48]); *) EVAL Glue (Clock(Enext(h.pyram[18][6])), s2[48], 1); (* RescueOnFace (Clock(Enext(h.pyram[ 9][6])), s2[49]); *) EVAL Glue (Clock(Enext(h.pyram[ 9][6])), s2[49], 1); (* 6 *) (* RescueOnFace (Spin(Enext_1(h.pyram[45][2])), s2[50]); *) EVAL Glue (Spin(Enext_1(h.pyram[45][2])), s2[50], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[36][2])), s2[51]); *) EVAL Glue (Spin(Enext_1(h.pyram[36][2])), s2[51], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[27][2])), s2[52]); *) EVAL Glue (Spin(Enext_1(h.pyram[27][2])), s2[52], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[18][2])), s2[53]); *) EVAL Glue (Spin(Enext_1(h.pyram[18][2])), s2[53], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[ 9][2])), s2[54]); *) EVAL Glue (Spin(Enext_1(h.pyram[ 9][2])), s2[54], 1); (* RescueOnFace (Clock(Enext(h.pyram[35][6])), s2[55]); *) EVAL Glue (Clock(Enext(h.pyram[35][6])), s2[55], 1); (* RescueOnFace (Clock(Enext(h.pyram[26][6])), s2[56]); *) EVAL Glue (Clock(Enext(h.pyram[26][6])), s2[56], 1); (* RescueOnFace (Clock(Enext(h.pyram[17][6])), s2[57]); *) EVAL Glue (Clock(Enext(h.pyram[17][6])), s2[57], 1); (* RescueOnFace (Clock(Enext(h.pyram[ 8][6])), s2[58]); *) EVAL Glue (Clock(Enext(h.pyram[ 8][6])), s2[58], 1); (* RescueOnFace (Clock(Enext(h.pyram[99][6])), s2[59]); *) EVAL Glue (Clock(Enext(h.pyram[99][6])), s2[59], 1); (* 7 *) (* RescueOnFace (Spin(Enext_1(h.pyram[35][2])), s2[60]); *) EVAL Glue (Spin(Enext_1(h.pyram[35][2])), s2[60], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[26][2])), s2[61]); *) EVAL Glue (Spin(Enext_1(h.pyram[26][2])), s2[61], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[17][2])), s2[62]); *) EVAL Glue (Spin(Enext_1(h.pyram[17][2])), s2[62], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[ 8][2])), s2[63]); *) EVAL Glue (Spin(Enext_1(h.pyram[ 8][2])), s2[63], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[99][2])), s2[64]); *) EVAL Glue (Spin(Enext_1(h.pyram[99][2])), s2[64], 1); (* RescueOnFace (Clock(Enext(h.pyram[25][6])), s2[65]); *) EVAL Glue (Clock(Enext(h.pyram[25][6])), s2[65], 1); (* RescueOnFace (Clock(Enext(h.pyram[16][6])), s2[66]); *) EVAL Glue (Clock(Enext(h.pyram[16][6])), s2[66], 1); (* RescueOnFace (Clock(Enext(h.pyram[ 7][6])), s2[67]); *) EVAL Glue (Clock(Enext(h.pyram[ 7][6])), s2[67], 1); (* RescueOnFace (Clock(Enext(h.pyram[98][6])), s2[68]); *) EVAL Glue (Clock(Enext(h.pyram[98][6])), s2[68], 1); (* RescueOnFace (Clock(Enext(h.pyram[89][6])), s2[69]); *) EVAL Glue (Clock(Enext(h.pyram[89][6])), s2[69], 1); (* 8 *) (* RescueOnFace (Spin(Enext_1(h.pyram[25][2])), s2[70]); *) EVAL Glue (Spin(Enext_1(h.pyram[25][2])), s2[70], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[16][2])), s2[71]); *) EVAL Glue (Spin(Enext_1(h.pyram[16][2])), s2[71], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[ 7][2])), s2[72]); *) EVAL Glue (Spin(Enext_1(h.pyram[ 7][2])), s2[72], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[98][2])), s2[73]); *) EVAL Glue (Spin(Enext_1(h.pyram[98][2])), s2[73], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[89][2])), s2[74]); *) EVAL Glue (Spin(Enext_1(h.pyram[89][2])), s2[74], 1); (* RescueOnFace (Clock(Enext(h.pyram[15][6])), s2[75]); *) EVAL Glue (Clock(Enext(h.pyram[15][6])), s2[75], 1); (* RescueOnFace (Clock(Enext(h.pyram[ 6][6])), s2[76]); *) EVAL Glue (Clock(Enext(h.pyram[ 6][6])), s2[76], 1); (* RescueOnFace (Clock(Enext(h.pyram[97][6])), s2[77]); *) EVAL Glue (Clock(Enext(h.pyram[97][6])), s2[77], 1); (* RescueOnFace (Clock(Enext(h.pyram[88][6])), s2[78]); *) EVAL Glue (Clock(Enext(h.pyram[88][6])), s2[78], 1); (* RescueOnFace (Clock(Enext(h.pyram[79][6])), s2[79]); *) EVAL Glue (Clock(Enext(h.pyram[79][6])), s2[79], 1); (* 9 *) (* RescueOnFace (Spin(Enext_1(h.pyram[15][2])), s2[80]); *) EVAL Glue (Spin(Enext_1(h.pyram[15][2])), s2[80], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[ 6][2])), s2[81]); *) EVAL Glue (Spin(Enext_1(h.pyram[ 6][2])), s2[81], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[97][2])), s2[82]); *) EVAL Glue (Spin(Enext_1(h.pyram[97][2])), s2[82], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[88][2])), s2[83]); *) EVAL Glue (Spin(Enext_1(h.pyram[88][2])), s2[83], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[79][2])), s2[84]); *) EVAL Glue (Spin(Enext_1(h.pyram[79][2])), s2[84], 1); (* RescueOnFace (Clock(Enext(h.pyram[ 5][6])), s2[85]); *) EVAL Glue (Clock(Enext(h.pyram[ 5][6])), s2[85], 1); (* RescueOnFace (Clock(Enext(h.pyram[96][6])), s2[86]); *) EVAL Glue (Clock(Enext(h.pyram[96][6])), s2[86], 1); (* RescueOnFace (Clock(Enext(h.pyram[87][6])), s2[87]); *) EVAL Glue (Clock(Enext(h.pyram[87][6])), s2[87], 1); (* RescueOnFace (Clock(Enext(h.pyram[78][6])), s2[88]); *) EVAL Glue (Clock(Enext(h.pyram[78][6])), s2[88], 1); (* RescueOnFace (Clock(Enext(h.pyram[69][6])), s2[89]); *) EVAL Glue (Clock(Enext(h.pyram[69][6])), s2[89], 1); (* 10 *) (* RescueOnFace (Spin(Enext_1(h.pyram[ 5][2])), s2[90]); *) EVAL Glue (Spin(Enext_1(h.pyram[ 5][2])), s2[90], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[96][2])), s2[91]); *) EVAL Glue (Spin(Enext_1(h.pyram[96][2])), s2[91], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[87][2])), s2[92]); *) EVAL Glue (Spin(Enext_1(h.pyram[87][2])), s2[92], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[78][2])), s2[93]); *) EVAL Glue (Spin(Enext_1(h.pyram[78][2])), s2[93], 1); (* RescueOnFace (Spin(Enext_1(h.pyram[69][2])), s2[94]); *) EVAL Glue (Spin(Enext_1(h.pyram[69][2])), s2[94], 1); (* RescueOnFace (Clock(Enext(h.pyram[95][6])), s2[95]); *) EVAL Glue (Clock(Enext(h.pyram[95][6])), s2[95], 1); (* RescueOnFace (Clock(Enext(h.pyram[86][6])), s2[96]); *) EVAL Glue (Clock(Enext(h.pyram[86][6])), s2[96], 1); (* RescueOnFace (Clock(Enext(h.pyram[77][6])), s2[97]); *) EVAL Glue (Clock(Enext(h.pyram[77][6])), s2[97], 1); (* RescueOnFace (Clock(Enext(h.pyram[68][6])), s2[98]); *) EVAL Glue (Clock(Enext(h.pyram[68][6])), s2[98], 1); (* RescueOnFace (Clock(Enext(h.pyram[59][6])), s2[99]); *) EVAL Glue (Clock(Enext(h.pyram[59][6])), s2[99], 1); RETURN h.pyram[10][2]; END; END Makecell600; PROCEDURE MakeHollowTorus() : Free = (* Build a hollow toroidal sheet, with 300 tetrahedra. *) VAR f : Free; BEGIN f.tetra := NEW(REF ARRAY OF PAIR, 100, 4); f.pyram := NEW(REF ARRAY OF PAIR, 100, 8); WITH r1 = MakeRow(), r2 = MakeRow(), r3 = MakeRow(), r4 = MakeRow(), r5 = MakeRow(), r6 = MakeRow(), r7 = MakeRow(), r8 = MakeRow(), r9 = MakeRow(), r10 = MakeRow() DO (* r1 <---> r2 *) FOR i := 0 TO 4 DO (* RescueOnFace (Clock(Enext(r1.tetra[i+5][0])), r2.pyram[i][3]); *) EVAL Glue (Clock(Enext(r1.tetra[i+5][0])), r2.pyram[i][3], 1); (* RescueOnFace (Spin(Enext(r1.pyram[i+5][5])), r2.tetra[i][3]); *) EVAL Glue (Spin(Enext(r1.pyram[i+5][5])), r2.tetra[i][3], 1); END; (* r2 <---> r3 *) FOR i := 0 TO 4 DO (* RescueOnFace (Clock(Enext(r2.tetra[i+5][0])), r3.pyram[i][3]); *) EVAL Glue (Clock(Enext(r2.tetra[i+5][0])), r3.pyram[i][3], 1); (* RescueOnFace (Spin(Enext(r2.pyram[i+5][5])), r3.tetra[i][3]); *) EVAL Glue (Spin(Enext(r2.pyram[i+5][5])), r3.tetra[i][3], 1); END; (* r3 <---> r4 *) FOR i := 0 TO 4 DO (* RescueOnFace (Clock(Enext(r3.tetra[i+5][0])), r4.pyram[i][3]); *) EVAL Glue (Clock(Enext(r3.tetra[i+5][0])), r4.pyram[i][3], 1); (* RescueOnFace (Spin(Enext(r3.pyram[i+5][5])), r4.tetra[i][3]); *) EVAL Glue (Spin(Enext(r3.pyram[i+5][5])), r4.tetra[i][3], 1); END; (* r4 <---> r5 *) FOR i := 0 TO 4 DO (* RescueOnFace (Clock(Enext(r4.tetra[i+5][0])), r5.pyram[i][3]); *) EVAL Glue (Clock(Enext(r4.tetra[i+5][0])), r5.pyram[i][3], 1); (* RescueOnFace (Spin(Enext(r4.pyram[i+5][5])), r5.tetra[i][3]); *) EVAL Glue (Spin(Enext(r4.pyram[i+5][5])), r5.tetra[i][3], 1); END; (* r5 <---> r6 *) FOR i := 0 TO 4 DO (* RescueOnFace (Clock(Enext(r5.tetra[i+5][0])), r6.pyram[i][3]); *) EVAL Glue (Clock(Enext(r5.tetra[i+5][0])), r6.pyram[i][3], 1); (* RescueOnFace (Spin(Enext(r5.pyram[i+5][5])), r6.tetra[i][3]); *) EVAL Glue (Spin(Enext(r5.pyram[i+5][5])), r6.tetra[i][3], 1); END; (* r6 <---> r7 *) FOR i := 0 TO 4 DO (* RescueOnFace (Clock(Enext(r6.tetra[i+5][0])), r7.pyram[i][3]); *) EVAL Glue (Clock(Enext(r6.tetra[i+5][0])), r7.pyram[i][3], 1); (* RescueOnFace (Spin(Enext(r6.pyram[i+5][5])), r7.tetra[i][3]); *) EVAL Glue (Spin(Enext(r6.pyram[i+5][5])), r7.tetra[i][3], 1); END; (* r7 <---> r8 *) FOR i := 0 TO 4 DO (* RescueOnFace (Clock(Enext(r7.tetra[i+5][0])), r8.pyram[i][3]); *) EVAL Glue (Clock(Enext(r7.tetra[i+5][0])), r8.pyram[i][3], 1); (* RescueOnFace (Spin(Enext(r7.pyram[i+5][5])), r8.tetra[i][3]); *) EVAL Glue (Spin(Enext(r7.pyram[i+5][5])), r8.tetra[i][3], 1); END; (* r8 <---> r9 *) FOR i := 0 TO 4 DO (* RescueOnFace (Clock(Enext(r8.tetra[i+5][0])), r9.pyram[i][3]); *) EVAL Glue (Clock(Enext(r8.tetra[i+5][0])), r9.pyram[i][3], 1); (* RescueOnFace (Spin(Enext(r8.pyram[i+5][5])), r9.tetra[i][3]); *) EVAL Glue (Spin(Enext(r8.pyram[i+5][5])), r9.tetra[i][3], 1); END; (* r9 <---> r10 *) FOR i := 0 TO 4 DO (* RescueOnFace (Clock(Enext(r9.tetra[i+5][0])), r10.pyram[i][3]); *) EVAL Glue (Clock(Enext(r9.tetra[i+5][0])), r10.pyram[i][3], 1); (* RescueOnFace (Spin(Enext(r9.pyram[i+5][5])), r10.tetra[i][3]); *) EVAL Glue (Spin(Enext(r9.pyram[i+5][5])), r10.tetra[i][3], 1); END; FOR i := 0 TO 9 DO f.pyram[i] := r1.pyram[i]; f.tetra[i] := r1.tetra[i]; END; FOR i := 10 TO 19 DO f.pyram[i] := r2.pyram[i-10]; f.tetra[i] := r2.tetra[i-10]; END; FOR i := 20 TO 29 DO f.pyram[i] := r3.pyram[i-20]; f.tetra[i] := r3.tetra[i-20]; END; FOR i := 30 TO 39 DO f.pyram[i] := r4.pyram[i-30]; f.tetra[i] := r4.tetra[i-30]; END; FOR i := 40 TO 49 DO f.pyram[i] := r5.pyram[i-40]; f.tetra[i] := r5.tetra[i-40]; END; FOR i := 50 TO 59 DO f.pyram[i] := r6.pyram[i-50]; f.tetra[i] := r6.tetra[i-50]; END; FOR i := 60 TO 69 DO f.pyram[i] := r7.pyram[i-60]; f.tetra[i] := r7.tetra[i-60]; END; FOR i := 70 TO 79 DO f.pyram[i] := r8.pyram[i-70]; f.tetra[i] := r8.tetra[i-70]; END; FOR i := 80 TO 89 DO f.pyram[i] := r9.pyram[i-80]; f.tetra[i] := r9.tetra[i-80]; END; FOR i := 90 TO 99 DO f.pyram[i] := r10.pyram[i-90]; f.tetra[i] := r10.tetra[i-90]; END; (* some useful assertions *) (* inferior grid *) FOR j := 0 TO 4 DO FOR i := 0 TO 8 DO <* ASSERT Fnext(f.pyram[(i+1)*10+j,2]) = Clock(Enext_1(f.pyram[i*(10)+j,6])) *> END END; (* superior grid *) FOR j := 5 TO 9 DO FOR i := 0 TO 8 DO <* ASSERT Fnext(f.pyram[(i+1)*10+j,2]) = Clock(Enext_1(f.pyram[(i*10)+j,6])) *> END END; RETURN f; END END MakeHollowTorus; PROCEDURE MakeTube() : Pair = BEGIN WITH h = MakeHollowTorus() DO (* gluing the left side border with the rigth side border in the toroidal sheet. *) (* RescueOnFace (Spin(Enext_1(h.tetra[54][2])), h.pyram[0][7]); *) EVAL Glue (Spin(Enext_1(h.tetra[54][2])), h.pyram[0][7], 1); (* RescueOnFace (Spin(Enext(h.pyram [59][7])), h.tetra[5][2]); *) EVAL Glue (Spin(Enext(h.pyram [59][7])), h.tetra[5][2], 1); (* RescueOnFace (Spin(Enext_1(h.tetra[64][2])), h.pyram[10][7]); *) EVAL Glue (Spin(Enext_1(h.tetra[64][2])), h.pyram[10][7], 1); (* RescueOnFace (Spin(Enext(h.pyram [69][7])), h.tetra[15][2]); *) EVAL Glue (Spin(Enext(h.pyram [69][7])), h.tetra[15][2], 1); (* RescueOnFace (Spin(Enext_1(h.tetra[74][2])), h.pyram[20][7]); *) EVAL Glue (Spin(Enext_1(h.tetra[74][2])), h.pyram[20][7], 1); (* RescueOnFace (Spin(Enext(h.pyram [79][7])), h.tetra[25][2]); *) EVAL Glue (Spin(Enext(h.pyram [79][7])), h.tetra[25][2], 1); (* RescueOnFace (Spin(Enext_1(h.tetra[84][2])), h.pyram[30][7]); *) EVAL Glue (Spin(Enext_1(h.tetra[84][2])), h.pyram[30][7], 1); (* RescueOnFace (Spin(Enext(h.pyram [89][7])), h.tetra[35][2]); *) EVAL Glue (Spin(Enext(h.pyram [89][7])), h.tetra[35][2], 1); (* RescueOnFace (Spin(Enext_1(h.tetra[94][2])), h.pyram[40][7]); *) EVAL Glue (Spin(Enext_1(h.tetra[94][2])), h.pyram[40][7], 1); (* RescueOnFace (Spin(Enext(h.pyram [99][7])), h.tetra[45][2]); *) EVAL Glue (Spin(Enext(h.pyram [99][7])), h.tetra[45][2], 1); (* RescueOnFace (Spin(Enext_1(h.tetra[4][2])), h.pyram[50][7]); *) EVAL Glue (Spin(Enext_1(h.tetra[4][2])), h.pyram[50][7], 1); (* RescueOnFace (Spin(Enext(h.pyram [9][7])), h.tetra[55][2]); *) EVAL Glue (Spin(Enext(h.pyram [9][7])), h.tetra[55][2], 1); (* RescueOnFace (Spin(Enext_1(h.tetra[14][2])), h.pyram[60][7]); *) EVAL Glue (Spin(Enext_1(h.tetra[14][2])), h.pyram[60][7], 1); (* RescueOnFace (Spin(Enext(h.pyram [19][7])), h.tetra[65][2]); *) EVAL Glue (Spin(Enext(h.pyram[ 19][7])), h.tetra[65][2], 1); (* RescueOnFace (Spin(Enext_1(h.tetra[24][2])), h.pyram[70][7]); *) EVAL Glue (Spin(Enext_1(h.tetra[24][2])), h.pyram[70][7], 1); (* RescueOnFace (Spin(Enext(h.pyram [29][7])), h.tetra[75][2]); *) EVAL Glue (Spin(Enext(h.pyram [29][7])), h.tetra[75][2], 1); (* RescueOnFace (Spin(Enext_1(h.tetra[34][2])), h.pyram[80][7]); *) EVAL Glue (Spin(Enext_1(h.tetra[34][2])), h.pyram[80][7], 1); (* RescueOnFace (Spin(Enext(h.pyram [39][7])), h.tetra[85][2]); *) EVAL Glue (Spin(Enext(h.pyram [39][7])), h.tetra[85][2], 1); (* RescueOnFace (Spin(Enext_1(h.tetra[44][2])), h.pyram[90][7]); *) EVAL Glue (Spin(Enext_1(h.tetra[44][2])), h.pyram[90][7], 1); (* RescueOnFace (Spin(Enext(h.pyram [49][7])), h.tetra[95][2]); *) EVAL Glue (Spin(Enext(h.pyram [49][7])), h.tetra[95][2], 1); (* gluing the botton border with the top border in the toroidal sheet. *) FOR i := 0 TO 4 DO (* RescueOnFace (Clock(Enext(h.tetra[95+i][0])), h.pyram[i][3]); *) EVAL Glue (Clock(Enext(h.tetra[95+i][0])), h.pyram[i][3], 1); (* RescueOnFace (Spin(Enext(h.pyram[i+95][5])), h.tetra[i][3]); *) EVAL Glue (Spin(Enext(h.pyram[i+95][5])), h.tetra[i][3], 1); END; RETURN h.pyram[10][2] END; END MakeTube; PROCEDURE MakeRow() : Free = VAR f : Free; BEGIN f.tetra := NEW(REF ARRAY OF PAIR, 10, 4); f.pyram := NEW(REF ARRAY OF PAIR, 10, 8); WITH p1 = MakeRowAtom5(), p2 = MakeRowAtom5() DO (* gluings: p1.pyram[0][5] p2.tetra[4][3] p1.tetra[0][0] p2.pyram[4][3] p1.pyram[1][5] p2.tetra[3][3] p1.tetra[1][0] p2.pyram[3][3] p1.pyram[2][5] p2.tetra[2][3] p1.tetra[2][0] p2.pyram[2][3] p1.pyram[3][5] p2.tetra[1][3] p1.tetra[3][0] p2.pyram[1][3] p1.pyram[4][5] p2.tetra[0][3] p1.tetra[4][0] p2.pyram[0][3] *) FOR i := 0 TO 4 DO (* RescueOnFace (Spin(p1.pyram[i][5]), Enext_1(p2.tetra[4-i][3]));*) EVAL Glue (Spin(p1.pyram[i][5]), Enext_1(p2.tetra[4-i][3]), 1); (* RescueOnFace (Clock(Enext(p2.pyram[4-i][3])), p1.tetra[i][0]); *) EVAL Glue (Clock(Enext(p2.pyram[4-i][3])), p1.tetra[i][0], 1); END; FOR i := 0 TO 4 DO f.pyram[i] := p1.pyram[i]; f.tetra[i] := p1.tetra[i]; END; FOR i := 5 TO 9 DO f.pyram[i] := p2.pyram[9-i]; f.tetra[i] := p2.tetra[9-i]; END; (* assertions *) FOR i := 0 TO 4 DO <* ASSERT Fnext(Enext(f.pyram[i,6])) = Clock(Enext_1(f.pyram[i,2])) *> END; FOR i := 5 TO 9 DO <* ASSERT Fnext(Enext(f.pyram[i,6])) = Clock(Enext_1(f.pyram[i,2])) *> END; RETURN f; END; END MakeRow; PROCEDURE MakeRowAtom1() : Free = VAR f : Free; BEGIN f.tetra := NEW(REF ARRAY OF PAIR, 1, 4); f.pyram := NEW(REF ARRAY OF PAIR, 1, 8); WITH g = GluePyramidTetra() DO f.pyram[0] := g.pyram[0]; f.tetra[0] := g.tetra[0]; RETURN f; END; END MakeRowAtom1; PROCEDURE MakeRowAtom2() : Free = VAR f : Free; BEGIN f.tetra := NEW(REF ARRAY OF PAIR, 2, 4); f.pyram := NEW(REF ARRAY OF PAIR, 2, 8); WITH g = GluePyramidTetra(), r = MakeRowAtom1() DO (* only one gluing g <---> r g.pyram[0][7] <--> r.tetra[0][2] *) (* RescueOnFace(Spin(g.pyram[0][7]), Enext_1(r.tetra[0][2])); *) EVAL Glue (Spin(g.pyram[0][7]), Enext_1(r.tetra[0][2]), 1); f.pyram[0] := r.pyram[0]; f.tetra[0] := r.tetra[0]; f.pyram[1] := g.pyram[0]; f.tetra[1] := g.tetra[0]; RETURN f; END; END MakeRowAtom2; PROCEDURE MakeRowAtom3() : Free = VAR f : Free; BEGIN f.tetra := NEW(REF ARRAY OF PAIR, 3, 4); f.pyram := NEW(REF ARRAY OF PAIR, 3, 8); WITH g = GluePyramidTetra(), r = MakeRowAtom2() DO (* only one gluing g <---> r g.pyram[0][7] <--> r.tetra[1][2] *) (* RescueOnFace(Spin(g.pyram[0][7]), Enext_1(r.tetra[1][2])); *) EVAL Glue (Spin(g.pyram[0][7]), Enext_1(r.tetra[1][2]), 1); FOR i := 0 TO 1 DO f.pyram[i] := r.pyram[i]; f.tetra[i] := r.tetra[i]; END; f.pyram[2] := g.pyram[0]; f.tetra[2] := g.tetra[0]; RETURN f; END; END MakeRowAtom3; PROCEDURE MakeRowAtom4() : Free = VAR f : Free; BEGIN f.tetra := NEW(REF ARRAY OF PAIR, 4, 4); f.pyram := NEW(REF ARRAY OF PAIR, 4, 8); WITH g = GluePyramidTetra(), r = MakeRowAtom3() DO (* only one gluing g <---> r g.pyram[0][7] <--> r.tetra[2][2] *) (* RescueOnFace(Spin(g.pyram[0][7]), Enext_1(r.tetra[2][2])); *) EVAL Glue (Spin(g.pyram[0][7]), Enext_1(r.tetra[2][2]), 1); FOR i := 0 TO 2 DO f.pyram[i] := r.pyram[i]; f.tetra[i] := r.tetra[i]; END; f.pyram[3] := g.pyram[0]; f.tetra[3] := g.tetra[0]; RETURN f; END; END MakeRowAtom4; PROCEDURE MakeRowAtom5() : Free = VAR f : Free; BEGIN f.tetra := NEW(REF ARRAY OF PAIR, 5, 4); f.pyram := NEW(REF ARRAY OF PAIR, 5, 8); WITH g = GluePyramidTetra(), r = MakeRowAtom4() DO (* only one gluing g <---> r g.pyram[0][7] <--> r.tetra[3][2] *) (* RescueOnFace(Spin(g.pyram[0][7]), Enext_1(r.tetra[3][2])); *) EVAL Glue (Spin(g.pyram[0][7]), Enext_1(r.tetra[3][2]), 1); FOR i := 0 TO 3 DO f.pyram[i] := r.pyram[i]; f.tetra[i] := r.tetra[i]; END; f.pyram[4] := g.pyram[0]; f.tetra[4] := g.tetra[0]; (* assertions *) FOR i := 0 TO 4 DO <* ASSERT Fnext(Enext(f.pyram[i,6])) = Clock(Enext_1(f.pyram[i,2])) *> END; RETURN f; END; END MakeRowAtom5; PROCEDURE MakeRowAtom(order: CARDINAL) : Pair = BEGIN CASE order OF | 1 => RETURN MakeRowAtom1( ).tetra[0][3]; | 2 => RETURN MakeRowAtom2( ).tetra[0][3]; | 3 => RETURN MakeRowAtom3( ).tetra[0][3]; | 4 => RETURN MakeRowAtom4( ).tetra[0][3]; | 5 => RETURN MakeRowAtom5( ).tetra[0][3]; ELSE RETURN Triangulation.MakeFacetEdge(); END END MakeRowAtom; PROCEDURE MakeSolidTorus() : REF ARRAY OF Pair = VAR ico : ARRAY [0..4 ] OF ARRAY [0..19] OF Pair; tet : ARRAY [0..49] OF ARRAY [0..7 ] OF Pair; s := NEW(REF ARRAY OF Pair, 100); BEGIN FOR i := 0 TO 4 DO ico[i] := Squared.MakeIcosahedronTriang(FALSE); END; FOR j := 0 TO 49 DO tet[j] := MakeTetraTopo(1,1); END; (* estrategia: tetrahedra 0 a 9 ligarao os icosaedros ico[0] e ico[1], tetrahedra 10 a 19 ligarao os icosaedros ico[1] e ico[2], tetrahedra 20 a 29 ligarao os icosaedros ico[2] e ico[3], tetrahedra 30 a 39 ligarao os icosaedros ico[3] e ico[4], tetrahedra 40 a 49 ligarao os icosaedros ico[4] e ico[0] *) (* link the tetrahedra 0-4 with the superior extremum of ico[0] pattern: tet[2] <--> ico[3] *) FOR i := 0 TO 4 DO EVAL Glue(Spin(ico[0][15+i]), tet[i,2], 1); END; (* link the tetrahedra 5-9 com o extremo inferior de ico[1] pattern: tet[3] <--> ico[2] *) FOR i := 5 TO 9 DO EVAL Glue(Spin(ico[1][i-5]) , tet[i,3], 1); END; (* link superior extremum of ico[0] with the inferior extremum of ico[1] *) (* RescueOnFace(Spin(Enext(tet[5][1])), tet[0,0]); *) EVAL Glue (Spin(Enext(tet[5][1])), tet[0,0], 1); (* RescueOnFace(Spin(tet[1][1]), Enext(tet[5][0])); *) EVAL Glue (Spin(tet[1][1]), Enext(tet[5][0]),1); (* RescueOnFace(Spin(Enext(tet[6][1])), tet[1,0]); *) EVAL Glue (Spin(Enext(tet[6][1])), tet[1,0], 1); (* RescueOnFace(Spin(tet[2][1]), Enext(tet[6][0])); *) EVAL Glue (Spin(tet[2][1]), Enext(tet[6][0]),1); (* RescueOnFace(Spin(Enext(tet[7][1])), tet[2,0]); *) EVAL Glue (Spin(Enext(tet[7][1])), tet[2,0], 1); (* RescueOnFace(Spin(tet[3][1]), Enext(tet[7][0])); *) EVAL Glue (Spin(tet[3][1]), Enext(tet[7][0]),1); (* RescueOnFace(Spin(Enext(tet[8][1])), tet[3,0]); *) EVAL Glue (Spin(Enext(tet[8][1])), tet[3,0], 1); (* RescueOnFace(Spin(tet[4][1]), Enext(tet[8][0])); *) EVAL Glue (Spin(tet[4][1]), Enext(tet[8][0]),1); (* RescueOnFace(Spin(Enext(tet[9][1])), tet[4,0]); *) EVAL Glue (Spin(Enext(tet[9][1])), tet[4,0], 1); (* RescueOnFace(Spin(tet[0][1]), Enext(tet[9][0])); *) EVAL Glue (Spin(tet[0][1]), Enext(tet[9][0]),1); (* link the tetrahedra 10-14 with the superior extremum of ico[1] pattern: tet[2] <--> ico[3] *) FOR i := 10 TO 14 DO EVAL Glue(Spin(ico[1][5+i]), tet[i,2], 1); END; (* link the tetrahedra 15-19 com o extremo inferior de ico[2] pattern: tet[3] <--> ico[2] *) FOR i := 15 TO 19 DO EVAL Glue(Spin(ico[2][i-15]) , tet[i,3], 1); END; (* link superior extremum of ico[1] with the inferior extremum of ico[2] *) (* RescueOnFace(Spin(Enext(tet[15][1])), tet[10,0]); *) EVAL Glue (Spin(Enext(tet[15][1])), tet[10,0], 1); (* RescueOnFace(Spin(tet[11][1]), Enext(tet[15][0])); *) EVAL Glue (Spin(tet[11][1]), Enext(tet[15][0]),1); (* RescueOnFace(Spin(Enext(tet[16][1])), tet[11,0]); *) EVAL Glue (Spin(Enext(tet[16][1])), tet[11,0], 1); (* RescueOnFace(Spin(tet[12][1]), Enext(tet[16][0])); *) EVAL Glue (Spin(tet[12][1]), Enext(tet[16][0]),1); (* RescueOnFace(Spin(Enext(tet[17][1])), tet[12,0]); *) EVAL Glue (Spin(Enext(tet[17][1])), tet[12,0], 1); (* RescueOnFace(Spin(tet[13][1]), Enext(tet[17][0])); *) EVAL Glue (Spin(tet[13][1]), Enext(tet[17][0]),1); (* RescueOnFace(Spin(Enext(tet[18][1])), tet[13,0]); *) EVAL Glue (Spin(Enext(tet[18][1])), tet[13,0], 1); (* RescueOnFace(Spin(tet[14][1]), Enext(tet[18][0])); *) EVAL Glue (Spin(tet[14][1]), Enext(tet[18][0]),1); (* RescueOnFace(Spin(Enext(tet[19][1])), tet[14,0]); *) EVAL Glue (Spin(Enext(tet[19][1])), tet[14,0], 1); (* RescueOnFace(Spin(tet[10][1]), Enext(tet[19][0])); *) EVAL Glue (Spin(tet[10][1]), Enext(tet[19][0]),1); (* link the tetrahedra 10-14 with the superior extremum of ico[1] pattern: tet[2] <--> ico[3] *) FOR i := 10 TO 14 DO EVAL Glue(Spin(ico[1][5+i]), tet[i,2], 1); END; (* link the tetrahedra 15-19 om o extremo inferior de ico[2] pattern: tet[3] <--> ico[2] *) FOR i := 15 TO 19 DO EVAL Glue(Spin(ico[2][i-15]) , tet[i,3], 1); END; (* link superior extremum of ico[2] with the inferior extremum of ico[3] *) (* RescueOnFace(Spin(Enext(tet[15][1])), tet[10,0]); *) EVAL Glue (Spin(Enext(tet[15][1])), tet[10,0], 1); (* RescueOnFace(Spin(tet[11][1]), Enext(tet[15][0])); *) EVAL Glue (Spin(tet[11][1]), Enext(tet[15][0]),1); (* RescueOnFace(Spin(Enext(tet[16][1])), tet[11,0]); *) EVAL Glue (Spin(Enext(tet[16][1])), tet[11,0], 1); (* RescueOnFace(Spin(tet[12][1]), Enext(tet[16][0])); *) EVAL Glue (Spin(tet[12][1]), Enext(tet[16][0]),1); (* RescueOnFace(Spin(Enext(tet[17][1])), tet[12,0]); *) EVAL Glue (Spin(Enext(tet[17][1])), tet[12,0], 1); (* RescueOnFace(Spin(tet[13][1]), Enext(tet[17][0])); *) EVAL Glue (Spin(tet[13][1]), Enext(tet[17][0]),1); (* RescueOnFace(Spin(Enext(tet[18][1])), tet[13,0]); *) EVAL Glue (Spin(Enext(tet[18][1])), tet[13,0], 1); (* RescueOnFace(Spin(tet[14][1]), Enext(tet[18][0])); *) EVAL Glue (Spin(tet[14][1]), Enext(tet[18][0]),1); (* RescueOnFace(Spin(Enext(tet[19][1])), tet[14,0]); *) EVAL Glue (Spin(Enext(tet[19][1])), tet[14,0], 1); (* RescueOnFace(Spin(tet[10][1]), Enext(tet[19][0])); *) EVAL Glue (Spin(tet[10][1]), Enext(tet[19][0]),1); (* link the tetrahedra 20-24 with the superior extremum of ico[2] pattern: tet[2] <--> ico[3] *) FOR i := 20 TO 24 DO EVAL Glue(Spin(ico[2][i-5]), tet[i,2], 1); END; (* link the tetrahedra 15-19 cwith the inferior extremum of ico[3] pattern: tet[3] <--> ico[2] *) FOR i := 25 TO 29 DO EVAL Glue(Spin(ico[3][i-25]) , tet[i,3], 1); END; (* link superior extremum of ico[3] with the inferior extremum of ico[4] *) (* RescueOnFace(Spin(Enext(tet[25][1])), tet[20,0]); *) EVAL Glue (Spin(Enext(tet[25][1])), tet[20,0], 1); (* RescueOnFace(Spin(tet[21][1]), Enext(tet[25][0])); *) EVAL Glue (Spin(tet[21][1]), Enext(tet[25][0]),1); (* RescueOnFace(Spin(Enext(tet[26][1])), tet[21,0]); *) EVAL Glue (Spin(Enext(tet[26][1])), tet[21,0], 1); (* RescueOnFace(Spin(tet[22][1]), Enext(tet[26][0])); *) EVAL Glue (Spin(tet[22][1]), Enext(tet[26][0]),1); (* RescueOnFace(Spin(Enext(tet[27][1])), tet[22,0]); *) EVAL Glue (Spin(Enext(tet[27][1])), tet[22,0], 1); (* RescueOnFace(Spin(tet[23][1]), Enext(tet[27][0])); *) EVAL Glue (Spin(tet[23][1]), Enext(tet[27][0]),1); (* RescueOnFace(Spin(Enext(tet[28][1])), tet[23,0]); *) EVAL Glue (Spin(Enext(tet[28][1])), tet[23,0], 1); (* RescueOnFace(Spin(tet[24][1]), Enext(tet[28][0])); *) EVAL Glue (Spin(tet[24][1]), Enext(tet[28][0]),1); (* RescueOnFace(Spin(Enext(tet[29][1])), tet[24,0]); *) EVAL Glue (Spin(Enext(tet[29][1])), tet[24,0], 1); (* RescueOnFace(Spin(tet[20][1]), Enext(tet[29][0])); *) EVAL Glue (Spin(tet[20][1]), Enext(tet[29][0]),1); (* link the tetrahedra 30-34 with the superior extremum of ico[3] pattern: tet[2] <--> ico[3] *) FOR i := 30 TO 34 DO EVAL Glue(Spin(ico[3][i-15]), tet[i,2], 1); END; (* link the tetrahedra 35-39 with the inferior extremum of ico[4] pattern: tet[3] <--> ico[2] *) FOR i := 35 TO 39 DO EVAL Glue(Spin(ico[4][i-35]) , tet[i,3], 1); END; (* link superior extremum of ico[4] with the inferior extremum of ico[0] *) (* RescueOnFace(Spin(Enext(tet[35][1])), tet[30,0]); *) EVAL Glue (Spin(Enext(tet[35][1])), tet[30,0], 1); (* RescueOnFace(Spin(tet[31][1]), Enext(tet[35][0])); *) EVAL Glue (Spin(tet[31][1]), Enext(tet[35][0]),1); (* RescueOnFace(Spin(Enext(tet[36][1])), tet[31,0]); *) EVAL Glue (Spin(Enext(tet[36][1])), tet[31,0], 1); (* RescueOnFace(Spin(tet[32][1]), Enext(tet[36][0])); *) EVAL Glue (Spin(tet[32][1]), Enext(tet[36][0]),1); (* RescueOnFace(Spin(Enext(tet[37][1])), tet[32,0]); *) EVAL Glue (Spin(Enext(tet[37][1])), tet[32,0], 1); (* RescueOnFace(Spin(tet[33][1]), Enext(tet[37][0])); *) EVAL Glue (Spin(tet[33][1]), Enext(tet[37][0]),1); (* RescueOnFace(Spin(Enext(tet[38][1])), tet[33,0]); *) EVAL Glue (Spin(Enext(tet[38][1])), tet[33,0], 1); (* RescueOnFace(Spin(tet[34][1]), Enext(tet[38][0])); *) EVAL Glue (Spin(tet[34][1]), Enext(tet[38][0]),1); (* RescueOnFace(Spin(Enext(tet[39][1])), tet[34,0]); *) EVAL Glue (Spin(Enext(tet[39][1])), tet[34,0], 1); (* RescueOnFace(Spin(tet[30][1]), Enext(tet[39][0])); *) EVAL Glue (Spin(tet[30][1]), Enext(tet[39][0]),1); (* link the tetrahedra 40-44 with the superior extremum of ico[4] pattern: tet[2] <--> ico[3] *) FOR i := 40 TO 44 DO EVAL Glue(Spin(ico[4][i-25]), tet[i,2], 1); END; (* link the tetrahedra 45-49 with the inferior extremum of ico[0] pattern: tet[3] <--> ico[2] *) FOR i := 45 TO 49 DO EVAL Glue(Spin(ico[0][i-45]) , tet[i,3], 1); END; (* link superior extremum of ico[3] with the inferior extremum of ico[4] *) (* RescueOnFace(Spin(Enext(tet[45][1])), tet[40,0]); *) EVAL Glue (Spin(Enext(tet[45][1])), tet[40,0], 1); (* RescueOnFace(Spin(tet[41][1]), Enext(tet[45][0])); *) EVAL Glue (Spin(tet[41][1]), Enext(tet[45][0]),1); (* RescueOnFace(Spin(Enext(tet[46][1])), tet[41,0]); *) EVAL Glue (Spin(Enext(tet[46][1])), tet[41,0], 1); (* RescueOnFace(Spin(tet[42][1]), Enext(tet[46][0])); *) EVAL Glue (Spin(tet[42][1]), Enext(tet[46][0]),1); (* RescueOnFace(Spin(Enext(tet[47][1])), tet[42,0]); *) EVAL Glue (Spin(Enext(tet[47][1])), tet[42,0], 1); (* RescueOnFace(Spin(tet[43][1]), Enext(tet[47][0])); *) EVAL Glue (Spin(tet[43][1]), Enext(tet[47][0]),1); (* RescueOnFace(Spin(Enext(tet[48][1])), tet[43,0]); *) EVAL Glue (Spin(Enext(tet[48][1])), tet[43,0], 1); (* RescueOnFace(Spin(tet[44][1]), Enext(tet[48][0])); *) EVAL Glue (Spin(tet[44][1]), Enext(tet[48][0]),1); (* RescueOnFace(Spin(Enext(tet[49][1])), tet[44,0]); *) EVAL Glue (Spin(Enext(tet[49][1])), tet[44,0], 1); (* RescueOnFace(Spin(tet[40][1]), Enext(tet[49][0])); *) EVAL Glue (Spin(tet[40][1]), Enext(tet[49][0]),1); (* the pair that will be returned as: I0 : T9-10 : I1 : T10-19 : I2 : T20-29 : I3 : T30-39 : I4 : T40-49 10 10 10 10 10 10 10 10 10 10 Fon each icosahedron the pairs follow the pattern: 5 --- 6 --- 7 --- 8 --- 9 10 11 12 13 14 |_______________________| tetrahedra follow the pattern: Is -------------- T:0,1,2,3,4[3] --> free T:5,6,7,8,9[2] --- Ii --> free *) FOR i := 0 TO 9 DO s[i] := ico[0][i+5] END; FOR i := 20 TO 29 DO s[i] := ico[1][i-15] END; FOR i := 40 TO 49 DO s[i] := ico[2][i-35] END; FOR i := 60 TO 69 DO s[i] := ico[3][i-55] END; FOR i := 80 TO 89 DO s[i] := ico[4][i-75] END; FOR i := 10 TO 14 DO s[i] := tet[i-10][3] END; FOR i := 15 TO 19 DO s[i] := tet[i-10][2] END; FOR i := 30 TO 34 DO s[i] := tet[i-20][3] END; FOR i := 35 TO 39 DO s[i] := tet[i-20][2] END; FOR i := 50 TO 54 DO s[i] := tet[i-30][3] END; FOR i := 55 TO 59 DO s[i] := tet[i-30][2] END; FOR i := 70 TO 74 DO s[i] := tet[i-40][3] END; FOR i := 75 TO 79 DO s[i] := tet[i-40][2] END; FOR i := 90 TO 94 DO s[i] := tet[i-50][3] END; FOR i := 95 TO 99 DO s[i] := tet[i-50][2] END; FOR i := 0 TO 4 DO <* ASSERT Fnext(Enext(s[i])) = Spin(Enext_1(s[i+5])) *> END; FOR i := 10 TO 14 DO <* ASSERT Fnext(Enext(s[i])) = Spin(Enext_1(s[i+5])) *> END; FOR i := 20 TO 24 DO <* ASSERT Fnext(Enext(s[i])) = Spin(Enext_1(s[i+5])) *> END; FOR i := 30 TO 34 DO <* ASSERT Fnext(Enext(s[i])) = Spin(Enext_1(s[i+5])) *> END; FOR i := 40 TO 44 DO <* ASSERT Fnext(Enext(s[i])) = Spin(Enext_1(s[i+5])) *> END; FOR i := 50 TO 54 DO <* ASSERT Fnext(Enext(s[i])) = Spin(Enext_1(s[i+5])) *> END; FOR i := 60 TO 64 DO <* ASSERT Fnext(Enext(s[i])) = Spin(Enext_1(s[i+5])) *> END; FOR i := 70 TO 74 DO <* ASSERT Fnext(Enext(s[i])) = Spin(Enext_1(s[i+5])) *> END; FOR i := 80 TO 84 DO <* ASSERT Fnext(Enext(s[i])) = Spin(Enext_1(s[i+5])) *> END; FOR i := 90 TO 94 DO <* ASSERT Fnext(Enext(s[i])) = Spin(Enext_1(s[i+5])) *> END; FOR i := 0 TO 4 DO <* ASSERT Fnext(s[i]) = Spin(s[i+95]) *> END; FOR i := 10 TO 14 DO <* ASSERT Fnext(s[i]) = Spin(s[i-5]) *> END; FOR i := 20 TO 24 DO <* ASSERT Fnext(s[i]) = Spin(s[i-5]) *> END; FOR i := 30 TO 34 DO <* ASSERT Fnext(s[i]) = Spin(s[i-5]) *> END; FOR i := 40 TO 44 DO <* ASSERT Fnext(s[i]) = Spin(s[i-5]) *> END; FOR i := 50 TO 54 DO <* ASSERT Fnext(s[i]) = Spin(s[i-5]) *> END; FOR i := 60 TO 64 DO <* ASSERT Fnext(s[i]) = Spin(s[i-5]) *> END; FOR i := 70 TO 74 DO <* ASSERT Fnext(s[i]) = Spin(s[i-5]) *> END; FOR i := 80 TO 84 DO <* ASSERT Fnext(s[i]) = Spin(s[i-5]) *> END; FOR i := 90 TO 94 DO <* ASSERT Fnext(s[i]) = Spin(s[i-5]) *> END; RETURN s; END MakeSolidTorus; PROCEDURE MakePyramid() : Free = VAR f : Free; BEGIN f.pyram := NEW(REF ARRAY OF PAIR, 1, 8); WITH a = MakeTetraTopo(1,1), b = MakeTetraTopo(1,1) DO EVAL Glue(Spin(a[1]),b[0],1); FOR j := 0 TO 3 DO f.pyram[0][j] := a[j]; END; FOR j := 4 TO 7 DO f.pyram[0][j] := b[j-4]; END END; (* assertions *) <* ASSERT Fnext(Enext(f.pyram[0,6])) = Clock(Enext_1(f.pyram[0,2])) *> RETURN f; (* Warning: note that the pair c[1][0] = b[0] was deleted from the topology, their use will produce NIL. *) END MakePyramid; PROCEDURE GluePyramidTetra() : Free = (* This procedure glue one pyramid more one tetrahedron. Note that this procedure es equal to the gluing of one tetrahedron more one pyramid. *) VAR f : Free; BEGIN f.tetra := NEW(REF ARRAY OF PAIR, 1, 4); f.pyram := NEW(REF ARRAY OF PAIR, 1, 8); WITH te = MakeTetraTopo(1,1), py = MakePyramid() DO (* make the gluing : py[0][0] <---> te[1] *) EVAL Glue(Spin(te[1]), py.pyram[0][0], 1); (* rescuing the pairs : First the pairs derived from the MakePyramid procedure. Second the pairs of the tetrahedron te. *) FOR i := 0 TO 7 DO f.pyram[0][i] := py.pyram[0][i]; END; FOR j := 0 TO 3 DO f.tetra[0][j] := te[j]; END END; RETURN f; (* Warning: note that the pairs: a[0][0]=py[0][0] and a[1][0]=py[1][0], was deleted from the topology, their use will produce NIL. *) END GluePyramidTetra; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-shape"); o.shapeName := pp.getNext(); IF Text.Equal(o.shapeName, "solid") THEN o.shape := Shape.SolidTorus ELSIF Text.Equal(o.shapeName, "hollow") THEN o.shape := Shape.HollowTorus ELSIF Text.Equal(o.shapeName, "cell600") THEN o.shape := Shape.cell600 ELSIF Text.Equal(o.shapeName, "rowatom") THEN o.shape := Shape.RowAtom; pp.getKeyword("-order"); o.order := pp.getNextInt(1, 5); ELSIF Text.Equal(o.shapeName, "row") THEN o.shape := Shape.Row; ELSIF Text.Equal(o.shapeName, "tube") THEN o.shape := Shape.Tube ELSE pp.error("Bad shape \"" & pp.getNext() & "\"\n") END; pp.getKeyword("-outFile"); o.outFile := pp.getNext(); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: Build600Cell \\\n"); Wr.PutText(stderr, " -shape { solid | hollow | rowatom -order | ... }\\\n"); Wr.PutText(stderr, " -outFile \n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt(); END Build600Cell. (*************************************************************************** From: dtd@world.std.com (Don Davis) Subject: 600-cell from two tori (long) Date: Wed, 8 Sep 1999 22:35:27 GMT Newsgroups: sci.math Keywords: construction of 120-cell and 600-cell (solids in R^4) In article <7r5bil$elq$1@mail.pl.unisys.com>, "Clive Tooth" wrote: > I wonder if the same approach could be used to illustrate the > construction of a 600-cell. My first reaction is that the tetra- > hedron is too "pointy" to make nice-looking diagrams, but maybe not... i have a more-or-less simple-to-visualize construction of the 600-cell, which i figured out last winter (it took me a while). i also found, in writing this up, that a similar construction also makes the 120-cell even easier to visualize. i have looked around on the web, and haven't seen anything as easy as my technique. i must admit i am very pleased with it. i don't have pictures yet, but here's a quickie description, without any proofs: the 600-cell construction has three parts: two solid tori of 150 cells each, and a hollow torus of 300 cells. build each solid torus as follows: using 100 tetrahedra, assemble 5 solid icosahedra (this is possible in R^4). daisy-chain five such icosahedra pole-to-pole. between every pair of adjacent icosahedra, surround the common vertex with 10 tetrahedra. each solid torus has a decagonal "axis" running through the centers and poles of the icosa- hedra. each solid torus contains 5*20 + 5*10 = 150 tetra- hedra, and its surface is tiled with 100 equilateral triangles. on this surface, six triangles meet at every vertex. we will link these solid tori, like two links of a chain. with the hollow torus acting as a glue layer between them. build the hollow torus as follows: lay out a 5x10 grid of unit edges. omit the left-hand and lower boundaries' edges, because we're going to roll this grid into a torus later. thus, the grid contains 100 edges: 50 running N-S, and 50 running E-W. attach one tetrahedron to each edge from above the grid. the opposite edges of these tetrahedra will form a new 5x10 grid, whose vertices overlie the centers of the squares in the lower grid. thus, these 100 tetrahedra now form an egg-carton shape, with 50 square-pyramid cups on each side. divide each cup into two non-unit tetrahedra, by erecting a right-triangular wall across the cup, corner-to-corner. make the upper cups' dividers run NE/SW, and make the upside-down lower cups' dividers run NW/SE. note that the egg-carton is now a solid flat layer, one tetrahedron deep, containing 100 unit tetra- hedra and 200 non-unit tetrahedra. when we shrink the right-triangular dividing walls into equilateral triangles, we distort each egg-cup into a pair of unit-tetrahedra. at the same time, the opening of each egg-cup changes from a square to a bent rhombus. as the square openings bend, the flat sheet of 300 tethrahedra is forced to wrap around into a hollow torus with a one-unit- thick shell. surprisingly, this bends each 5x10 grid into a toroidal sheet of 100 equilateral triangles. each grid's short edge is now a pentagon that threads through the donut hole. the grid's long edge is now a decagon that wraps around both holes in its donut. the two grids' long edges are now linked decagons. this wrapping cannot occur in R^3, but it works fine in R^4. i admit that this part of my presentation is not easy to visualize. perhaps a localized visualization image will help: as an upper egg-cup is squeezed in one direction, the edge-tetrahedra around it rotate, squeezing the nearby lower egg-cups in the other direction. this forces the flat sheet into a saddle-shape. in R^4, when this saddle-bending happens across the whole egg-carton at once, the carton's edges can meet to make the toroidal sheet. finally, put one solid torus inside the hollow toroidal sheet, attaching the 100 triangular faces of the solid to the 100 triangles of the sheet's inner surface. this gives us a fat solid torus, 10 units around and 4 units thick, containing 450 tetrahedral cells. nevertheless, its surface has only 100 triangular faces. thread the second 150-cell solid torus through this fat torus, and attach the two solids' triangular faces. this is the 600-cell polytope. symmetry: recall the decagonal "axes" of the original 150-cell solid tori. these two linked decagons are now the equators of a 3-sphere in R^4. the equators are 3 units apart. all of the grids' N/S unit edges are linked up into decagons, too. indeed, each edge in the 600 cell is part of a unique planar decagon that girdles the figure. there are (600*6)/5 = 720 edges in all, so 72 such decagons criscross the 600-cell. it's a beautiful fact that these decagons can be grouped into sets of 12, s.t. the 12 decagons trace the linked circles of a Hopf fibration of S^3! for each of the 6 vertex-to- vertex rotational axes of the icosahedron, there are two arrangements of these 12 decagons: * through each axis there is exactly one equatorial decagon; * linked with this equatorial decagon are 5 decagons, wrapped around the equator in a barber-pole pattern; * 5 more decagons are wrapped around the barber-pole in the same direction, but in a shallower spiral; * the second equatorial decagon girdles the lot, in a plane perpendicular to the first equator. there are two such wrappings for each axis, because the barber pole can carry a left-handed or a right-handed stripe. thus, the 600-cell presents 12 distinct Hopf fibrations of itself. -------==================------- in general, this "stitch 2 tori together" approach can be very natural for visualising the complicated polytopes of 3-d cells, since the tori display the S^3 symmetry enjoyed by these shapes. for example, it's nicer to con- sider the tesseract as two linked rings of 4 cubes, than as a russian doll of nestled cubes, or as a 3-D cross. note that the 600-cell has (600*4)/20 = 120 vertices, and it is the dual of the 120-cell. thus, it is straight- forward to assemble the 120-cell in an analogous but easier way, starting with two simple rings of 10 dodecahedra apiece. each ring has 10 neck-like indentations between pairs of dodecahedra. we cover each neck with 5 dodecahedra, making two bumpy tori of 60 cells apiece. the bumps and hollows form a simple square-grid arrangement on the surface of each torus. link these tori, and stitch them together, fitting the bumps of one torus into the hollows of the other. this bumpy interface between the two tori is a semi- regular toroidal surface, comprising 50*4 = 200 regular pentagons. three pentagons meet at each vertex in the concave and convex parts of the surface, but in the saddle- shaped parts, four pentagons meet at each vertex. when we project this tesselation onto the plane, we get a familiar tiling of irregular pentagons. in this projection, each pentagon has two right angles and three 120-degree angles, and four pentagons are arranged to form a squat hexagon. these hexagons tile the plane (and thus the toroidal surface) in the usual way (you'll need a fixed-width font here): :, ,: :, ,: :, ,: __/ "|" \___/ "|" \___/ "|" \___ \ ,|, / \ ,|, / \ ,|, / ,:" ":, ,:" ":, ,:" ":, |" \___/ "|" \___/ "|" \___/ "|" |, / \ ,|, / \ ,|, / \ ,|, ":, ,:" ":, ,:" ":, ,:" __/ "|" \___/ "|" \___/ "|" \___ \ ,|, / \ ,|, / \ ,|, / ,:" ":, ,:" ":, ,:" ":, |" \___/ "|" \___/ "|" \___/ "|" |, / \ ,|, / \ ,|, / \ ,|, ":, ,:" ":, ,:" ":, ,:" __/ "|" \___/ "|" \___/ "|" \___ \ ,|, / \ ,|, / \ ,|, / ,:" ":, ,:" ":, ,:" ":, |" \___/ "|" \___/ "|" \___/ "|" |, / \ ,|, / \ ,|, / \ ,|, ":, ,:" ":, ,:" ":, ,:" __/ "|" \___/ "|" \___/ "|" \___ in this diagram, suppose that the ring of 10 dodecahedra is running vertically inside its sheath of 50 dodecahedra, whose exposed facets appear as irregular pentagons. then the horizontal edges are at the tops of the bumps in the surface, while the vertical edges are at the bottoms of the hollows. thus, the fat torus of 60 dodecahedra is covered with 10 rows of squat hexagons, with 5 hexagons in each row. similarly, this pattern is overlaid with 10 columns of tall hexagons, with 5 hexagons in each column. together, these overlaid patterns show that the two fat 60-cell tori can indeed be fit together, facet-to-facet and bump-into-hollow. while every edge in the 600-cell is part of exactly one decagon, every dodecahedron in the 120-cell is part of 6 different 10-cell ring. the 120-cell can be parti- tioned into 12 linked rings, pairwise nearly parallel, so that the rings again trace the circles of the Hopf fibration. there 12 ways to perform this Hopf-like partition of the 120-cell. these 12 arrangements of rings correspond exactly to the 12 Hopf-like arrange- ments of decagons in the 600-cell. - don davis, boston *************************************************************) (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/BuildRefinement.m3 MODULE BuildRefinement EXPORTS Main; (* This module builds a refinement of a triangulation $T$ exchanging each single tetrahedron of $T$ by a $K$-refined tetrahedron as created by the "Refine" procedure on the library "libm3subi". *) IMPORT Thread, Wr, Process, Triangulation, Octf, ParseParams, Fmt, Refine, LR4, Text, Stdio; FROM Triangulation IMPORT Pair, Pneg, Ppos, OrgV, Vertex, Edge, Face, WriteState; FROM Octf IMPORT Spin, Clock, Tors, Enext, Enext_1, Fnext_1; FROM Stdio IMPORT stderr; FROM Refine IMPORT MakeTetra; FROM Fmt IMPORT Pad, Int; FROM LR4 IMPORT Scale, Add; TYPE Options = RECORD inFileTp : TEXT; (* Input file name (minus extensions) *) inFileSt : TEXT; (* Input file name (minus extensions) *) outFile : TEXT; (* Output file name prefix *) order : CARDINAL; (* order of the refinement *) detail : BOOLEAN; (* print some detail information *) fixed : BOOLEAN; (* retain the previus geometry *) net : BOOLEAN; (* drawing each existing face as a net with small spheres and thin cylinders *) END; Corner = ARRAY [0..23] OF Pair; Report = RECORD bo : BOOLEAN; tu : ARRAY[0..1] OF INTEGER; END; PAIR = ARRAY OF Pair; CENTER = ARRAY OF Vertex; PROCEDURE MyAssert(READONLY p: LR4.T) = BEGIN <* ASSERT NOT( (p[0] = 0.0d0) AND (p[1] = 0.0d0) AND (p[2] = 0.0d0) AND (p[3] = 0.0d0) ) *> END MyAssert; PROCEDURE AreGlued(a,b: Pair) : BOOLEAN = (* This procedure return TRUE iff the corners (pairs) "a" e "b" are glued in the original triangulation $T$; otherwise return FALSE. *) PROCEDURE PolyhedraInfo() : BOOLEAN = (* First step: We need to compare the polyhedra information. *) BEGIN IF (Ppos(a) = Pneg(b)) AND (Ppos(b) = Pneg(a)) THEN RETURN TRUE; ELSE RETURN FALSE END; END PolyhedraInfo; PROCEDURE VerticesInfo() : BOOLEAN = (* Second step: We need to compare the vertices information. *) BEGIN IF (OrgV(a) = OrgV(b)) AND (OrgV(Enext(a)) = OrgV(Enext(b))) AND (OrgV(Enext_1(a)) = OrgV(Enext_1(b))) THEN RETURN TRUE ELSE RETURN FALSE END; END VerticesInfo; BEGIN IF PolyhedraInfo() THEN IF VerticesInfo() THEN <* ASSERT a = Spin(b) AND b = Spin(a) *> RETURN TRUE END END; RETURN FALSE; END AreGlued; PROCEDURE MidOcta(a: Pair) : Vertex = (* Return a vertex that is the medial vertex of an triangulated octahedron. This vertex has a "VP" label as type. *) BEGIN WITH v = OrgV(Enext_1(Fnext_1(Fnext_1(a)))) DO v.label := "VP"; RETURN v END END MidOcta; PROCEDURE InterVertex(a: Pair) : Vertex = (* Return a vertex that is a internal to the macro-tetrahedron. This vertex is located on a edge and face and present only in order greater than four. This vertex has a "VP" label as type. *) BEGIN WITH v = OrgV(Enext_1(Fnext_1(a))) DO v.label := "FE"; RETURN v END END InterVertex; PROCEDURE AreGluedCorners(READONLY ca,cb: Corner) : Report = (* This procedure return TRUE iff the tetrahedra with corners "ca" and "cb" must be glued. *) VAR re : Report; BEGIN FOR i := 0 TO 23 DO FOR j := 0 TO 23 DO IF AreGlued(ca[i],cb[j]) THEN re.bo := TRUE; re.tu[0] := i; re.tu[1] := j; END END END; RETURN re; END AreGluedCorners; PROCEDURE DoIt() = <* FATAL Thread.Alerted, Wr.Failure *> VAR newtop: Triangulation.Topology; vme : REF ARRAY OF CENTER; (* Array of mid vertex of octahedra *) vin : REF ARRAY OF CENTER; (* An array of internal vertex *) nvv,nve,nvf,nvp,nfe: CARDINAL := 0; (* numbers vertices of each type *) nov,noe,nof,nop : CARDINAL := 0; BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToMa(o.inFileTp), top = tc.top, co = NEW(REF ARRAY OF Corner, top.NP), nco = NEW(REF ARRAY OF Refine.Corner, top.NP), rc = Triangulation.ReadState(o.inFileSt), c = rc^ DO (* Assertion *) IF top.der # 3 THEN Wr.PutText(stderr,"\nThis topology isn't a triangulation\n"); Process.Exit(1); END; Wr.PutText(stderr,"\n" & Fmt.Int(o.order) & "-Refining from: " & o.inFileTp & ".tp\n"); (* compute Corners table *) FOR i := 0 TO top.NP-1 DO WITH da = top.region[i], pa = Tors(da) DO co[i] := BuildCornerTable(pa); nco[i] := SubdivideTetrahedron(o.order, pa, o.net, top); END; IF o.detail THEN Wr.PutText(stderr, "tetrahedron " & Fmt.Int(i) & ":\n"); PrintCornerTable(co[i]); END END; (* save memory for the medial and internal vertices .*) IF o.order = 1 THEN vme := NEW(REF ARRAY OF CENTER, top.NP, 0); ELSIF o.order = 2 THEN vme := NEW(REF ARRAY OF CENTER, top.NP, 1); ELSIF o.order = 3 THEN vme := NEW(REF ARRAY OF CENTER, top.NP, 4); ELSIF o.order = 4 THEN vme := NEW(REF ARRAY OF CENTER, top.NP, 10); vin := NEW(REF ARRAY OF CENTER, top.NP, 1); ELSIF o.order = 5 THEN vme := NEW(REF ARRAY OF CENTER, top.NP, 20); vin := NEW(REF ARRAY OF CENTER, top.NP, 4); END; FOR i := 0 TO top.NP-1 DO IF o.order = 2 THEN vme[i][0] := MidOcta(nco[i].front[0]); ELSIF o.order = 3 THEN vme[i][ 0] := MidOcta(nco[i].front[ 0]); vme[i][ 1] := MidOcta(nco[i].front[ 1]); vme[i][ 2] := MidOcta(nco[i].front[ 3]); vme[i][ 3] := MidOcta(nco[i].back [ 0]); ELSIF o.order = 4 THEN vme[i][ 0] := MidOcta(nco[i].front[ 0]); vme[i][ 1] := MidOcta(nco[i].front[ 1]); vme[i][ 2] := MidOcta(nco[i].front[ 3]); vme[i][ 3] := MidOcta(nco[i].front[ 4]); vme[i][ 4] := MidOcta(nco[i].front[ 6]); vme[i][ 5] := MidOcta(nco[i].front[ 8]); vme[i][ 6] := MidOcta(nco[i].back [ 0]); vme[i][ 7] := MidOcta(nco[i].right[ 6]); vme[i][ 8] := MidOcta(nco[i].right[13]); vme[i][ 9] := MidOcta(nco[i].left [13]); (* *) vin[i][ 0] := InterVertex(nco[i].front[6]); ELSIF o.order = 5 THEN vme[i][ 0] := MidOcta(nco[i].front[ 0]); vme[i][ 1] := MidOcta(nco[i].front[ 1]); vme[i][ 2] := MidOcta(nco[i].front[ 3]); vme[i][ 3] := MidOcta(nco[i].front[ 4]); vme[i][ 4] := MidOcta(nco[i].front[ 6]); vme[i][ 5] := MidOcta(nco[i].front[ 8]); vme[i][ 6] := MidOcta(nco[i].front[ 9]); vme[i][ 7] := MidOcta(nco[i].front[11]); vme[i][ 8] := MidOcta(nco[i].front[13]); vme[i][ 9] := MidOcta(nco[i].front[15]); vme[i][10] := MidOcta(nco[i].back [ 0]); vme[i][11] := MidOcta(nco[i].right[11]); vme[i][12] := MidOcta(nco[i].right[20]); vme[i][13] := MidOcta(nco[i].right[ 6]); vme[i][14] := MidOcta(nco[i].right[13]); vme[i][15] := MidOcta(nco[i].right[22]); vme[i][16] := MidOcta(nco[i].left [20]); vme[i][17] := MidOcta(nco[i].left [13]); vme[i][18] := MidOcta(nco[i].left [22]); vme[i][19] := MidOcta(nco[i].back [ 6]); (* *) vin[i][ 0] := InterVertex(nco[i].front[ 6]); vin[i][ 1] := InterVertex(nco[i].front[11]); vin[i][ 2] := InterVertex(nco[i].front[13]); vin[i][ 3] := InterVertex(nco[i].right[11]); END END; (* compute that corners that must be glued *) FOR k := 0 TO top.NF-1 DO WITH f = top.face[k].pa, i = Triangulation.Ppos(f).num, j = Triangulation.Pneg(f).num DO IF (Triangulation.Ppos(f) # NIL) AND (Triangulation.Pneg(f) # NIL) THEN WITH re = AreGluedCorners(co[i],co[j]) DO IF re.bo THEN IF o.detail THEN Wr.PutText(stderr, "New Corners that must be glue :" & " NC[" & Pad(Int(i),3) &"," & Pad(Int(re.tu[0]),3)&"] and" & " NC[" & Pad(Int(j),3) &"," & Pad(Int(re.tu[1]),3)&"]\n"); END; WITH ar = Refine.PairsOnFrontier(nco[i], re.tu[0], o.order), br = Refine.PairsOnFrontier(nco[j], re.tu[1], o.order) DO GlueMacroTetrahedra(ar,br); END END END END END END; FOR i := 0 TO top.NV-1 DO WITH v = NARROW(top.vertex[i],Vertex), vl = v.label DO IF Text.Equal(vl,"VV") THEN INC(nov); ELSIF Text.Equal(vl,"VE") THEN INC(noe); ELSIF Text.Equal(vl,"VF") THEN INC(nof); ELSIF Text.Equal(vl,"VP") THEN INC(nop); END END END; newtop := Triangulation.MakeTopology(nco[0].right[0],1); FOR i := 0 TO newtop.NV-1 DO WITH v = NARROW(newtop.vertex[i],Vertex), vl = v.label DO IF Text.Equal(vl,"VV") THEN INC(nvv); ELSIF Text.Equal(vl,"VE") THEN INC(nve); ELSIF Text.Equal(vl,"VF") THEN INC(nvf); ELSIF Text.Equal(vl,"VP") THEN INC(nvp); ELSIF Text.Equal(vl,"FE") THEN INC(nfe); END END END; <* ASSERT newtop.NV = nvv + nve + nvf + nvp + nfe *> <* ASSERT nvv = nov *> IF o.order >= 2 THEN <* ASSERT nve = top.NE * (o.order-1) + noe *> END; IF o.order = 3 THEN <* ASSERT nvf = top.NF * 1 + nof *> ELSIF o.order = 4 THEN <* ASSERT nvf = top.NF * 3 + nof *> ELSIF o.order = 5 THEN <* ASSERT nvf = top.NF * 6 + nof *> END; (* useful assertion *) WITH o1 = o.order, o2 = o1*o1, o3 = o2*o1, cte = (5*o3-2*o1) DIV 3 DO <* ASSERT newtop.NP = top.NP * cte *> IF o.order = 1 THEN <* ASSERT nvp = top.NP * 0 + nop *> ELSIF o.order = 2 THEN <* ASSERT nvp = top.NP * 1 + nop *> ELSIF o.order = 3 THEN <* ASSERT nvp = top.NP * 4 + nop *> ELSIF o.order = 4 THEN <* ASSERT nvp = top.NP * 10 + nop *> <* ASSERT nfe = top.NP * 1 *> ELSIF o.order = 5 THEN <* ASSERT nvp = top.NP * 20 + nop *> <* ASSERT nfe = top.NP * 4 *> END END; WITH com = Fmt.Int(o.order) & "-Refined from: " & o.inFileTp & ".tp\n" & "Created by BuildRefinement: " & o.outFile & ".tp", ncord = SettingCoords(top, newtop,c,co,nco,o.order,vme,vin,o.net), rcord = Triangulation.GenCoords(newtop)^ DO Triangulation.WriteTopology (o.outFile, newtop, com); (*Triangulation.WriteTable (o.outFile, newtop, com);*) Triangulation.WriteMaterials(o.outFile, newtop, com); IF o.fixed THEN FOR i := 0 TO LAST(ncord^)-1 DO ncord[i] := LR4.Scale(FLOAT(1.0d0, LONGREAL), ncord[i]); END; WriteState(o.outFile&"-Fix",newtop,ncord^,com&": Fixed Geometry\n"); ELSE WriteState(o.outFile, newtop, rcord, com & ": Random Geometry\n"); END END END END DoIt; PROCEDURE BuildCornerTable(a : Pair) : Corner = (* This procedure builds an array of 24 facetedge pairs, such all elements on the array have the same negative polyhedron "Pneg". The pair "a" in the argument must be a pair that represent one tetrahe- dron of $T$ (in the primal space). *) VAR c : Corner; BEGIN WITH a0 = a, a1 = Enext(a0), a2 = Enext(a1), b0 = Spin(Fnext_1(a0)), c0 = Spin(Fnext_1(a1)), d0 = Spin(Fnext_1(a2)) DO (* the 24 elements on the array must have the same negative polyhedron. *) c[0 ] := a0; c[1 ] := Enext(a0); c[2 ] := Enext_1(a0); c[3 ] := b0; c[4 ] := Enext(b0); c[5 ] := Enext_1(b0); c[6 ] := c0; c[7 ] := Enext(c0); c[8 ] := Enext_1(c0); c[9 ] := d0; c[10] := Enext(d0); c[11] := Enext_1(d0); <* ASSERT c[0] = a *> (* basically the last 12 pairs in the "corner" array are the "spined- clocked" version of the firsts 12 pairs facetedges. *) FOR j := 1 TO 12 DO c[j+11] := Clock(Spin(c[j-1])); END; (* for assert that the 24 pairs facetedge have the same negative polyhedron. *) FOR m := 0 TO 23 DO FOR n := m+1 TO 23 DO <* ASSERT Pneg(c[m]) = Pneg(c[n]) *> END END END; RETURN c; END BuildCornerTable; PROCEDURE PrintCornerTable(READONLY ac : Corner) = (* Prints detail information about the macro-tetrahedra that must be glued. *) <* FATAL Thread.Alerted, Wr.Failure *> BEGIN FOR j := 0 TO 11 DO Wr.PutText(stderr,Fmt.Pad(Fmt.Int(j),6) & " "); END; Wr.PutText(stderr,"\n--------------------------------------------------" & "---------------------------------------\n"); FOR j := 0 TO 11 DO Octf.PrintPair(stderr, ac[j], 3, FALSE); END; Wr.PutText(stderr, "\ng\n"); FOR j := 12 TO 23 DO Wr.PutText(stderr,Fmt.Pad(Fmt.Int(j),6) & " "); END; Wr.PutText(stderr,"\n--------------------------------------------------" & "---------------------------------------\n"); FOR j := 12 TO 23 DO Octf.PrintPair(stderr, ac[j], 3, FALSE); END; Wr.PutText(stderr, "\n\n"); END PrintCornerTable; PROCEDURE SubdivideTetrahedron( order : CARDINAL; a : Pair; net : BOOLEAN; READONLY tp : Triangulation.Topology; ) : Refine.Corner = (* This procedure rescues the propiertes of the vertices, edges and faces belonging to the original tetrahedron represented by the pair "a", and expands this propiertes to the macro-tetrahedron. *) PROCEDURE InheritVertices(v,V: Vertex) = (* Inherits vertex propiertes.*) BEGIN V.exists := v.exists; V.fixed := v.fixed; V.color := v.color; V.transp := v.transp; V.radius := v.radius; V.label := v.label; END InheritVertices; PROCEDURE InheritEdges(e,E: Edge) = (* Inherits edge propiertes.*) BEGIN WITH ed = tp.edge[e.num] DO E.exists := ed.exists; E.color := ed.color; E.transp := ed.transp; E.radius := ed.radius; E.root := ed.root; END; END InheritEdges; PROCEDURE InheritFaces(f,F: Face) = (* Inherits face propiertes.*) BEGIN WITH fd = tp.face[f.num] DO F.exists := fd.exists; F.color := fd.color; F.transp := fd.transp; F.root := fd.root; END END InheritFaces; <* FATAL Thread.Alerted, Wr.Failure *> VAR co : Refine.Corner; BEGIN IF order = 1 THEN co := MakeTetra(1,net); ELSIF order = 2 THEN co := MakeTetra(2,net); ELSIF order = 3 THEN co := MakeTetra(3,net); ELSIF order = 4 THEN co := MakeTetra(4,net); ELSIF order = 5 THEN co := MakeTetra(5,net); ELSE Wr.PutText(stderr,"BuildRefinement: Order must be less equal to 5\n"); <* ASSERT order <= 5 *> END; WITH o2 = order*order, ve = Triangulation.TetraNegVertices(a), ed = Triangulation.TetraEdges(a), fa = Triangulation.TetraFaces(a), v0 = ve[0], v1 = ve[1], v2 = ve[2], v3 = ve[3], e0 = ed[0], e1 = ed[1], e2 = ed[2], e3 = ed[3], e4 = ed[4], e5 = ed[5], f0 = fa[0], f1 = fa[1], f2 = fa[2], f3 = fa[3], V0 = OrgV(Enext_1(co.back [0])), V1 = OrgV(Enext_1(co.front[0])), V2 = OrgV(Enext (co.front[o2-1])), V3 = OrgV(Enext_1(co.left [o2-1])) DO (* vertices *) InheritVertices(v0,V0); InheritVertices(v1,V1); InheritVertices(v2,V2); InheritVertices(v3,V3); (* faces *) FOR i := 0 TO o2-1 DO InheritFaces(f0, co.right[i].facetedge.face); InheritFaces(f1, co.left [i].facetedge.face); InheritFaces(f2, co.front[i].facetedge.face); InheritFaces(f3, co.back [i].facetedge.face); END; IF net THEN (* iff the face not exists then non exists the elements on the net. *) WITH f0e = tp.face[f0.num].exists, f1e = tp.face[f1.num].exists, f2e = tp.face[f2.num].exists, f3e = tp.face[f3.num].exists DO ModSetGrade(order,co,f0e,f1e,f2e,f3e); END END; (* edges : e0 *) FOR i := 1 TO order DO InheritEdges(e0, co.right[(i-1)*(i-1)].facetedge.edge); END; IF NOT tp.edge[e0.num].exists THEN FOR i := 1 TO order-1 DO OrgV(co.right[(i-1)*(i-1)]).exists := FALSE; END END; WITH cor = tp.edge[e0.num].color DO FOR i := 1 TO order-1 DO OrgV(co.right[(i-1)*(i-1)]).color := cor; END END; (* e1 *) FOR i := 1 TO order DO InheritEdges(e1, Enext(co.right[i*i-1]).facetedge.edge); END; IF NOT tp.edge[e1.num].exists THEN FOR i := 1 TO order-1 DO OrgV(Enext_1(co.right[i*i-1])).exists := FALSE; END END; WITH cor = tp.edge[e1.num].color DO FOR i := 1 TO order-1 DO OrgV(Enext_1(co.right[i*i-1])).color := cor; END END; (* e3 *) FOR i := 1 TO order DO InheritEdges(e3, Enext(co.left[i*i-1]).facetedge.edge); END; IF NOT tp.edge[e3.num].exists THEN FOR i := 1 TO order-1 DO OrgV(Enext_1(co.left[i*i-1])).exists := FALSE; END END; WITH cor = tp.edge[e3.num].color DO FOR i := 1 TO order-1 DO OrgV(Enext_1(co.left[i*i-1])).color := cor; END END; (* e4 *) FOR i := 1 TO order DO InheritEdges(e4, Enext_1(co.back[(i-1)*(i-1)]).facetedge.edge); END; IF NOT tp.edge[e4.num].exists THEN FOR i := 1 TO order-1 DO OrgV(co.back[(i-1)*(i-1)]).exists := FALSE; END END; WITH cor = tp.edge[e4.num].color DO FOR i := 1 TO order-1 DO OrgV(co.back[(i-1)*(i-1)]).color := cor; END END; (* e2 *) FOR i := 1 TO order DO InheritEdges(e2, Enext(co.back[i*i-1]).facetedge.edge); END; IF NOT tp.edge[e2.num].exists THEN FOR i := 1 TO order-1 DO OrgV(Enext(co.back[i*i-1])).exists := FALSE; END END; WITH cor = tp.edge[e2.num].color DO FOR i := 1 TO order-1 DO OrgV(Enext(co.back[i*i-1])).color := cor; END END; (* e5 *) VAR count: INTEGER := o2-1; BEGIN InheritEdges(e5, co.front[count].facetedge.edge); FOR j := 1 TO order-1 DO InheritEdges(e5, co.front[count-2].facetedge.edge); count := count-2; END; count := o2-1; IF NOT tp.edge[e5.num].exists THEN FOR j := 1 TO order-1 DO OrgV(co.front[count]).exists := FALSE; count := count-2; END END; count := o2-1; WITH cor = tp.edge[e5.num].color DO FOR j := 1 TO order-1 DO OrgV(co.front[count]).color := cor; count := count-2; END END END; RETURN co; END END SubdivideTetrahedron; PROCEDURE SettingCoords( READONLY oldtp : Triangulation.Topology; READONLY newtp : Triangulation.Topology; READONLY oldco : Triangulation.Coords; READONLY cor : REF ARRAY OF Corner; READONLY ncor : REF ARRAY OF Refine.Corner; order : CARDINAL; mocta : REF ARRAY OF CENTER; inter : REF ARRAY OF CENTER; net : BOOLEAN; ) : REF Triangulation.Coords = PROCEDURE NewNumVer(v: Vertex) : CARDINAL = (*Return the new number vertex of the vertex "v" on the "newtp" topology.*) VAR n: CARDINAL := 0; BEGIN FOR i := 0 TO newtp.NV-1 DO WITH w = newtp.vertex[i] DO IF w = v THEN n := i; EXIT; END; END END; RETURN n; END NewNumVer; PROCEDURE PresentVertex(v: Vertex) : BOOLEAN = (* Return TRUE iff the vertex "v" is present on the "newtp" topology.*) BEGIN FOR i := 0 TO newtp.NV-1 DO WITH w = newtp.vertex[i] DO IF w = v THEN RETURN TRUE END; END END; RETURN FALSE; END PresentVertex; VAR newco : REF Triangulation.Coords; (* vertices *) v0,v1,v2,v3 : CARDINAL; (* edges *) e0 := NEW(REF ARRAY OF CARDINAL, order-1); e1 := NEW(REF ARRAY OF CARDINAL, order-1); e2 := NEW(REF ARRAY OF CARDINAL, order-1); e3 := NEW(REF ARRAY OF CARDINAL, order-1); e4 := NEW(REF ARRAY OF CARDINAL, order-1); e5 := NEW(REF ARRAY OF CARDINAL, order-1); (* faces *) f0 : REF ARRAY OF CARDINAL; f1 : REF ARRAY OF CARDINAL; f2 : REF ARRAY OF CARDINAL; f3 : REF ARRAY OF CARDINAL; BEGIN IF order = 3 THEN f0 := NEW(REF ARRAY OF CARDINAL, 1); f1 := NEW(REF ARRAY OF CARDINAL, 1); f2 := NEW(REF ARRAY OF CARDINAL, 1); f3 := NEW(REF ARRAY OF CARDINAL, 1); ELSIF order = 4 THEN f0 := NEW(REF ARRAY OF CARDINAL, 3); f1 := NEW(REF ARRAY OF CARDINAL, 3); f2 := NEW(REF ARRAY OF CARDINAL, 3); f3 := NEW(REF ARRAY OF CARDINAL, 3); ELSIF order = 5 THEN f0 := NEW(REF ARRAY OF CARDINAL, 6); f1 := NEW(REF ARRAY OF CARDINAL, 6); f2 := NEW(REF ARRAY OF CARDINAL, 6); f3 := NEW(REF ARRAY OF CARDINAL, 6); END; newco := NEW(REF Triangulation.Coords, newtp.NV); (* original vertices *) FOR i := 0 TO oldtp.NP-1 DO WITH o2 = order*order, V0 = OrgV(Enext_1(ncor[i].back [0])), V1 = OrgV(Enext_1(ncor[i].front[0])), V2 = OrgV(Enext (ncor[i].front[o2-1])), V3 = OrgV(Enext_1(ncor[i].left [o2-1])) DO v0 := OrgV(cor[i,0]).num; v1 := OrgV(cor[i,1]).num; v2 := OrgV(cor[i,2]).num; v3 := OrgV(cor[i,5]).num; IF PresentVertex(V0) THEN newco[NewNumVer(V0)] := oldco[v0]; END; IF PresentVertex(V1) THEN newco[NewNumVer(V1)] := oldco[v1]; END; IF PresentVertex(V2) THEN newco[NewNumVer(V2)] := oldco[v2]; END; IF PresentVertex(V3) THEN newco[NewNumVer(V3)] := oldco[v3]; END END; (* vertices on the subdivided edges *) (* e0 : tips vertices V0 and v1 *) WITH dx = (oldco[v1][0] - oldco[v0][0])/FLOAT(order, LONGREAL), dy = (oldco[v1][1] - oldco[v0][1])/FLOAT(order, LONGREAL), dz = (oldco[v1][2] - oldco[v0][2])/FLOAT(order, LONGREAL), dw = (oldco[v1][3] - oldco[v0][3])/FLOAT(order, LONGREAL) DO FOR j := 1 TO order-1 DO WITH ve = OrgV(ncor[i].right[(j-1)*(j-1)]) DO IF PresentVertex(ve) THEN e0[j-1] := NewNumVer(ve); newco[e0[j-1]][0] := oldco[v1][0] - FLOAT(j, LONGREAL) * dx; newco[e0[j-1]][1] := oldco[v1][1] - FLOAT(j, LONGREAL) * dy; newco[e0[j-1]][2] := oldco[v1][2] - FLOAT(j, LONGREAL) * dz; newco[e0[j-1]][3] := oldco[v1][3] - FLOAT(j, LONGREAL) * dw; END END END END; (* end e0 edge *) (* e1 : tips vertices V1 and v2 *) WITH dx = (oldco[v1][0] - oldco[v2][0])/FLOAT(order, LONGREAL), dy = (oldco[v1][1] - oldco[v2][1])/FLOAT(order, LONGREAL), dz = (oldco[v1][2] - oldco[v2][2])/FLOAT(order, LONGREAL), dw = (oldco[v1][3] - oldco[v2][3])/FLOAT(order, LONGREAL) DO FOR j := 1 TO order-1 DO WITH ve = OrgV(Enext_1(ncor[i].right[j*j-1])) DO IF PresentVertex(ve) THEN e1[j-1] := NewNumVer(ve); newco[e1[j-1]][0] := oldco[v1][0] - FLOAT(j, LONGREAL) * dx; newco[e1[j-1]][1] := oldco[v1][1] - FLOAT(j, LONGREAL) * dy; newco[e1[j-1]][2] := oldco[v1][2] - FLOAT(j, LONGREAL) * dz; newco[e1[j-1]][3] := oldco[v1][3] - FLOAT(j, LONGREAL) * dw; END END END END; (* end e1 edge *) (* e3 : tips vertices V1 and v3 *) WITH dx = (oldco[v1][0] - oldco[v3][0])/FLOAT(order, LONGREAL), dy = (oldco[v1][1] - oldco[v3][1])/FLOAT(order, LONGREAL), dz = (oldco[v1][2] - oldco[v3][2])/FLOAT(order, LONGREAL), dw = (oldco[v1][3] - oldco[v3][3])/FLOAT(order, LONGREAL) DO FOR j := 1 TO order-1 DO WITH ve = OrgV(Enext_1(ncor[i].left[j*j-1])) DO IF PresentVertex(ve) THEN e3[j-1] := NewNumVer(ve); newco[e3[j-1]][0] := oldco[v1][0] - FLOAT(j, LONGREAL) * dx; newco[e3[j-1]][1] := oldco[v1][1] - FLOAT(j, LONGREAL) * dy; newco[e3[j-1]][2] := oldco[v1][2] - FLOAT(j, LONGREAL) * dz; newco[e3[j-1]][3] := oldco[v1][3] - FLOAT(j, LONGREAL) * dw; END END END END; (* end e3 edge *) (* e4 : tips vertices V0 and v3 *) WITH dx = (oldco[v0][0] - oldco[v3][0])/FLOAT(order, LONGREAL), dy = (oldco[v0][1] - oldco[v3][1])/FLOAT(order, LONGREAL), dz = (oldco[v0][2] - oldco[v3][2])/FLOAT(order, LONGREAL), dw = (oldco[v0][3] - oldco[v3][3])/FLOAT(order, LONGREAL) DO FOR j := 1 TO order-1 DO WITH ve = OrgV(ncor[i].back[(j-1)*(j-1)]) DO IF PresentVertex(ve) THEN e4[j-1] := NewNumVer(ve); newco[e4[j-1]][0] := oldco[v0][0] - FLOAT(j, LONGREAL) * dx; newco[e4[j-1]][1] := oldco[v0][1] - FLOAT(j, LONGREAL) * dy; newco[e4[j-1]][2] := oldco[v0][2] - FLOAT(j, LONGREAL) * dz; newco[e4[j-1]][3] := oldco[v0][3] - FLOAT(j, LONGREAL) * dw; END END END END; (* end e4 edge *) (* e2 : tips vertices V0 and v2 *) WITH dx = (oldco[v0][0] - oldco[v2][0])/FLOAT(order, LONGREAL), dy = (oldco[v0][1] - oldco[v2][1])/FLOAT(order, LONGREAL), dz = (oldco[v0][2] - oldco[v2][2])/FLOAT(order, LONGREAL), dw = (oldco[v0][3] - oldco[v2][3])/FLOAT(order, LONGREAL) DO FOR j := 1 TO order-1 DO WITH ve = OrgV(Enext(ncor[i].back[j*j-1])) DO IF PresentVertex(ve) THEN e2[j-1] := NewNumVer(ve); newco[e2[j-1]][0] := oldco[v0][0] - FLOAT(j, LONGREAL) * dx; newco[e2[j-1]][1] := oldco[v0][1] - FLOAT(j, LONGREAL) * dy; newco[e2[j-1]][2] := oldco[v0][2] - FLOAT(j, LONGREAL) * dz; newco[e2[j-1]][3] := oldco[v0][3] - FLOAT(j, LONGREAL) * dw; END END END END; (* end e2 edge *) (* e5 : tips vertices V2 and v3 *) WITH dx = (oldco[v2][0] - oldco[v3][0])/FLOAT(order, LONGREAL), dy = (oldco[v2][1] - oldco[v3][1])/FLOAT(order, LONGREAL), dz = (oldco[v2][2] - oldco[v3][2])/FLOAT(order, LONGREAL), dw = (oldco[v2][3] - oldco[v3][3])/FLOAT(order, LONGREAL) DO VAR count : CARDINAL; BEGIN count := order*order-1; FOR j := 1 TO order-1 DO WITH ve = OrgV(ncor[i].front[count]) DO count := count-2; IF PresentVertex(ve) THEN e5[j-1] := NewNumVer(ve); newco[e5[j-1]][0] := oldco[v2][0] - FLOAT(j, LONGREAL) * dx; newco[e5[j-1]][1] := oldco[v2][1] - FLOAT(j, LONGREAL) * dy; newco[e5[j-1]][2] := oldco[v2][2] - FLOAT(j, LONGREAL) * dz; newco[e5[j-1]][3] := oldco[v2][3] - FLOAT(j, LONGREAL) * dw; END END END END END; (* end e5 edge *) (* vertices on the triangulated face. *) IF order = 3 THEN WITH F0 = OrgV(ncor[i].right[3]), F1 = OrgV(ncor[i].left [3]), F3 = OrgV(ncor[i].back [3]), F2 = OrgV(ncor[i].front[3]) DO WITH dx = (newco[e1[0]][0] + newco[e2[0]][0])/2.0d0, dy = (newco[e1[0]][1] + newco[e2[0]][1])/2.0d0, dz = (newco[e1[0]][2] + newco[e2[0]][2])/2.0d0, dw = (newco[e1[0]][3] + newco[e2[0]][3])/2.0d0 DO IF PresentVertex(F0) THEN IF NOT net THEN <* ASSERT NOT F0.exists *> END; f0[0] := NewNumVer(F0); newco[f0[0]][0] := dx; newco[f0[0]][1] := dy; newco[f0[0]][2] := dz; newco[f0[0]][3] := dw; END END; WITH dx = (newco[e0[0]][0] + newco[e4[1]][0])/FLOAT(order-1, LONGREAL), dy = (newco[e0[0]][1] + newco[e4[1]][1])/FLOAT(order-1, LONGREAL), dz = (newco[e0[0]][2] + newco[e4[1]][2])/FLOAT(order-1, LONGREAL), dw = (newco[e0[0]][3] + newco[e4[1]][3])/FLOAT(order-1, LONGREAL) DO IF PresentVertex(F1) THEN IF NOT net THEN <* ASSERT NOT F1.exists *> END; f1[0] := NewNumVer(F1); newco[f1[0]][0] := dx; newco[f1[0]][1] := dy; newco[f1[0]][2] := dz; newco[f1[0]][3] := dw; END END; WITH dx = (newco[e3[0]][0] + newco[e5[0]][0])/FLOAT(order-1, LONGREAL), dy = (newco[e3[0]][1] + newco[e5[0]][1])/FLOAT(order-1, LONGREAL), dz = (newco[e3[0]][2] + newco[e5[0]][2])/FLOAT(order-1, LONGREAL), dw = (newco[e3[0]][3] + newco[e5[0]][3])/FLOAT(order-1, LONGREAL) DO IF PresentVertex(F2) THEN IF NOT net THEN <* ASSERT NOT F2.exists *> END; f2[0] := NewNumVer(F2); newco[f2[0]][0] := dx; newco[f2[0]][1] := dy; newco[f2[0]][2] := dz; newco[f2[0]][3] := dw; END END; WITH dx = (newco[e4[0]][0] + newco[e5[0]][0])/FLOAT(order-1, LONGREAL), dy = (newco[e4[0]][1] + newco[e5[0]][1])/FLOAT(order-1, LONGREAL), dz = (newco[e4[0]][2] + newco[e5[0]][2])/FLOAT(order-1, LONGREAL), dw = (newco[e4[0]][3] + newco[e5[0]][3])/FLOAT(order-1, LONGREAL) DO IF PresentVertex(F3) THEN IF NOT net THEN <* ASSERT NOT F3.exists *> END; f3[0] := NewNumVer(F3); newco[f3[0]][0] := dx; newco[f3[0]][1] := dy; newco[f3[0]][2] := dz; newco[f3[0]][3] := dw; END END END; ELSIF order = 4 THEN WITH F00 = OrgV(ncor[i].right[3]), F01 = OrgV(ncor[i].right[8]), F02 = OrgV(ncor[i].right[6]), F10 = OrgV(ncor[i].left[3]), F11 = OrgV(ncor[i].left[8]), F12 = OrgV(ncor[i].left[6]), F30 = OrgV(ncor[i].back[3]), F31 = OrgV(ncor[i].back[8]), F32 = OrgV(ncor[i].back[6]), F20 = OrgV(ncor[i].front[3]), F21 = OrgV(ncor[i].front[8]), F22 = OrgV(ncor[i].front[6]) DO <* ASSERT Text.Equal(F00.label,"VF") *> <* ASSERT Text.Equal(F01.label,"VF") *> <* ASSERT Text.Equal(F02.label,"VF") *> <* ASSERT Text.Equal(F10.label,"VF") *> <* ASSERT Text.Equal(F11.label,"VF") *> <* ASSERT Text.Equal(F12.label,"VF") *> <* ASSERT Text.Equal(F30.label,"VF") *> <* ASSERT Text.Equal(F31.label,"VF") *> <* ASSERT Text.Equal(F32.label,"VF") *> <* ASSERT Text.Equal(F20.label,"VF") *> <* ASSERT Text.Equal(F21.label,"VF") *> <* ASSERT Text.Equal(F22.label,"VF") *> (* Right *) WITH dx = (newco[e1[0]][0] - newco[e2[0]][0])/FLOAT(order-1, LONGREAL), dy = (newco[e1[0]][1] - newco[e2[0]][1])/FLOAT(order-1, LONGREAL), dz = (newco[e1[0]][2] - newco[e2[0]][2])/FLOAT(order-1, LONGREAL), dw = (newco[e1[0]][3] - newco[e2[0]][3])/FLOAT(order-1, LONGREAL) DO IF PresentVertex(F00) THEN IF NOT net THEN <* ASSERT NOT F00.exists *> END; f0[0] := NewNumVer(F00); newco[f0[0]][0] := newco[e1[0]][0] - 1.0d0 * dx; newco[f0[0]][1] := newco[e1[0]][1] - 1.0d0 * dy; newco[f0[0]][2] := newco[e1[0]][2] - 1.0d0 * dz; newco[f0[0]][3] := newco[e1[0]][3] - 1.0d0 * dw; END; IF PresentVertex(F02) THEN IF NOT net THEN <* ASSERT NOT F02.exists *> END; f0[2] := NewNumVer(F02); newco[f0[2]][0] := newco[e1[0]][0] - 2.0d0 * dx; newco[f0[2]][1] := newco[e1[0]][1] - 2.0d0 * dy; newco[f0[2]][2] := newco[e1[0]][2] - 2.0d0 * dz; newco[f0[2]][3] := newco[e1[0]][3] - 2.0d0 * dw; END END; WITH dx = (newco[e1[1]][0] - newco[e2[1]][0])/FLOAT(order-2, LONGREAL), dy = (newco[e1[1]][1] - newco[e2[1]][1])/FLOAT(order-2, LONGREAL), dz = (newco[e1[1]][2] - newco[e2[1]][2])/FLOAT(order-2, LONGREAL), dw = (newco[e1[1]][3] - newco[e2[1]][3])/FLOAT(order-2, LONGREAL) DO IF PresentVertex(F01) THEN IF NOT net THEN <* ASSERT NOT F01.exists *> END; f0[1] := NewNumVer(F01); newco[f0[1]][0] := newco[e1[1]][0] - 1.0d0 * dx; newco[f0[1]][1] := newco[e1[1]][1] - 1.0d0 * dy; newco[f0[1]][2] := newco[e1[1]][2] - 1.0d0 * dz; newco[f0[1]][3] := newco[e1[1]][3] - 1.0d0 * dw; END END; (* Left *) WITH dx = (newco[e0[0]][0] - newco[e4[2]][0])/FLOAT(order-1, LONGREAL), dy = (newco[e0[0]][1] - newco[e4[2]][1])/FLOAT(order-1, LONGREAL), dz = (newco[e0[0]][2] - newco[e4[2]][2])/FLOAT(order-1, LONGREAL), dw = (newco[e0[0]][3] - newco[e4[2]][3])/FLOAT(order-1, LONGREAL) DO IF PresentVertex(F10) THEN IF NOT net THEN <* ASSERT NOT F10.exists *> END; f1[0] := NewNumVer(F10); newco[f1[0]][0] := newco[e0[0]][0] - 1.0d0 * dx; newco[f1[0]][1] := newco[e0[0]][1] - 1.0d0 * dy; newco[f1[0]][2] := newco[e0[0]][2] - 1.0d0 * dz; newco[f1[0]][3] := newco[e0[0]][3] - 1.0d0 * dw; END; IF PresentVertex(F11) THEN IF NOT net THEN <* ASSERT NOT F11.exists *> END; f1[1] := NewNumVer(F11); newco[f1[1]][0] := newco[e0[0]][0] - 2.0d0 * dx; newco[f1[1]][1] := newco[e0[0]][1] - 2.0d0 * dy; newco[f1[1]][2] := newco[e0[0]][2] - 2.0d0 * dz; newco[f1[1]][3] := newco[e0[0]][3] - 2.0d0 * dw; END END; WITH dx = (newco[e0[1]][0] - newco[e4[1]][0])/FLOAT(order-2, LONGREAL), dy = (newco[e0[1]][1] - newco[e4[1]][1])/FLOAT(order-2, LONGREAL), dz = (newco[e0[1]][2] - newco[e4[1]][2])/FLOAT(order-2, LONGREAL), dw = (newco[e0[1]][3] - newco[e4[1]][3])/FLOAT(order-2, LONGREAL) DO IF PresentVertex(F12) THEN IF NOT net THEN <* ASSERT NOT F12.exists *> END; f1[2] := NewNumVer(F12); newco[f1[2]][0] := newco[e0[1]][0] - 1.0d0 * dx; newco[f1[2]][1] := newco[e0[1]][1] - 1.0d0 * dy; newco[f1[2]][2] := newco[e0[1]][2] - 1.0d0 * dz; newco[f1[2]][3] := newco[e0[1]][3] - 1.0d0 * dw; END END; (* Front *) WITH dx = (newco[e3[0]][0] - newco[e5[0]][0])/FLOAT(order-1, LONGREAL), dy = (newco[e3[0]][1] - newco[e5[0]][1])/FLOAT(order-1, LONGREAL), dz = (newco[e3[0]][2] - newco[e5[0]][2])/FLOAT(order-1, LONGREAL), dw = (newco[e3[0]][3] - newco[e5[0]][3])/FLOAT(order-1, LONGREAL) DO IF PresentVertex(F20) THEN IF NOT net THEN <* ASSERT NOT F20.exists *> END; f2[0] := NewNumVer(F20); newco[f2[0]][0] := newco[e3[0]][0] - 1.0d0 * dx; newco[f2[0]][1] := newco[e3[0]][1] - 1.0d0 * dy; newco[f2[0]][2] := newco[e3[0]][2] - 1.0d0 * dz; newco[f2[0]][3] := newco[e3[0]][3] - 1.0d0 * dw; END; IF PresentVertex(F21) THEN IF NOT net THEN <* ASSERT NOT F21.exists *> END; f2[1] := NewNumVer(F21); newco[f2[1]][0] := newco[e3[0]][0] - 2.0d0 * dx; newco[f2[1]][1] := newco[e3[0]][1] - 2.0d0 * dy; newco[f2[1]][2] := newco[e3[0]][2] - 2.0d0 * dz; newco[f2[1]][3] := newco[e3[0]][3] - 2.0d0 * dw; END END; WITH dx = (newco[e3[1]][0] - newco[e5[1]][0])/FLOAT(order-2, LONGREAL), dy = (newco[e3[1]][1] - newco[e5[1]][1])/FLOAT(order-2, LONGREAL), dz = (newco[e3[1]][2] - newco[e5[1]][2])/FLOAT(order-2, LONGREAL), dw = (newco[e3[1]][3] - newco[e5[1]][3])/FLOAT(order-2, LONGREAL) DO IF PresentVertex(F22) THEN IF NOT net THEN <* ASSERT NOT F22.exists *> END; f2[2] := NewNumVer(F22); newco[f2[2]][0] := newco[e3[1]][0] - 1.0d0 * dx; newco[f2[2]][1] := newco[e3[1]][1] - 1.0d0 * dy; newco[f2[2]][2] := newco[e3[1]][2] - 1.0d0 * dz; newco[f2[2]][3] := newco[e3[1]][3] - 1.0d0 * dw; END END; (* Back *) WITH dx = (newco[e4[0]][0] - newco[e5[0]][0])/FLOAT(order-1, LONGREAL), dy = (newco[e4[0]][1] - newco[e5[0]][1])/FLOAT(order-1, LONGREAL), dz = (newco[e4[0]][2] - newco[e5[0]][2])/FLOAT(order-1, LONGREAL), dw = (newco[e4[0]][3] - newco[e5[0]][3])/FLOAT(order-1, LONGREAL) DO IF PresentVertex(F30) THEN IF NOT net THEN <* ASSERT NOT F30.exists *> END; f3[0] := NewNumVer(F30); newco[f3[0]][0] := newco[e4[0]][0] - 1.0d0 * dx; newco[f3[0]][1] := newco[e4[0]][1] - 1.0d0 * dy; newco[f3[0]][2] := newco[e4[0]][2] - 1.0d0 * dz; newco[f3[0]][3] := newco[e4[0]][3] - 1.0d0 * dw; END; IF PresentVertex(F31) THEN IF NOT net THEN <* ASSERT NOT F31.exists *> END; f3[1] := NewNumVer(F31); newco[f3[1]][0] := newco[e4[0]][0] - 2.0d0 * dx; newco[f3[1]][1] := newco[e4[0]][1] - 2.0d0 * dy; newco[f3[1]][2] := newco[e4[0]][2] - 2.0d0 * dz; newco[f3[1]][3] := newco[e4[0]][3] - 2.0d0 * dw; END END; WITH dx = (newco[e4[1]][0] - newco[e5[1]][0])/FLOAT(order-2, LONGREAL), dy = (newco[e4[1]][1] - newco[e5[1]][1])/FLOAT(order-2, LONGREAL), dz = (newco[e4[1]][2] - newco[e5[1]][2])/FLOAT(order-2, LONGREAL), dw = (newco[e4[1]][3] - newco[e5[1]][3])/FLOAT(order-2, LONGREAL) DO IF PresentVertex(F32) THEN IF NOT net THEN <* ASSERT NOT F32.exists *> END; f3[2] := NewNumVer(F32); newco[f3[2]][0] := newco[e4[1]][0] - 1.0d0 * dx; newco[f3[2]][1] := newco[e4[1]][1] - 1.0d0 * dy; newco[f3[2]][2] := newco[e4[1]][2] - 1.0d0 * dz; newco[f3[2]][3] := newco[e4[1]][3] - 1.0d0 * dw; END END END; ELSIF order = 5 THEN WITH F00 = OrgV(ncor[i].right[ 3]), F01 = OrgV(ncor[i].right[ 8]), F02 = OrgV(ncor[i].right[ 6]), F03 = OrgV(ncor[i].right[15]), F04 = OrgV(ncor[i].right[13]), F05 = OrgV(ncor[i].right[11]), F10 = OrgV(ncor[i].left [ 3]), F11 = OrgV(ncor[i].left [ 8]), F12 = OrgV(ncor[i].left [ 6]), F13 = OrgV(ncor[i].left [15]), F14 = OrgV(ncor[i].left [13]), F15 = OrgV(ncor[i].left [11]), F30 = OrgV(ncor[i].back [ 3]), F31 = OrgV(ncor[i].back [ 8]), F32 = OrgV(ncor[i].back [ 6]), F33 = OrgV(ncor[i].back [15]), F34 = OrgV(ncor[i].back [13]), F35 = OrgV(ncor[i].back [11]), F20 = OrgV(ncor[i].front[ 3]), F21 = OrgV(ncor[i].front[ 8]), F22 = OrgV(ncor[i].front[ 6]), F23 = OrgV(ncor[i].front[15]), F24 = OrgV(ncor[i].front[13]), F25 = OrgV(ncor[i].front[11]) DO (* Right *) WITH dx = (newco[e1[0]][0] - newco[e2[0]][0])/FLOAT(order-1, LONGREAL), dy = (newco[e1[0]][1] - newco[e2[0]][1])/FLOAT(order-1, LONGREAL), dz = (newco[e1[0]][2] - newco[e2[0]][2])/FLOAT(order-1, LONGREAL), dw = (newco[e1[0]][3] - newco[e2[0]][3])/FLOAT(order-1, LONGREAL) DO IF PresentVertex(F00) THEN IF NOT net THEN <* ASSERT NOT F00.exists *> END; f0[0] := NewNumVer(F00); newco[f0[0]][0] := newco[e1[0]][0] - 1.0d0 * dx; newco[f0[0]][1] := newco[e1[0]][1] - 1.0d0 * dy; newco[f0[0]][2] := newco[e1[0]][2] - 1.0d0 * dz; newco[f0[0]][3] := newco[e1[0]][3] - 1.0d0 * dw; END; IF PresentVertex(F02) THEN IF NOT net THEN <* ASSERT NOT F02.exists *> END; f0[2] := NewNumVer(F02); newco[f0[2]][0] := newco[e1[0]][0] - 2.0d0 * dx; newco[f0[2]][1] := newco[e1[0]][1] - 2.0d0 * dy; newco[f0[2]][2] := newco[e1[0]][2] - 2.0d0 * dz; newco[f0[2]][3] := newco[e1[0]][3] - 2.0d0 * dw; END; IF PresentVertex(F05) THEN IF NOT net THEN <* ASSERT NOT F05.exists *> END; f0[5] := NewNumVer(F05); newco[f0[5]][0] := newco[e1[0]][0] - 3.0d0 * dx; newco[f0[5]][1] := newco[e1[0]][1] - 3.0d0 * dy; newco[f0[5]][2] := newco[e1[0]][2] - 3.0d0 * dz; newco[f0[5]][3] := newco[e1[0]][3] - 3.0d0 * dw; END END; WITH dx = (newco[e1[1]][0] - newco[e2[1]][0])/FLOAT(order-2, LONGREAL), dy = (newco[e1[1]][1] - newco[e2[1]][1])/FLOAT(order-2, LONGREAL), dz = (newco[e1[1]][2] - newco[e2[1]][2])/FLOAT(order-2, LONGREAL), dw = (newco[e1[1]][3] - newco[e2[1]][3])/FLOAT(order-2, LONGREAL) DO IF PresentVertex(F01) THEN IF NOT net THEN <* ASSERT NOT F01.exists *> END; f0[1] := NewNumVer(F01); newco[f0[1]][0] := newco[e1[1]][0] - 1.0d0 * dx; newco[f0[1]][1] := newco[e1[1]][1] - 1.0d0 * dy; newco[f0[1]][2] := newco[e1[1]][2] - 1.0d0 * dz; newco[f0[1]][3] := newco[e1[1]][3] - 1.0d0 * dw; END; IF PresentVertex(F04) THEN IF NOT net THEN <* ASSERT NOT F04.exists *> END; f0[4] := NewNumVer(F04); newco[f0[4]][0] := newco[e1[1]][0] - 2.0d0 * dx; newco[f0[4]][1] := newco[e1[1]][1] - 2.0d0 * dy; newco[f0[4]][2] := newco[e1[1]][2] - 2.0d0 * dz; newco[f0[4]][3] := newco[e1[1]][3] - 2.0d0 * dw; END END; WITH dx = (newco[e1[2]][0] - newco[e2[2]][0])/FLOAT(order-3, LONGREAL), dy = (newco[e1[2]][1] - newco[e2[2]][1])/FLOAT(order-3, LONGREAL), dz = (newco[e1[2]][2] - newco[e2[2]][2])/FLOAT(order-3, LONGREAL), dw = (newco[e1[2]][3] - newco[e2[2]][3])/FLOAT(order-3, LONGREAL) DO IF PresentVertex(F03) THEN IF NOT net THEN <* ASSERT NOT F03.exists *> END; f0[3] := NewNumVer(F03); newco[f0[3]][0] := newco[e1[2]][0] - 1.0d0 * dx; newco[f0[3]][1] := newco[e1[2]][1] - 1.0d0 * dy; newco[f0[3]][2] := newco[e1[2]][2] - 1.0d0 * dz; newco[f0[3]][3] := newco[e1[2]][3] - 1.0d0 * dw; END END; (* Left *) WITH dx = (newco[e0[0]][0] - newco[e4[3]][0])/FLOAT(order-1, LONGREAL), dy = (newco[e0[0]][1] - newco[e4[3]][1])/FLOAT(order-1, LONGREAL), dz = (newco[e0[0]][2] - newco[e4[3]][2])/FLOAT(order-1, LONGREAL), dw = (newco[e0[0]][3] - newco[e4[3]][3])/FLOAT(order-1, LONGREAL) DO IF PresentVertex(F10) THEN IF NOT net THEN <* ASSERT NOT F10.exists *> END; f1[0] := NewNumVer(F10); newco[f1[0]][0] := newco[e0[0]][0] - 1.0d0 * dx; newco[f1[0]][1] := newco[e0[0]][1] - 1.0d0 * dy; newco[f1[0]][2] := newco[e0[0]][2] - 1.0d0 * dz; newco[f1[0]][3] := newco[e0[0]][3] - 1.0d0 * dw; END; IF PresentVertex(F11) THEN IF NOT net THEN <* ASSERT NOT F11.exists *> END; f1[1] := NewNumVer(F11); newco[f1[1]][0] := newco[e0[0]][0] - 2.0d0 * dx; newco[f1[1]][1] := newco[e0[0]][1] - 2.0d0 * dy; newco[f1[1]][2] := newco[e0[0]][2] - 2.0d0 * dz; newco[f1[1]][3] := newco[e0[0]][3] - 2.0d0 * dw; END; IF PresentVertex(F13) THEN IF NOT net THEN <* ASSERT NOT F13.exists *> END; f1[3] := NewNumVer(F13); newco[f1[3]][0] := newco[e0[0]][0] - 3.0d0 * dx; newco[f1[3]][1] := newco[e0[0]][1] - 3.0d0 * dy; newco[f1[3]][2] := newco[e0[0]][2] - 3.0d0 * dz; newco[f1[3]][3] := newco[e0[0]][3] - 3.0d0 * dw; END END; WITH dx = (newco[e0[1]][0] - newco[e4[2]][0])/FLOAT(order-2, LONGREAL), dy = (newco[e0[1]][1] - newco[e4[2]][1])/FLOAT(order-2, LONGREAL), dz = (newco[e0[1]][2] - newco[e4[2]][2])/FLOAT(order-2, LONGREAL), dw = (newco[e0[1]][3] - newco[e4[2]][3])/FLOAT(order-2, LONGREAL) DO IF PresentVertex(F12) THEN IF NOT net THEN <* ASSERT NOT F12.exists *> END; f1[2] := NewNumVer(F12); newco[f1[2]][0] := newco[e0[1]][0] - 1.0d0 * dx; newco[f1[2]][1] := newco[e0[1]][1] - 1.0d0 * dy; newco[f1[2]][2] := newco[e0[1]][2] - 1.0d0 * dz; newco[f1[2]][3] := newco[e0[1]][3] - 1.0d0 * dw; END; IF PresentVertex(F14) THEN IF NOT net THEN <* ASSERT NOT F14.exists *> END; f1[4] := NewNumVer(F14); newco[f1[4]][0] := newco[e0[1]][0] - 2.0d0 * dx; newco[f1[4]][1] := newco[e0[1]][1] - 2.0d0 * dy; newco[f1[4]][2] := newco[e0[1]][2] - 2.0d0 * dz; newco[f1[4]][3] := newco[e0[1]][3] - 2.0d0 * dw; END END; WITH dx = (newco[e0[2]][0] - newco[e4[1]][0])/FLOAT(order-3, LONGREAL), dy = (newco[e0[2]][1] - newco[e4[1]][1])/FLOAT(order-3, LONGREAL), dz = (newco[e0[2]][2] - newco[e4[1]][2])/FLOAT(order-3, LONGREAL), dw = (newco[e0[2]][3] - newco[e4[1]][3])/FLOAT(order-3, LONGREAL) DO IF PresentVertex(F15) THEN IF NOT net THEN <* ASSERT NOT F15.exists *> END; f1[5] := NewNumVer(F15); newco[f1[5]][0] := newco[e0[2]][0] - 1.0d0 * dx; newco[f1[5]][1] := newco[e0[2]][1] - 1.0d0 * dy; newco[f1[5]][2] := newco[e0[2]][2] - 1.0d0 * dz; newco[f1[5]][3] := newco[e0[2]][3] - 1.0d0 * dw; END END; (* Front *) WITH dx = (newco[e3[0]][0] - newco[e5[0]][0])/FLOAT(order-1, LONGREAL), dy = (newco[e3[0]][1] - newco[e5[0]][1])/FLOAT(order-1, LONGREAL), dz = (newco[e3[0]][2] - newco[e5[0]][2])/FLOAT(order-1, LONGREAL), dw = (newco[e3[0]][3] - newco[e5[0]][3])/FLOAT(order-1, LONGREAL) DO IF PresentVertex(F20) THEN IF NOT net THEN <* ASSERT NOT F20.exists *> END; f2[0] := NewNumVer(F20); newco[f2[0]][0] := newco[e3[0]][0] - 1.0d0 * dx; newco[f2[0]][1] := newco[e3[0]][1] - 1.0d0 * dy; newco[f2[0]][2] := newco[e3[0]][2] - 1.0d0 * dz; newco[f2[0]][3] := newco[e3[0]][3] - 1.0d0 * dw; END; IF PresentVertex(F21) THEN IF NOT net THEN <* ASSERT NOT F21.exists *> END; f2[1] := NewNumVer(F21); newco[f2[1]][0] := newco[e3[0]][0] - 2.0d0 * dx; newco[f2[1]][1] := newco[e3[0]][1] - 2.0d0 * dy; newco[f2[1]][2] := newco[e3[0]][2] - 2.0d0 * dz; newco[f2[1]][3] := newco[e3[0]][3] - 2.0d0 * dw; END; IF PresentVertex(F23) THEN IF NOT net THEN <* ASSERT NOT F23.exists *> END; f2[3] := NewNumVer(F23); newco[f2[3]][0] := newco[e3[0]][0] - 3.0d0 * dx; newco[f2[3]][1] := newco[e3[0]][1] - 3.0d0 * dy; newco[f2[3]][2] := newco[e3[0]][2] - 3.0d0 * dz; newco[f2[3]][3] := newco[e3[0]][3] - 3.0d0 * dw; END END; WITH dx = (newco[e3[1]][0] - newco[e5[1]][0])/FLOAT(order-2, LONGREAL), dy = (newco[e3[1]][1] - newco[e5[1]][1])/FLOAT(order-2, LONGREAL), dz = (newco[e3[1]][2] - newco[e5[1]][2])/FLOAT(order-2, LONGREAL), dw = (newco[e3[1]][3] - newco[e5[1]][3])/FLOAT(order-2, LONGREAL) DO IF PresentVertex(F22) THEN IF NOT net THEN <* ASSERT NOT F22.exists *> END; f2[2] := NewNumVer(F22); newco[f2[2]][0] := newco[e3[1]][0] - 1.0d0 * dx; newco[f2[2]][1] := newco[e3[1]][1] - 1.0d0 * dy; newco[f2[2]][2] := newco[e3[1]][2] - 1.0d0 * dz; newco[f2[2]][3] := newco[e3[1]][3] - 1.0d0 * dw; END; IF PresentVertex(F24) THEN IF NOT net THEN <* ASSERT NOT F24.exists *> END; f2[4] := NewNumVer(F24); newco[f2[4]][0] := newco[e3[1]][0] - 2.0d0 * dx; newco[f2[4]][1] := newco[e3[1]][1] - 2.0d0 * dy; newco[f2[4]][2] := newco[e3[1]][2] - 2.0d0 * dz; newco[f2[4]][3] := newco[e3[1]][3] - 2.0d0 * dw; END END; WITH dx = (newco[e3[2]][0] - newco[e5[2]][0])/FLOAT(order-3, LONGREAL), dy = (newco[e3[2]][1] - newco[e5[2]][1])/FLOAT(order-3, LONGREAL), dz = (newco[e3[2]][2] - newco[e5[2]][2])/FLOAT(order-3, LONGREAL), dw = (newco[e3[2]][3] - newco[e5[2]][3])/FLOAT(order-3, LONGREAL) DO IF PresentVertex(F25) THEN IF NOT net THEN <* ASSERT NOT F25.exists *> END; f2[5] := NewNumVer(F25); newco[f2[5]][0] := newco[e3[2]][0] - 1.0d0 * dx; newco[f2[5]][1] := newco[e3[2]][1] - 1.0d0 * dy; newco[f2[5]][2] := newco[e3[2]][2] - 1.0d0 * dz; newco[f2[5]][3] := newco[e3[2]][3] - 1.0d0 * dw; END END; (* Back *) WITH dx = (newco[e4[0]][0] - newco[e5[0]][0])/FLOAT(order-1, LONGREAL), dy = (newco[e4[0]][1] - newco[e5[0]][1])/FLOAT(order-1, LONGREAL), dz = (newco[e4[0]][2] - newco[e5[0]][2])/FLOAT(order-1, LONGREAL), dw = (newco[e4[0]][3] - newco[e5[0]][3])/FLOAT(order-1, LONGREAL) DO IF PresentVertex(F30) THEN IF NOT net THEN <* ASSERT NOT F30.exists *> END; f3[0] := NewNumVer(F30); newco[f3[0]][0] := newco[e4[0]][0] - 1.0d0 * dx; newco[f3[0]][1] := newco[e4[0]][1] - 1.0d0 * dy; newco[f3[0]][2] := newco[e4[0]][2] - 1.0d0 * dz; newco[f3[0]][3] := newco[e4[0]][3] - 1.0d0 * dw; END; IF PresentVertex(F31) THEN IF NOT net THEN <* ASSERT NOT F31.exists *> END; f3[1] := NewNumVer(F31); newco[f3[1]][0] := newco[e4[0]][0] - 2.0d0 * dx; newco[f3[1]][1] := newco[e4[0]][1] - 2.0d0 * dy; newco[f3[1]][2] := newco[e4[0]][2] - 2.0d0 * dz; newco[f3[1]][3] := newco[e4[0]][3] - 2.0d0 * dw; END; IF PresentVertex(F33) THEN IF NOT net THEN <* ASSERT NOT F33.exists *> END; f3[3] := NewNumVer(F33); newco[f3[3]][0] := newco[e4[0]][0] - 3.0d0 * dx; newco[f3[3]][1] := newco[e4[0]][1] - 3.0d0 * dy; newco[f3[3]][2] := newco[e4[0]][2] - 3.0d0 * dz; newco[f3[3]][3] := newco[e4[0]][3] - 3.0d0 * dw; END END; WITH dx = (newco[e4[1]][0] - newco[e5[1]][0])/FLOAT(order-2, LONGREAL), dy = (newco[e4[1]][1] - newco[e5[1]][1])/FLOAT(order-2, LONGREAL), dz = (newco[e4[1]][2] - newco[e5[1]][2])/FLOAT(order-2, LONGREAL), dw = (newco[e4[1]][3] - newco[e5[1]][3])/FLOAT(order-2, LONGREAL) DO IF PresentVertex(F32) THEN IF NOT net THEN <* ASSERT NOT F32.exists *> END; f3[2] := NewNumVer(F32); newco[f3[2]][0] := newco[e4[1]][0] - 1.0d0 * dx; newco[f3[2]][1] := newco[e4[1]][1] - 1.0d0 * dy; newco[f3[2]][2] := newco[e4[1]][2] - 1.0d0 * dz; newco[f3[2]][3] := newco[e4[1]][3] - 1.0d0 * dw; END; IF PresentVertex(F34) THEN IF NOT net THEN <* ASSERT NOT F34.exists *> END; f3[4] := NewNumVer(F34); newco[f3[4]][0] := newco[e4[1]][0] - 2.0d0 * dx; newco[f3[4]][1] := newco[e4[1]][1] - 2.0d0 * dy; newco[f3[4]][2] := newco[e4[1]][2] - 2.0d0 * dz; newco[f3[4]][3] := newco[e4[1]][3] - 2.0d0 * dw; END END; WITH dx = (newco[e4[2]][0] - newco[e5[2]][0])/FLOAT(order-3, LONGREAL), dy = (newco[e4[2]][1] - newco[e5[2]][1])/FLOAT(order-3, LONGREAL), dz = (newco[e4[2]][2] - newco[e5[2]][2])/FLOAT(order-3, LONGREAL), dw = (newco[e4[2]][3] - newco[e5[2]][3])/FLOAT(order-3, LONGREAL) DO IF PresentVertex(F35) THEN IF NOT net THEN <* ASSERT NOT F35.exists *> END; f3[5] := NewNumVer(F35); newco[f3[5]][0] := newco[e4[2]][0] - 1.0d0 * dx; newco[f3[5]][1] := newco[e4[2]][1] - 1.0d0 * dy; newco[f3[5]][2] := newco[e4[2]][2] - 1.0d0 * dz; newco[f3[5]][3] := newco[e4[2]][3] - 1.0d0 * dw; END END END END; (* vertices on the octahedron barycenter. *) IF order = 2 THEN IF PresentVertex(mocta[i][0]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][0].exists *> END; WITH n = NewNumVer(mocta[i][0]), b0 = Add(newco[e3[0]],newco[e1[0]]), b1 = Add(newco[e4[0]],newco[e2[0]]), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(4, LONGREAL), b); END END ELSIF order = 3 THEN IF PresentVertex(mocta[i][0]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][0].exists *> END; WITH n = NewNumVer(mocta[i][0]), b0 = Add(Add(newco[f2[0]],newco[e3[0]]),newco[f1[0]]), b1 = Add(Add(newco[e1[0]],newco[e0[0]]),newco[f0[0]]), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; IF PresentVertex(mocta[i][1]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][1].exists *> END; WITH n = NewNumVer(mocta[i][1]), b0 = Add(Add(newco[f2[0]],newco[f3[0]]),newco[e5[1]]), b1 = Add(Add(newco[f1[0]],newco[e4[1]]),newco[e3[1]]), b = Add(b0,b1) DO MyAssert(newco[f2[0]]); MyAssert(newco[f3[0]]); MyAssert(newco[e5[1]]); MyAssert(newco[f1[0]]); MyAssert(newco[e4[1]]); MyAssert(newco[e3[1]]); newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; IF PresentVertex(mocta[i][2]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][2].exists *> END; WITH n = NewNumVer(mocta[i][2]), b0 = Add(Add(newco[f2[0]],newco[f3[0]]),newco[e5[0]]), b1 = Add(Add(newco[e1[1]],newco[f0[0]]),newco[e2[1]]), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; IF PresentVertex(mocta[i][3]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][3].exists *> END; WITH n = NewNumVer(mocta[i][3]), b0 = Add(Add(newco[f3[0]],newco[f1[0]]),newco[e4[0]]), b1 = Add(Add(newco[f0[0]],newco[e0[1]]),newco[e2[0]]), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; ELSIF order = 4 THEN IF PresentVertex(mocta[i][0]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][0].exists *> END; WITH n = NewNumVer(mocta[i][0]), b0 = Add(Add(newco[e1[0]],newco[e0[0]]),newco[f0[0]]), b1 = Add(Add(newco[f1[0]],newco[e3[0]]),newco[f2[0]]), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; IF PresentVertex(mocta[i][3]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][3].exists *> END; WITH n = NewNumVer(mocta[i][3]), b0 = Add(Add(newco[e3[2]],newco[f2[2]]),newco[e5[2]]), b1 = Add(Add(newco[f1[1]],newco[e4[2]]),newco[f3[2]]), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; IF PresentVertex(mocta[i][5]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][5].exists *> END; WITH n = NewNumVer(mocta[i][5]), b0 = Add(Add(newco[f2[1]],newco[e1[2]]),newco[e5[0]]), b1 = Add(Add(newco[f3[1]],newco[e2[2]]),newco[f0[1]]), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; IF PresentVertex(mocta[i][6]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][6].exists *> END; WITH n = NewNumVer(mocta[i][6]), b0 = Add(Add(newco[f0[2]],newco[e0[2]]),newco[e2[0]]), b1 = Add(Add(newco[f1[2]],newco[e4[0]]),newco[f3[0]]), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; WITH dx = (newco[f1[1]][0] - newco[f0[1]][0])/FLOAT(order-2, LONGREAL), dy = (newco[f1[1]][1] - newco[f0[1]][1])/FLOAT(order-2, LONGREAL), dz = (newco[f1[1]][2] - newco[f0[1]][2])/FLOAT(order-2, LONGREAL), dw = (newco[f1[1]][3] - newco[f0[1]][3])/FLOAT(order-2, LONGREAL), p0 = newco[f1[1]][0] - 1.0d0 * dx, p1 = newco[f1[1]][1] - 1.0d0 * dy, p2 = newco[f1[1]][2] - 1.0d0 * dz, p3 = newco[f1[1]][3] - 1.0d0 * dw, p = LR4.T{p0,p1,p2,p3} DO IF PresentVertex(inter[i][0]) THEN <* ASSERT NOT inter[i][0].exists *> WITH n = NewNumVer(inter[i][0]) DO newco[n] := p; END END; IF PresentVertex(mocta[i][1]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][1].exists *> END; WITH n = NewNumVer(mocta[i][1]), b0 = Add(Add(newco[e3[1]],newco[f2[0]]),newco[f2[2]]), b1 = Add(Add(newco[f1[0]],newco[f1[1]]),p), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; IF PresentVertex(mocta[i][2]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][2].exists *> END; WITH n = NewNumVer(mocta[i][2]), b0 = Add(Add(newco[f2[0]],newco[e1[1]]),newco[f2[1]]), b1 = Add(Add(newco[f0[0]],newco[f0[1]]),p), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; IF PresentVertex(mocta[i][4]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][4].exists *> END; WITH n = NewNumVer(mocta[i][4]), b0 = Add(Add(newco[f2[2]],newco[f2[1]]),newco[e5[1]]), b1 = Add(Add(newco[f3[2]],newco[f3[1]]),p), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; IF PresentVertex(mocta[i][7]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][7].exists *> END; WITH n = NewNumVer(mocta[i][7]), b0 = Add(Add(newco[f0[0]],newco[e0[1]]),newco[f0[2]]), b1 = Add(Add(newco[f1[0]],newco[f1[2]]),p), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; IF PresentVertex(mocta[i][8]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][8].exists *> END; WITH n = NewNumVer(mocta[i][8]), b0 = Add(Add(newco[f0[1]],newco[f0[2]]),newco[e2[1]]), b1 = Add(Add(newco[f3[0]],newco[f3[1]]),p), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; IF PresentVertex(mocta[i][9]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][9].exists *> END; WITH n = NewNumVer(mocta[i][9]), b0 = Add(Add(newco[f1[2]],newco[f1[1]]),newco[e4[1]]), b1 = Add(Add(newco[f3[0]],newco[f3[2]]),p), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END END; ELSIF order = 5 THEN IF PresentVertex(mocta[i][0]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][0].exists *> END; WITH n = NewNumVer(mocta[i][0]), b0 = Add(Add(newco[e1[0]],newco[e0[0]]),newco[f0[0]]), b1 = Add(Add(newco[f1[0]],newco[e3[0]]),newco[f2[0]]), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; IF PresentVertex(mocta[i][6]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][6].exists *> END; WITH n = NewNumVer(mocta[i][6]), b0 = Add(Add(newco[f1[3]],newco[e3[3]]),newco[e4[3]]), b1 = Add(Add(newco[f3[5]],newco[e5[3]]),newco[f2[5]]), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; IF PresentVertex(mocta[i][9]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][9].exists *> END; WITH n = NewNumVer(mocta[i][9]), b0 = Add(Add(newco[e1[3]],newco[f0[3]]),newco[e2[3]]), b1 = Add(Add(newco[f2[3]],newco[e5[0]]),newco[f3[3]]), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; IF PresentVertex(mocta[i][10]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][10].exists *> END; WITH n = NewNumVer(mocta[i][10]), b0 = Add(Add(newco[f0[5]],newco[e0[3]]),newco[e2[0]]), b1 = Add(Add(newco[f1[5]],newco[e4[0]]),newco[f3[0]]), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; WITH dx = (newco[f1[2]][0] - newco[f2[1]][0])/FLOAT(order-3, LONGREAL), dy = (newco[f1[2]][1] - newco[f2[1]][1])/FLOAT(order-3, LONGREAL), dz = (newco[f1[2]][2] - newco[f2[1]][2])/FLOAT(order-3, LONGREAL), dw = (newco[f1[2]][3] - newco[f2[1]][3])/FLOAT(order-3, LONGREAL), Q0 = newco[f1[2]][0] - 1.0d0 * dx, Q1 = newco[f1[2]][1] - 1.0d0 * dy, Q2 = newco[f1[2]][2] - 1.0d0 * dz, Q3 = newco[f1[2]][3] - 1.0d0 * dw, q1 = LR4.T{Q0,Q1,Q2,Q3} DO IF PresentVertex(mocta[i][1]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][1].exists *> END; WITH n = NewNumVer(mocta[i][1]), b0 = Add(Add(newco[e3[1]],newco[f2[0]]),newco[f2[2]]), b1 = Add(Add(newco[f1[0]],newco[f1[1]]),q1), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; IF PresentVertex(mocta[i][2]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][2].exists *> END; WITH n = NewNumVer(mocta[i][2]), b0 = Add(Add(newco[e1[1]],newco[f0[0]]),newco[f0[1]]), b1 = Add(Add(newco[f2[0]],newco[f2[1]]),q1), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; IF PresentVertex(mocta[i][13]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][13].exists *> END; WITH n = NewNumVer(mocta[i][13]), b0 = Add(Add(newco[f0[0]],newco[e0[1]]),newco[f0[2]]), b1 = Add(Add(newco[f1[0]],newco[f1[2]]),q1), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; (* first internal vertex: q1 *) IF PresentVertex(inter[i][0]) THEN <* ASSERT NOT inter[i][0].exists *> WITH n = NewNumVer(inter[i][0]) DO newco[n] := q1; END END; WITH dx = (newco[f1[5]][0] - newco[f2[3]][0])/FLOAT(order-2, LONGREAL), dy = (newco[f1[5]][1] - newco[f2[3]][1])/FLOAT(order-2, LONGREAL), dz = (newco[f1[5]][2] - newco[f2[3]][2])/FLOAT(order-2, LONGREAL), dw = (newco[f1[5]][3] - newco[f2[3]][3])/FLOAT(order-2, LONGREAL), p0 = newco[f1[5]][0] - 1.0d0 * dx, p1 = newco[f1[5]][1] - 1.0d0 * dy, p2 = newco[f1[5]][2] - 1.0d0 * dz, p3 = newco[f1[5]][3] - 1.0d0 * dw, q2 = LR4.T{p0,p1,p2,p3}, r0 = newco[f1[5]][0] - 2.0d0 * dx, r1 = newco[f1[5]][1] - 2.0d0 * dy, r2 = newco[f1[5]][2] - 2.0d0 * dz, r3 = newco[f1[5]][3] - 2.0d0 * dw, q3 = LR4.T{r0,r1,r2,r3}, dx = (newco[f1[4]][0] - newco[f2[4]][0])/FLOAT(order-3, LONGREAL), dy = (newco[f1[4]][1] - newco[f2[4]][1])/FLOAT(order-3, LONGREAL), dz = (newco[f1[4]][2] - newco[f2[4]][2])/FLOAT(order-3, LONGREAL), dw = (newco[f1[4]][3] - newco[f2[4]][3])/FLOAT(order-3, LONGREAL), t0 = newco[f1[4]][0] - 1.0d0 * dx, t1 = newco[f1[4]][1] - 1.0d0 * dy, t2 = newco[f1[4]][2] - 1.0d0 * dz, t3 = newco[f1[4]][3] - 1.0d0 * dw, q4 = LR4.T{t0,t1,t2,t3} DO (* internal vertices: q2, q3, q4 *) IF PresentVertex(inter[i][1]) THEN <* ASSERT NOT inter[i][1].exists *> WITH n = NewNumVer(inter[i][1]) DO newco[n] := q4; END END; IF PresentVertex(inter[i][2]) THEN <* ASSERT NOT inter[i][2].exists *> WITH n = NewNumVer(inter[i][2]) DO newco[n] := q3; END END; IF PresentVertex(inter[i][3]) THEN <* ASSERT NOT inter[i][3].exists *> WITH n = NewNumVer(inter[i][3]) DO newco[n] := q2; END END; IF PresentVertex(mocta[i][7]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][7].exists *> END; WITH n = NewNumVer(mocta[i][7]), b0 = Add(Add(newco[f2[5]],newco[f2[4]]),newco[e5[2]]), b1 = Add(Add(newco[f3[5]],newco[f3[4]]),q4), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; IF PresentVertex(mocta[i][8]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][8].exists *> END; WITH n = NewNumVer(mocta[i][8]), b0 = Add(Add(newco[f2[4]],newco[f2[3]]),newco[e5[1]]), b1 = Add(Add(newco[f3[4]],newco[f3[3]]),q3), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; IF PresentVertex(mocta[i][3]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][3].exists *> END; WITH n = NewNumVer(mocta[i][3]), b0 = Add(Add(newco[e3[2]],newco[f2[2]]),newco[f2[5]]), b1 = Add(Add(newco[f1[1]],newco[f1[3]]),q4), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; IF PresentVertex(mocta[i][4]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][4].exists *> END; WITH n = NewNumVer(mocta[i][4]), b0 = Add(Add(newco[f2[2]],newco[f2[1]]),newco[f2[4]]), b1 = Add(Add(q1,q3),q4), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; IF PresentVertex(mocta[i][5]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][5].exists *> END; WITH n = NewNumVer(mocta[i][5]), b0 = Add(Add(newco[f2[1]],newco[e1[2]]),newco[f2[3]]), b1 = Add(Add(newco[f0[1]],newco[f0[3]]),q3), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; IF PresentVertex(mocta[i][12]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][12].exists *> END; WITH n = NewNumVer(mocta[i][12]), b0 = Add(Add(newco[f3[0]],newco[f3[1]]),newco[e2[1]]), b1 = Add(Add(newco[f0[4]],newco[f0[5]]),q2), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; IF PresentVertex(mocta[i][16]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][16].exists *> END; WITH n = NewNumVer(mocta[i][16]), b0 = Add(Add(newco[e4[1]],newco[f3[0]]),newco[f3[2]]), b1 = Add(Add(newco[f1[5]],newco[f1[4]]),q2), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; IF PresentVertex(mocta[i][18]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][18].exists *> END; WITH n = NewNumVer(mocta[i][18]), b0 = Add(Add(newco[e4[2]],newco[f3[2]]),newco[f3[5]]), b1 = Add(Add(newco[f1[4]],newco[f1[3]]),q4), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; IF PresentVertex(mocta[i][19]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][19].exists *> END; WITH n = NewNumVer(mocta[i][19]), b0 = Add(Add(newco[f3[2]],newco[f3[1]]),newco[f3[4]]), b1 = Add(Add(q2,q3),q4), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; IF PresentVertex(mocta[i][15]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][15].exists *> END; WITH n = NewNumVer(mocta[i][15]), b0 = Add(Add(newco[f3[1]],newco[e2[2]]),newco[f3[3]]), b1 = Add(Add(newco[f0[3]],newco[f0[4]]),q3), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; IF PresentVertex(mocta[i][11]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][11].exists *> END; WITH n = NewNumVer(mocta[i][11]), b0 = Add(Add(newco[f0[2]],newco[f0[5]]),q2), b1 = Add(Add(newco[e0[2]],newco[f1[2]]), newco[f1[5]]), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; IF PresentVertex(mocta[i][14]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][14].exists *> END; WITH n = NewNumVer(mocta[i][14]), b0 = Add(Add(newco[f0[1]],newco[f0[2]]),newco[f0[4]]), b1 = Add(Add(q1,q2),q3), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END; IF PresentVertex(mocta[i][17]) THEN IF NOT net THEN <* ASSERT NOT mocta[i][17].exists *> END; WITH n = NewNumVer(mocta[i][17]), b0 = Add(Add(newco[f1[2]],newco[f1[1]]),newco[f1[4]]), b1 = Add(Add(q1,q2), q4), b = Add(b0,b1) DO newco[n] := Scale(1.0d0/FLOAT(6, LONGREAL), b); END END END END END END; RETURN newco; END SettingCoords; PROCEDURE GlueTetrahedra(a,b: Pair) = (* This procedure realizes the gluing of two single tetrahedra. *) <* FATAL Thread.Alerted, Wr.Failure *> BEGIN IF Pneg(Spin(a)) = NIL AND Pneg(b) # NIL THEN EVAL Triangulation.Glue(Spin(a),b, 1, TRUE); ELSIF Pneg(a) = NIL AND Pneg(b) = NIL THEN EVAL Triangulation.Glue(a,Spin(b), 1, TRUE); ELSE Wr.PutText(stderr,"BuildRefinement: Not gluing some triangular faces\n"); Process.Exit(1); END; END GlueTetrahedra; PROCEDURE GlueMacroTetrahedra(ar,br: REF PAIR) = (* This procedure realizes the gluing of two macro-tetrahedra trough the triangulated macro-faces. *) BEGIN FOR i := 0 TO NUMBER(ar^)-1 DO GlueTetrahedra(ar[i],br[i]); END END GlueMacroTetrahedra; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFileTp"); o.inFileTp := pp.getNext(); pp.getKeyword("-inFileSt"); o.inFileSt := pp.getNext(); pp.getKeyword("-outFile"); o.outFile := pp.getNext(); pp.getKeyword("-order"); o.order := pp.getNextInt(1, 5); o.detail := pp.keywordPresent("-detail"); o.fixed := pp.keywordPresent("-fixed"); o.net := pp.keywordPresent("-net"); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: BuildRefinement \\\n"); Wr.PutText(stderr, " -inFileTp \\\n"); Wr.PutText(stderr, " -inFileSt \\\n"); Wr.PutText(stderr, " -outFile \\\n"); Wr.PutText(stderr, " -order [ -detail ] \\\n"); Wr.PutText(stderr, " [ -fixed ] [ -net ]\n"); Process.Exit (1); END END; RETURN o END GetOptions; PROCEDURE ModSetGrade( ord: CARDINAL; rco: Refine.Corner; Right,Left,Front,Back: BOOLEAN; ) = (* Set edges and spheres underling on the boundary of a tetrahedron as thin cylinders and small spheres. *) PROCEDURE ResetVertexonNet(a: Pair) = BEGIN WITH vn = OrgV(a) DO vn.exists := FALSE; END END ResetVertexonNet; PROCEDURE ResetEdgeOnNet(a: Pair) = BEGIN WITH en = a.facetedge.edge DO en.exists := FALSE; END END ResetEdgeOnNet; PROCEDURE SetGrade1() = BEGIN (* nothing *) END SetGrade1; PROCEDURE SetGrade2() = BEGIN (* 3 edges and 0 vertices for each face of the refined tetrahedron. *) (* On the right side. *) IF NOT Right THEN ResetEdgeOnNet(Enext_1(rco.right[0])); ResetEdgeOnNet( rco.right[3] ); ResetEdgeOnNet(Enext (rco.right[2])); END; (* On the left side. *) IF NOT Left THEN ResetEdgeOnNet(Enext_1(rco.left[0])); ResetEdgeOnNet( rco.left[2] ); ResetEdgeOnNet(Enext (rco.left[1])); END; (* On the front side. *) IF NOT Front THEN ResetEdgeOnNet( rco.front[0] ); ResetEdgeOnNet(Enext (rco.front[1])); ResetEdgeOnNet(Enext (rco.front[2])); END; (* On the back side. *) IF NOT Back THEN ResetEdgeOnNet( rco.back [0] ); ResetEdgeOnNet(Enext (rco.back [1])); ResetEdgeOnNet(Enext_1(rco.back [2])); END; END SetGrade2; PROCEDURE SetGrade3() = BEGIN (* 9 edges and 1 vertices for each face of the refined tetrahedron. *) SetGrade2(); (* On the right side. *) IF NOT Right THEN ResetEdgeOnNet(Enext_1(rco.right[3])); ResetEdgeOnNet(Enext_1(rco.right[1])); ResetEdgeOnNet( rco.right[8] ); ResetEdgeOnNet(Enext (rco.right[7])); ResetEdgeOnNet( rco.right[6] ); ResetEdgeOnNet(Enext (rco.right[5])); ResetVertexonNet(rco.right[3]); END; (* On the left side. *) IF NOT Left THEN ResetEdgeOnNet(Enext_1(rco.left[1])); ResetEdgeOnNet(Enext_1(rco.left[3])); ResetEdgeOnNet(Enext (rco.left[4])); ResetEdgeOnNet( rco.left[5] ); ResetEdgeOnNet(Enext (rco.left[6])); ResetEdgeOnNet( rco.left[7] ); ResetVertexonNet(rco.left[3]); END; (* On the front side. *) IF NOT Front THEN ResetEdgeOnNet( rco.front[1] ); ResetEdgeOnNet( rco.front[3] ); ResetEdgeOnNet(Enext (rco.front[4])); ResetEdgeOnNet(Enext (rco.front[5])); ResetEdgeOnNet(Enext (rco.front[6])); ResetEdgeOnNet(Enext (rco.front[7])); ResetVertexonNet(rco.front[3]); END; (* On the back side. *) IF NOT Back THEN ResetEdgeOnNet( rco.back [1] ); ResetEdgeOnNet( rco.back [3] ); ResetEdgeOnNet(Enext (rco.back [4])); ResetEdgeOnNet(Enext_1(rco.back [5])); ResetEdgeOnNet(Enext (rco.back [6])); ResetEdgeOnNet(Enext_1(rco.back [7])); ResetVertexonNet(rco.back[3]); END; END SetGrade3; PROCEDURE SetGrade4() = BEGIN (* 18 edges and 3 vertices for each face of the refined tetrahedron. *) SetGrade3(); (* On the right side. *) IF NOT Right THEN ResetEdgeOnNet(Enext_1(rco.right[8])); ResetEdgeOnNet(Enext_1(rco.right[6])); ResetEdgeOnNet(Enext_1(rco.right[4])); ResetEdgeOnNet( rco.right[15] ); ResetEdgeOnNet(Enext (rco.right[14])); ResetEdgeOnNet( rco.right[13] ); ResetEdgeOnNet(Enext (rco.right[12])); ResetEdgeOnNet( rco.right[11] ); ResetEdgeOnNet(Enext (rco.right[10])); ResetVertexonNet(rco.right[8]); ResetVertexonNet(rco.right[6]); END; (* On the left side. *) IF NOT Left THEN ResetEdgeOnNet(Enext_1(rco.left[4])); ResetEdgeOnNet(Enext_1(rco.left[6])); ResetEdgeOnNet(Enext_1(rco.left[8])); ResetEdgeOnNet(Enext (rco.left[9 ])); ResetEdgeOnNet( rco.left[10] ); ResetEdgeOnNet(Enext (rco.left[11])); ResetEdgeOnNet( rco.left[12] ); ResetEdgeOnNet(Enext (rco.left[13])); ResetEdgeOnNet( rco.left[14] ); ResetVertexonNet(rco.left[8]); ResetVertexonNet(rco.left[6]); END; (* On the front side. *) IF NOT Front THEN ResetEdgeOnNet( rco.front[4] ); ResetEdgeOnNet( rco.front[6] ); ResetEdgeOnNet( rco.front[8] ); ResetEdgeOnNet(Enext (rco.front[ 9])); ResetEdgeOnNet(Enext (rco.front[10])); ResetEdgeOnNet(Enext (rco.front[11])); ResetEdgeOnNet(Enext (rco.front[12])); ResetEdgeOnNet(Enext (rco.front[13])); ResetEdgeOnNet(Enext (rco.front[14])); ResetVertexonNet(rco.front[8]); ResetVertexonNet(rco.front[6]); END; (* On the back side. *) IF NOT Back THEN ResetEdgeOnNet( rco.back [4] ); ResetEdgeOnNet( rco.back [6] ); ResetEdgeOnNet( rco.back [8] ); ResetEdgeOnNet(Enext (rco.back [ 9])); ResetEdgeOnNet(Enext_1(rco.back [10])); ResetEdgeOnNet(Enext (rco.back [11])); ResetEdgeOnNet(Enext_1(rco.back [12])); ResetEdgeOnNet(Enext (rco.back [13])); ResetEdgeOnNet(Enext_1(rco.back [14])); ResetVertexonNet(rco.back[8]); ResetVertexonNet(rco.back[6]); END; END SetGrade4; PROCEDURE SetGrade5() = BEGIN (* 10 edges and 6 vertices for each face of the refined tetrahedron. *) SetGrade4(); (* On the right side. *) IF NOT Right THEN ResetEdgeOnNet(Enext_1(rco.right[15])); ResetEdgeOnNet(Enext_1(rco.right[13])); ResetEdgeOnNet(Enext_1(rco.right[11])); ResetEdgeOnNet(Enext_1(rco.right[ 9])); ResetEdgeOnNet( rco.right[24] ); ResetEdgeOnNet(Enext (rco.right[23])); ResetEdgeOnNet( rco.right[22] ); ResetEdgeOnNet(Enext (rco.right[21])); ResetEdgeOnNet( rco.right[20] ); ResetEdgeOnNet(Enext (rco.right[19])); ResetEdgeOnNet( rco.right[18] ); ResetEdgeOnNet(Enext (rco.right[17])); ResetVertexonNet(rco.right[15]); ResetVertexonNet(rco.right[13]); ResetVertexonNet(rco.right[11]); END; (* On the left side. *) IF NOT Left THEN ResetEdgeOnNet(Enext_1(rco.left[ 9])); ResetEdgeOnNet(Enext_1(rco.left[11])); ResetEdgeOnNet(Enext_1(rco.left[13])); ResetEdgeOnNet(Enext_1(rco.left[15])); ResetEdgeOnNet(Enext (rco.left[16])); ResetEdgeOnNet( rco.left[17] ); ResetEdgeOnNet(Enext (rco.left[18])); ResetEdgeOnNet( rco.left[19] ); ResetEdgeOnNet(Enext (rco.left[20])); ResetEdgeOnNet( rco.left[21] ); ResetEdgeOnNet(Enext (rco.left[22])); ResetEdgeOnNet( rco.left[23] ); ResetVertexonNet(rco.left[15]); ResetVertexonNet(rco.left[13]); ResetVertexonNet(rco.left[11]); END; (* On the front side. *) IF NOT Front THEN ResetEdgeOnNet( rco.front[ 9] ); ResetEdgeOnNet( rco.front[11] ); ResetEdgeOnNet( rco.front[13] ); ResetEdgeOnNet( rco.front[15] ); ResetEdgeOnNet(Enext (rco.front[16])); ResetEdgeOnNet(Enext (rco.front[17])); ResetEdgeOnNet(Enext (rco.front[18])); ResetEdgeOnNet(Enext (rco.front[19])); ResetEdgeOnNet(Enext (rco.front[20])); ResetEdgeOnNet(Enext (rco.front[21])); ResetEdgeOnNet(Enext (rco.front[22])); ResetEdgeOnNet(Enext (rco.front[23])); ResetVertexonNet(rco.front[15]); ResetVertexonNet(rco.front[13]); ResetVertexonNet(rco.front[11]); END; (* On the back side. *) IF NOT Back THEN ResetEdgeOnNet( rco.back [ 9] ); ResetEdgeOnNet( rco.back [11] ); ResetEdgeOnNet( rco.back [13] ); ResetEdgeOnNet( rco.back [15] ); ResetEdgeOnNet(Enext (rco.back [16])); ResetEdgeOnNet(Enext_1(rco.back [17])); ResetEdgeOnNet(Enext (rco.back [18])); ResetEdgeOnNet(Enext_1(rco.back [19])); ResetEdgeOnNet(Enext (rco.back [20])); ResetEdgeOnNet(Enext_1(rco.back [21])); ResetEdgeOnNet(Enext (rco.back [22])); ResetEdgeOnNet(Enext_1(rco.back [23])); ResetVertexonNet(rco.back[15]); ResetVertexonNet(rco.back[13]); ResetVertexonNet(rco.back[11]); END; END SetGrade5; <* FATAL Thread.Alerted, Wr.Failure *> BEGIN IF ord = 1 THEN SetGrade1(); ELSIF ord = 2 THEN SetGrade2(); ELSIF ord = 3 THEN SetGrade3(); ELSIF ord = 4 THEN SetGrade4(); ELSIF ord = 5 THEN SetGrade5(); ELSE Wr.PutText(stderr,"Order must be less equal to 5\n"); <* ASSERT ord <= 5 *> END; END ModSetGrade; BEGIN DoIt() END BuildRefinement. (**************************************************************************) (* *) (* Copyright (C) 2001 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/CameraPath.m3 MODULE CameraPath EXPORTS Main; (* Generates equally spaced sample points along a closed path around the origin Writes the sample points as camera positions in the format expected by the "Wire4"-Interactive 4D Wireframe Display Program (".w4"). Also writes a plain text file with one point per line (preceded by its integer ID). Implemented by stolfi 16-10-2000 *) IMPORT ParseParams, Process, Wr, Thread, OSError, FileWr, Mis, LR4, Fmt; FROM Math IMPORT sin, cos; FROM Stdio IMPORT stderr; TYPE Row3I = ARRAY [0..2] OF INTEGER; LONG = LONGREAL; Options = RECORD outFile: TEXT; (* Output file name prefix *) dist: LONGREAL; (* Nominal distance from origin *) normalize: BOOLEAN; (* If TRUE, normalize From-To vectors to length "dist". *) renderPoints: CARDINAL; (* Subsampling ratio for camera positions.*) wire4Points: CARDINAL; (* Number of vertices on path for Wire4 plotting. *) To4: LR4.T; (* Look at point *) Up4: LR4.T; (* Head-up point *) Over4: LR4.T; (* Hyperhead-up point *) END; <* FATAL Wr.Failure, Thread.Alerted, OSError.E *> PROCEDURE WriteColor(wr: Wr.T; READONLY c: Row3I) = (* Write colors in RGB mode *) BEGIN Mis.WriteInt(wr,c[0]); Wr.PutText(wr," "); Mis.WriteInt(wr,c[1]); Wr.PutText(wr," "); Mis.WriteInt(wr,c[2]); END WriteColor; PROCEDURE DoIt() = BEGIN WITH o = GetOptions(), comments = "Made by CameraPath on " & Mis.Today() & "\n", w4 = FileWr.Open(o.outFile & ".w4"), txt = FileWr.Open(o.outFile & ".from4") DO WriteComments(w4,o,comments); WriteComments(txt,o,comments); WriteWire4Header(w4, 3.0d0*o.dist); SamplePath(o,w4,txt); Wr.Close(w4); Wr.Close(txt); END END DoIt; PROCEDURE WriteComments( wr: Wr.T; <*UNUSED*>READONLY o: Options; comments: TEXT; ) = BEGIN Mis.WriteCommentsJS(wr,comments,'#'); Wr.PutText(wr, "\n"); END WriteComments; PROCEDURE WriteWire4Header(wr: Wr.T; dist: LONGREAL) = BEGIN Wr.PutText(wr, "DegreeRingEdges"); Wr.PutText(wr," 0"); Wr.PutText(wr,"\nDepthCueLevels 10"); Wr.PutText(wr,"\nFogDensity 0.5"); Wr.PutText(wr,"\n"); Wr.PutText(wr, "\nFrom4: " & Fmt.LongReal(dist) & " 00 00 00"); Wr.PutText(wr, "\nTo4 : 00 00 00 00"); Wr.PutText(wr, "\nUp4 : 00 00 +1 00"); Wr.PutText(wr, "\nOver4: 00 00 00 +1"); Wr.PutText(wr, "\nVangle4: 30"); Wr.PutText(wr, "\n"); Wr.PutText(wr, "\nFrom3: " & Fmt.LongReal(dist) & " 00 00"); Wr.PutText(wr, "\nTo3 : 00 00 00"); Wr.PutText(wr, "\nUp3 : 00 00 +1"); Wr.PutText(wr, "\nVangle3: 30"); Wr.PutText(wr, "\n"); END WriteWire4Header; PROCEDURE SamplePath(READONLY o: Options; w4: Wr.T; txt: Wr.T) = VAR vcolor : Row3I := Row3I{100,100,100}; ecolor : Row3I := Row3I{0,255,255}; vradius : REAL := 1.0; eradius : REAL := 1.0; CONST TwoPi = 6.28318530717958648d0; BEGIN PROCEDURE EvalPath(t: LONGREAL): LR4.T = BEGIN WITH r1 = 1.0d0, t1 = t, c1 = cos(t1), s1 = sin(t1), r2 = 0.7d0, t2 = 2.0d0*t + 1.0d0, c2 = cos(t2), s2 = sin(t2), p = LR4.T{ r1*c1, r1*s1, r2*c2, r2*s2 } DO IF o.normalize THEN RETURN LR4.Scale(o.dist, LR4.Dir(p)) ELSE RETURN LR4.Scale(o.dist, p) END END END EvalPath; PROCEDURE ComputeSampleTimes(nSteps: CARDINAL): REF ARRAY OF LONGREAL = (* Returns array "t[0..nSteps]" with "nSteps+1" equally spaced times in "[0..TwoPi]", including "t[0] = 0" and "t[nSteps] = TwoPi". *) VAR pAnt: LR4.T; BEGIN WITH fns = FLOAT(nSteps, LONGREAL), rt = NEW(REF ARRAY OF LONGREAL, nSteps + 1), t = rt^ DO pAnt := EvalPath(0.0d0); t[0] := 0.0d0; FOR i := 1 TO nSteps DO WITH fi = FLOAT(i,LONGREAL), ti = TwoPi*fi/fns DO t[i] := ti END END; RETURN rt; END END ComputeSampleTimes; PROCEDURE ComputePathLengths( READONLY t: ARRAY OF LONGREAL; ): REF ARRAY OF LONGREAL = (* Computes "s[i]" = path length from "t=0" to each "t[i]" *) VAR sAnt: LONGREAL; pAnt: LR4.T; BEGIN WITH nt = NUMBER(t), rs = NEW(REF ARRAY OF LONGREAL, nt), s = rs^ DO pAnt := EvalPath(0.0d0); sAnt := 0.0d0; FOR i := 0 TO nt-1 DO WITH pi = EvalPath(t[i]) DO sAnt := sAnt + LR4.Dist(pAnt, pi); s[i] := sAnt; pAnt := pi END END; RETURN rs; END END ComputePathLengths; PROCEDURE ComputeEquallySpacedPoints( READONLY t: ARRAY OF LONG;(*Times of some sample points along curve *) READONLY s: ARRAY OF LONG;(*Lengths to those sample points along curve *) np: CARDINAL; ): REF ARRAY OF LR4.T = (* Divides the interval "t[0]..t[LAST(t)]" into np equal intervals and returns an array with the beginning of each interval. *) VAR iCur: CARDINAL; tGoal: LONGREAL; BEGIN WITH nt = NUMBER(t), rp = NEW(REF ARRAY OF LR4.T, np), p = rp^, sIni = s[0], sFin = s[LAST(s)], ds = sFin - sIni DO <* ASSERT nt = NUMBER(s) *> iCur := 0; FOR k := 0 TO np-1 DO WITH sGoal = sIni + ds * FLOAT(k, LONGREAL)/FLOAT(np, LONGREAL) DO WHILE iCur < nt - 1 AND s[iCur+1] < sGoal DO INC(iCur) END; IF iCur >= nt-1 THEN tGoal := t[nt-1] ELSE WITH ds = s[iCur+1] - s[iCur], dt = t[iCur+1] - t[iCur] DO tGoal := t[iCur] + dt * (sGoal - s[iCur])/ds END END; p[k] := EvalPath(tGoal); END END; RETURN rp END END ComputeEquallySpacedPoints; PROCEDURE WriteCoord(wr: Wr.T; x: LONG) = BEGIN Wr.PutText(wr, Fmt.Pad(Fmt.LongReal(x, Fmt.Style.Fix, prec := 4), 7)); END WriteCoord; PROCEDURE WritePoint4DForWire4( READONLY c: LR4.T; vcolor: Row3I; vradius: REAL; ) = BEGIN WriteCoord(w4,c[0]); Wr.PutText(w4, " "); WriteCoord(w4,c[1]); Wr.PutText(w4, " "); WriteCoord(w4,c[2]); Wr.PutText(w4, " "); WriteCoord(w4,c[3]); Wr.PutText(w4, " : "); WriteColor(w4, vcolor); Wr.PutText(w4, " : "); Mis.WriteRadius(w4, vradius); Wr.PutText(w4, "\n"); END WritePoint4DForWire4; PROCEDURE WritePoint4DAsText(READONLY c: LR4.T; i: CARDINAL) = BEGIN Wr.PutText(txt, " " & Fmt.Int(i) & " "); WriteCoord(txt,c[0]); Wr.PutText(txt, " "); WriteCoord(txt,c[1]); Wr.PutText(txt, " "); WriteCoord(txt,c[2]); Wr.PutText(txt, " "); WriteCoord(txt,c[3]); Wr.PutText(txt, "\n"); END WritePoint4DAsText; BEGIN WITH nr = o.renderPoints, nw = o.wire4Points, ns = 50*MAX(nr, nw), t = ComputeSampleTimes(ns)^, s = ComputePathLengths(t)^ DO (* Camera positions for rendering *) WITH pr = ComputeEquallySpacedPoints(t, s, nr)^ DO FOR k := 0 TO LAST(pr) DO WritePoint4DAsText(pr[k],k); END END; (* Camera positions for wire4 *) Wr.PutText(w4, "\n\nVertexList : "); Wr.PutText(w4, Fmt.Int(nw+5) & "\n"); WITH pw = ComputeEquallySpacedPoints(t, s, nw)^ DO FOR k := 0 TO LAST(pw) DO WritePoint4DForWire4(pw[k],vcolor,vradius); END END; (* reference axis vertices *) Wr.PutText(w4, " 0 0 0 0 : 255 255 255 : 0\n"); Wr.PutText(w4, " 1 0 0 0 : 255 255 255 : 0\n"); Wr.PutText(w4, " 0 1 0 0 : 255 255 255 : 0\n"); Wr.PutText(w4, " 0 0 1 0 : 255 255 255 : 0\n"); Wr.PutText(w4, " 0 0 0 1 : 255 255 255 : 0\n"); Wr.PutText(w4, "\n"); Wr.PutText(w4, "\nEdgeList " & Fmt.Int(nw+4) & ":\n"); FOR i := 0 TO nw-1 DO Wr.PutText(w4, Fmt.Pad(Fmt.Int(i), 4) & " " & Fmt.Pad(Fmt.Int((i+1) MOD nw),4) ); Wr.PutText(w4, " : "); (* color *) WriteColor(w4, ecolor); Wr.PutText(w4, " : "); Mis.WriteRadius(w4, eradius); Wr.PutText(w4, "\n"); END; (* reference axis edges *) Wr.PutText(w4, " " & Fmt.Int(nw) & " " & Fmt.Int(nw+1) ); Wr.PutText(w4, " : 125 125 125 : 1\n"); Wr.PutText(w4, " " & Fmt.Int(nw) & " " & Fmt.Int(nw+2) ); Wr.PutText(w4, " : 125 125 125 : 1\n"); Wr.PutText(w4, " " & Fmt.Int(nw) & " " & Fmt.Int(nw+3) ); Wr.PutText(w4, " : 125 125 125 : 1\n"); Wr.PutText(w4, " " & Fmt.Int(nw) & " " & Fmt.Int(nw+4) ); Wr.PutText(w4, " : 125 125 125 : 1\n"); Wr.PutText(w4, "\nFaceList 0\n"); Wr.Close(w4); END END END SamplePath; PROCEDURE GetOptions(): Options = VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-outFile"); o.outFile := pp.getNext(); pp.getKeyword("-dist"); o.dist := pp.getNextLongReal(1.0d-10,1.0d+10); o.normalize := pp.keywordPresent("-normalize"); IF pp.keywordPresent("-renderPoints") THEN o.renderPoints := pp.getNextInt(1,10000); ELSE o.renderPoints := 10; END; IF pp.keywordPresent("-wire4Points") THEN o.wire4Points := pp.getNextInt(1,10000); ELSE o.wire4Points := 10; END; pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: CameraPath \\\n"); Wr.PutText(stderr, " -outFile \\\n"); Wr.PutText(stderr, " -dist [ -normalize ] \\\n"); Wr.PutText(stderr, " [ -renderPoints ] \\\n"); Wr.PutText(stderr, " [ -wire4Points ]\n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt(); END CameraPath. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/Circle.m3 MODULE circle EXPORTS Main; IMPORT Stdio, Wr, Fmt, Thread, Math, Rd, Scan, FloatMode, Lex; FROM Math IMPORT cos; FROM Stdio IMPORT stderr, stdin; VAR n: CARDINAL; teta: LONGREAL := 0.0d0; y: LONGREAL; <* FATAL Wr.Failure, Thread.Alerted, Rd.EndOfFile, FloatMode.Trap, Rd.Failure, Lex.Error *> PROCEDURE ReadInt() : INTEGER = BEGIN RETURN Scan.Int(Rd.GetLine(stdin)); END ReadInt; BEGIN Wr.PutText(stderr, "Input an integer in the next line\n"); n := ReadInt(); WITH count = 360 DIV n DO FOR i:= 0 TO n-1 DO teta := FLOAT(count,LONGREAL) + teta; WITH nr = FLOAT((teta * FLOAT(Math.Pi,LONGREAL))/180.0d0,LONGREAL), x = cos(nr), x2 = FLOAT(x * x,LONGREAL) DO IF nr > FLOAT(Math.Pi,LONGREAL) THEN y := Math.sqrt(1.0d0-x2); ELSE y := -Math.sqrt(1.0d0-x2); END; Wr.PutText(stderr, Fmt.LongReal(x) & " " & Fmt.LongReal(y) & "\n"); END END END END circle. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/Cross.m3 (* Programa para testar as propriedades do produto cruzado no R4. 1) Se os vetores nao sao l. i. retorna vetor nulo 2) Se mudar a ordem dos operandos muda o sentido do vetor "cross" 3) O vetor "cross" \'e ortogonal aos 3 vetores argumentos 4) O produto cross de A x b x c onde A = K a equivale a: K (a x b x c) *) MODULE Cross EXPORTS Main; IMPORT Stdio, Wr, LR4, LR4Extras, Fmt, Thread, Math, Mis; <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH p1 = LR4.T{ 1.0000d00, 1.00000d0, 1.0000d0, 1.000d00}, p2 = LR4.T{ 2.0000d00, 0.30000d0, 3.000d00, 3.000d00}, p3 = LR4.T{-0.1470d00, -0.7930d00, 0.663d001, -0.000d0}, pp = LR4.Scale(2.0d0, p1), m = LR4Extras.Cross(p1,p2,p3), n = LR4Extras.Cross(pp,p2,p3), nn = LR4.Scale(2.0d0, m), a = LR4.Dot(m,p1), b = LR4.Dot(m,p2), c = LR4.Dot(m,p3) DO Mis.WritePoint(Stdio.stdout, n); Wr.PutText(Stdio.stdout, "\n"); Mis.WritePoint(Stdio.stdout, nn); Wr.PutText(Stdio.stdout, "\n"); Wr.PutText(Stdio.stdout, Fmt.LongReal(a) & " " & Fmt.LongReal(b) & " " & Fmt.LongReal(c) & "\n"); END; END Cross. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/DegreeOfVertex.m3 MODULE DegreeOfVertex EXPORTS Main; (* This module prints the degree of each vertex. *) IMPORT Triangulation, ParseParams, Process, Wr, Thread, Fmt; FROM Stdio IMPORT stderr; TYPE Options = RECORD inFile: TEXT; END; PROCEDURE DoIt() = <* FATAL Thread.Alerted, Wr.Failure *> BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToMa(o.inFile), top = tc.top DO Wr.PutText(stderr, "vertex label degree\n"); Wr.PutText(stderr, "----------------------\n"); FOR i := 0 TO top.NV-1 DO WITH a = top.out[i], v = Triangulation.OrgV(a), l = v.label, d = Triangulation.DegreeOfVertex(a) DO Wr.PutText(stderr, Fmt.Pad(Fmt.Int(i),5) & " " & l & Fmt.Pad(Fmt.Int(d),7) & "\n"); END END END END DoIt; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFile"); o.inFile := pp.getNext(); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr,"Usage: DegreeOfVertex \\\n"); Wr.PutText(stderr," -inFile \n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt(); END DegreeOfVertex. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/Depthcueing4D.m3 MODULE Depthcueing4D EXPORTS Main; (* This program performs the 4D depth-cueing by POVray tracer. The include file must be process with the "povray-3.1a-1" version in /n/lac/pkg/povray-3.1a-1/PUB/sun4-SunOS-5.5 See the copyright and authorship futher down. Revisions: 09-05-2000: Added in the rendering the vertices (spheres) 20-05-2000: Added the silhouette faces. 19-07-2000: Added the original faces. *) IMPORT Triangulation, ParseParams, Process, Wr, Thread, Text, Mis, LR4, LR4Extras, Math, Tridimensional, Fmt, LR3, FileWr, OSError, R3; FROM Stdio IMPORT stderr; FROM Octf IMPORT Tors, Clock, Enext, Enext_1; FROM Triangulation IMPORT Topology, Coords, OrgV, Vertex, Pair, TetraNegPosVertices; FROM Tridimensional IMPORT Coord3D; FROM Pov IMPORT WritePOVPoint, WritePOVColor, WritePOVSphere, WritePOVTriangle; FROM Wr IMPORT PutText; VAR bari : LR4.T; cmap : REF ARRAY OF Row3I; Wa,Wb,Wc,Wd : LR4.T; vstack := NEW(REF ARRAY OF CARDINAL, IniStackSize); (* stack for vertices *) vtop : CARDINAL := 0; (* top for the above stack *) CONST Epsilon = 0.0000000001d0; IniStackSize = 100000; TYPE Row3I = ARRAY[0..2] OF INTEGER; Quad = RECORD u, v, w, x: CARDINAL END; Options = RECORD inFileTp: TEXT; inFileSt: TEXT; outFile: TEXT; projectionName: TEXT; autoProject: BOOLEAN; normalize: LONGREAL; (* Normalize al vertices onto the S^3 with that radius. *) From4: LR4.T; (* *) To4: LR4.T; (* 4D viewing parameters as expected by the *) Up4: LR4.T; (* "Wire4"- Interactive 4D Wireframe Display *) Over4: LR4.T; (* Program. *) Vangle4: LONGREAL; (* *) printDepth: BOOLEAN; colormap : BOOLEAN; dc_ColorFar: Row3I; dc_ColorNear: Row3I; dc_DepthFar: LONGREAL; dc_DepthNear: LONGREAL; dc_Levels: INTEGER; silhouette : BOOLEAN; (* draws the silhouette faces *) color : R3.T; (* attributes of color and opacity for silhouette *) opacity : REAL; (* faces; Transparent (opacity=1) Opaque (opacity=0)*) faces : BOOLEAN; (* draws the original faces *) END; PROCEDURE WL(x: LONGREAL) : TEXT = BEGIN RETURN(Fmt.Pad(Fmt.LongReal(x, Fmt.Style.Fix, prec := 2), 6)); END WL; PROCEDURE Sign(d: LONGREAL) : BOOLEAN = (* Return TRUE iff the longreal value is positive, FALSE c.c. *) BEGIN <* ASSERT d # 0.0d0 *> IF d < 0.0d0 THEN RETURN FALSE ELSE RETURN TRUE END; END Sign; PROCEDURE DoIt() = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options := GetOptions(); newcomments: TEXT; BEGIN WITH tc = Triangulation.ReadToMa(o.inFileTp), top = tc.top, rc = Triangulation.ReadState(o.inFileSt), c = rc^, rc3 = NEW(REF Tridimensional.Coord3D, top.NV), c3 = rc3^, rdepth = NEW(REF ARRAY OF LONGREAL, top.NV), depth = rdepth^, comments = tc.comments & "\nProjected in " & o.projectionName & ": " & o.outFile & ".st3 on " & Mis.Today() DO cmap := NEW(REF ARRAY OF Row3I, o.dc_Levels); SetColorMap(o); IF o.colormap THEN PrintColorMap(o) END; IF o.normalize > 0.0d0 THEN Wr.PutText(stderr, "projecting vertices onto the unit S^3\n"); NormalizeVertexCoords(c, o.normalize); END; IF o.autoProject THEN SelectProjection(o, c, top); newcomments := comments & "\nWith AutoProject"; ELSE newcomments := comments & "\nParameters: " & "\nFrom4: " & WL(o.From4[0]) & WL(o.From4[1]) & WL(o.From4[2]) & WL(o.From4[3]) & "\nTo4: " & WL(o.To4[0]) & WL(o.To4[1]) & WL(o.To4[2]) & WL(o.To4[3]) & "\nUp4: " & WL(o.Up4[0]) & WL(o.Up4[1]) & WL(o.Up4[2]) & WL(o.Up4[3]) & "\nOver4: " & WL(o.Over4[0]) & WL(o.Over4[1]) & WL(o.Over4[2]) & WL(o.Over4[3]) & "\nVangle4: " & WL(o.Vangle4); END; ProjectTo3D(o, c, c3, depth, top); IF Text.Equal(o.projectionName, "Parallel") THEN WritePOVFile(o, depth, o.outFile & "-Par", top, c3); ELSIF Text.Equal(o.projectionName, "Perspective") THEN WritePOVFile(o, depth, o.outFile & "-Per", top, c3); END; bari := Triangulation.Barycenter(top, c); END END DoIt; PROCEDURE NormalizeVertexCoords(VAR c: Coords; newR: LONGREAL) = BEGIN WITH b = Barycenter(c) DO FOR i := 0 TO LAST(c) DO WITH p = c[i], q = LR4.Sub(p, b), r = LR4.Norm(q) DO IF r > 0.0d0 THEN p := LR4.Scale(newR/r, q) END END END END END NormalizeVertexCoords; PROCEDURE Barycenter(READONLY c: Coords): LR4.T = VAR B: LR4.T := LR4.T{0.0d0, ..}; BEGIN FOR i := 0 TO LAST(c) DO B := LR4.Add(B, c[i]) END; RETURN LR4.Scale(1.0d0/FLOAT(NUMBER(c), LONGREAL), B) END Barycenter; PROCEDURE CalcV4Matrix(READONLY o: Options) = (* This procedure computes the four basis vectors for the 4D viewing matrix, Wa,Wb,Wc, and Wd. Note that the Up vector transforms to Wb, the Over vector transforms to Wc, and the line of sight transforms to Wd. The Wa vector is then computed from Wb,Wc and Wd. *) <* FATAL Wr.Failure, Thread.Alerted *> VAR norm : LONGREAL; BEGIN (* Calculate Wd, the 4th coordinate basis vector and line-of-sight. *) Wd := LR4.Sub(o.To4,o.From4); norm := LR4.Norm(Wd); IF norm < Epsilon THEN Wr.PutText(stderr,"4D To Point and From Point are the same\n"); Process.Exit(1); END; Wd := LR4.Scale(1.0d0/norm, Wd); (* Calculate Wa, the X-axis basis vector. *) Wa := LR4Extras.Cross(o.Up4,o.Over4,Wd); norm := LR4.Norm(Wa); IF norm < Epsilon THEN Wr.PutText(stderr, "4D up,over and view vectors are not perpendicular\n"); Process.Exit(1); END; Wa := LR4.Scale(1.0d0/norm, Wa); (* Calculate Wb, the perpendicularized Up vector. *) Wb := LR4Extras.Cross(o.Over4,Wd,Wa); norm := LR4.Norm(Wb); IF norm < Epsilon THEN Wr.PutText(stderr,"Invalid 4D over vector\n"); Process.Exit(1); END; Wb := LR4.Scale(1.0d0/norm, Wb); (* Calculate Wc, the perpendicularized Over vector. Note that the resulting vector is already normalized, since Wa, Wb and Wd are all unit vectors. *) Wc := LR4Extras.Cross(Wd,Wa,Wb); END CalcV4Matrix; PROCEDURE ProjectTo3D( READONLY o: Options; READONLY c: Coords; VAR c3: Tridimensional.Coord3D; VAR depth: ARRAY OF LONGREAL; READONLY top: Topology ) = <* FATAL Wr.Failure, Thread.Alerted *> VAR Tan2Vangle4, Data4Radius, pconst, rtemp: LONGREAL; TempV : LR4.T; BEGIN WITH angle = o.Vangle4/2.0d0, angler = (FLOAT(Math.Pi,LONGREAL)*angle)/180.0d0 DO Tan2Vangle4 := Math.tan(angler); END; (* Find the radius of the 4D data. The radius of the 4D data is the radius of the smallest enclosing sphere, centered at the To point. Note that during the loop through the vertices, Data4Radius holds the squared radius value. *) Data4Radius := 0.0d0; FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i], Temp4 = LR4.Sub(c[v.num],o.To4), dist = LR4.Dot(Temp4,Temp4) DO IF dist > Data4Radius THEN Data4Radius := dist; END END END; Data4Radius := Math.sqrt(Data4Radius); Wr.PutText(stderr,"Data4Radius: "& Fmt.Pad(Fmt.LongReal(Data4Radius, Fmt.Style.Fix, prec := 4),8)&"\n\n"); CalcV4Matrix(o); IF Text.Equal(o.projectionName, "Parallel") THEN rtemp := 1.0d0 / Data4Radius; ELSE pconst := 1.0d0 / Tan2Vangle4; END; FOR i := 0 TO top.NV-1 DO (* Transform the vertices from 4D World coordinates to 4D eye coordinates. *) WITH v = top.vertex[i] DO TempV := LR4.Sub(c[v.num],o.From4); depth[v.num] := LR4.Dot(TempV,Wd); IF Text.Equal(o.projectionName, "Perspective") THEN rtemp := pconst / depth[v.num]; END; IF o.printDepth THEN Wr.PutText(stderr, "v[" & Fmt.Pad(Fmt.Int(v.num),4) & "] depth = " & Fmt.Pad(Fmt.LongReal(depth[v.num],Fmt.Style.Fix,prec:=4),8) & "\n"); END; c3[v.num][0] := rtemp * LR4.Dot(TempV, Wa); c3[v.num][1] := rtemp * LR4.Dot(TempV, Wb); c3[v.num][2] := rtemp * LR4.Dot(TempV, Wc); END END END ProjectTo3D; PROCEDURE TetrahedronVertices(f:Triangulation.Pair): ARRAY [0..3] OF CARDINAL = BEGIN WITH g = Tors(f), h = Tors(Clock(Enext_1(f))), p = OrgV(g).num, q = OrgV(Enext(g)).num, r = OrgV(Enext_1(g)).num, s = OrgV(Enext_1(h)).num DO RETURN ARRAY [0..3] OF CARDINAL{p, q, r, s} END END TetrahedronVertices; PROCEDURE SelectProjection( VAR o: Options; READONLY c: Coords; READONLY top: Topology ) = VAR norm: LR4.T := LR4.T{0.0d0, ..}; BEGIN FOR i := 0 TO top.NP-1 DO WITH f = top.region[i], k = TetrahedronVertices(f), p = c[k[0]], q = c[k[1]], r = c[k[2]], s = c[k[3]], pq = LR4.Sub(q, p), pr = LR4.Sub(r, p), ps = LR4.Sub(s, p), v = LR4Extras.Cross(pq, pr, ps), n = LR4.Dir(v) DO norm := LR4.Add(norm, n) END END; WITH m = LR4.Norm(norm) DO IF m < 1.0d-20 THEN norm := LR4.T{1.0d0, 0.0d0, ..} ELSE norm := LR4.Scale(1.0d0/m, norm) END END; WITH bar = Triangulation.Barycenter(top, c) DO o.To4 := bar; o.From4 := LR4.Add(o.To4, norm); SelectTwoIndepDirs(norm, o.Up4, o.Over4); o.Vangle4 := 120.0d0; END; END SelectProjection; PROCEDURE SelectTwoIndepDirs( READONLY u: LR4.T; VAR v, w: LR4.T; ) = (* Selects two vectors "v", "w", independent of each other and of the given vector "u". *) VAR m: CARDINAL := 0; BEGIN (* Find the largest coordinate of "u": *) FOR i := 1 TO 3 DO IF ABS(u[i]) > ABS(u[m]) THEN m := i END END; FOR i := 0 TO 3 DO v[i] := 0.0d0; w[i] := 0.0d0 END; v[(m+1) MOD 4] := 1.0d0; w[(m+2) MOD 4] := 1.0d0; END SelectTwoIndepDirs; PROCEDURE WritePOVFile( READONLY op: Options; READONLY depth: ARRAY OF LONGREAL; name: TEXT; READONLY top: Topology; READONLY c3: Tridimensional.Coord3D; ) = <* FATAL Wr.Failure, Thread.Alerted, OSError.E *> BEGIN WITH wr = FileWr.Open(name & ".inc") DO Wr.PutText(wr, "// Include File: <" & name & ".inc>\n"); WritePOV(op, depth, wr, top, c3); Wr.Close(wr) END END WritePOVFile; PROCEDURE WritePOV( READONLY op: Options; READONLY depth: ARRAY OF LONGREAL; wr: Wr.T; READONLY top: Topology; READONLY c3: Coord3D; ) = <* FATAL Wr.Failure, Thread.Alerted *> PROCEDURE WritePOVCylinder4DC( READONLY o,d: LR3.T; radius: REAL; READONLY cr: ARRAY [0..1] OF R3.T; ) = (* Defines a finity length cylinder without parallel end caps with 4D depthcueing. This effect is obtained by the use of color map that modified the pigments colors through the length cylinder. *) BEGIN Wr.PutText(wr," cylinder {\n"); Wr.PutText(wr," "); WritePOVPoint(wr,o); Wr.PutText(wr, ",\n"); Wr.PutText(wr," "); WritePOVPoint(wr,d); Wr.PutText(wr, ",\n"); Wr.PutText(wr," " & Fmt.Real(radius) & "\n"); Wr.PutText(wr," open\n"); Wr.PutText(wr," pigment {\n"); Wr.PutText(wr," gradient "); WritePOVPoint(wr,LR3.Sub(d,o)); Wr.PutText(wr,"\n"); Wr.PutText(wr," color_map{\n"); Wr.PutText(wr," [0.0 color "); WritePOVColor(wr,cr[0]); Wr.PutText(wr,"]\n"); Wr.PutText(wr," [1.0 color "); WritePOVColor(wr,cr[1]); Wr.PutText(wr,"]\n"); Wr.PutText(wr," }\n"); Wr.PutText(wr," translate "); WritePOVPoint(wr,o); Wr.PutText(wr,"\n"); Wr.PutText(wr," }\n"); Wr.PutText(wr," }\n\n"); Wr.Flush(wr); END WritePOVCylinder4DC; PROCEDURE FindOriR3(q: Quad) : LONGREAL = (* For each tetrahedron with extremus vertices numbers u,v,w,x compute us its orientation in R^{3} through the 4x4 determinant: _ _ | c3[q.u][0] c3[q.u][1] c3[q.u][2] 1.0d0 | B = | c3[q.v][0] c3[q.v][1] c3[q.v][2] 1.0d0 | | c3[q.w][0] c3[q.w][1] c3[q.w][2] 1.0d0 | | c3[q.x][0] c3[q.x][1] c3[q.x][2] 1.0d0 | - - *) BEGIN WITH a = LR4.T{c3[q.u][0], c3[q.u][1], c3[q.u][2], 1.0d0}, b = LR4.T{c3[q.v][0], c3[q.v][1], c3[q.v][2], 1.0d0}, c = LR4.T{c3[q.w][0], c3[q.w][1], c3[q.w][2], 1.0d0}, d = LR4.T{c3[q.x][0], c3[q.x][1], c3[q.x][2], 1.0d0} DO RETURN LR4Extras.Det(a,b,c,d); END END FindOriR3; PROCEDURE SilhouetteFaces(a: Pair) : BOOLEAN = (* Return TRUE iff the face associated to the pair "a" is a silhouette face, FALSE c.c. *) BEGIN WITH t = TetraNegPosVertices(a), un = t[0].num, vn = t[1].num, wn = t[2].num, xn = t[3].num, yn = t[4].num, t1 = Quad{un,vn,wn,xn}, t2 = Quad{un,vn,wn,yn}, d1 = FindOriR3(t1), d2 = FindOriR3(t2) DO IF (Sign(d1) AND Sign(d2)) OR ((NOT Sign(d1)) AND (NOT Sign(d2))) THEN RETURN TRUE ELSE RETURN FALSE END END END SilhouetteFaces; VAR cr: ARRAY [0..1] OF R3.T; BEGIN FOR i := 0 TO top.NE-1 DO WITH e = top.edge[i] DO IF e.exists THEN WITH a = e.pa, ov = OrgV(a), dv = OrgV(Clock(a)), or = ov.num, de = dv.num, cm = LineDepthCue(op,ov,dv,depth) DO FOR i := 0 TO 1 DO FOR j := 0 TO 2 DO cr[i][j] := FLOAT(cm[i][j],REAL)/255.0; END; END; WritePOVCylinder4DC(c3[or], c3[de], e.radius, cr); WITH ov = NARROW(ov, Vertex), dv = NARROW(dv, Vertex) DO IF NOT Present(vstack,vtop,or) THEN WritePOVSphere(wr,c3[or], ov.radius, cr[0], 0.0, TRUE); Save(vstack,vtop,ov.num); END; IF NOT Present(vstack,vtop,de) THEN WritePOVSphere(wr,c3[de], dv.radius, cr[1], 0.0, TRUE); Save(vstack,vtop,dv.num); END END END END END END; IF op.silhouette THEN FOR i := 0 TO top.NF-1 DO WITH f = top.face[i], a = f.pa, un = OrgV(a).num, vn = OrgV(Enext(a)).num, wn = OrgV(Enext_1(a)).num, c = op.color, t = op.opacity DO IF SilhouetteFaces(a) AND (NOT f.exists) THEN WritePOVTriangle(wr,c3[un], c3[vn], c3[wn],c,t, TRUE); END END END END; IF op.faces THEN FOR i := 0 TO top.NF-1 DO WITH f = top.face[i], a = f.pa, un = OrgV(a).num, vn = OrgV(Enext(a)).num, wn = OrgV(Enext_1(a)).num, t3 = f.transp, tp = (t3[0] + t3[1] + t3[2]) / 3.0, co = f.color DO IF f.exists THEN WritePOVTriangle(wr,c3[un], c3[vn], c3[wn], co, tp, TRUE); END END END END; Wr.Flush(wr); END WritePOV; PROCEDURE LineDepthCue( READONLY o: Options; P,Q: Vertex; READONLY depth: ARRAY OF LONGREAL; ) : ARRAY[0..1] OF Row3I = (* This function computes the colors for 4D depthcueing. The main approach used is to subdivide the pigment into dc_Levels subsegments, that is realized by the "gradient " implemented by J. Stolfi in the "povray-3.1a-1" version, where is an arbitrary vector. *) VAR cd : ARRAY[0..1] OF Row3I; BEGIN WITH depthP = depth[P.num], depthQ = depth[Q.num], dc_DFar_DNear = o.dc_DepthFar - o.dc_DepthNear, dscale = FLOAT(o.dc_Levels,LONGREAL) / dc_DFar_DNear DO IF depthP < o.dc_DepthNear THEN cd[0] := Row3I{cmap[0][0],cmap[0][1],cmap[0][2]}; ELSIF depthP > o.dc_DepthFar THEN cd[0] := Row3I{cmap[o.dc_Levels-1][0], cmap[o.dc_Levels-1][1], cmap[o.dc_Levels-1][2]}; ELSE cd[0] := Row3I{cmap[FLOOR(dscale*(depthP-o.dc_DepthNear))][0], cmap[FLOOR(dscale*(depthP-o.dc_DepthNear))][1], cmap[FLOOR(dscale*(depthP-o.dc_DepthNear))][2]}; END; IF depthQ < o.dc_DepthNear THEN cd[1] := Row3I{cmap[0][0],cmap[0][1],cmap[0][2]}; ELSIF depthQ > o.dc_DepthFar THEN cd[1] := Row3I{cmap[o.dc_Levels-1][0], cmap[o.dc_Levels-1][1], cmap[o.dc_Levels-1][2]}; ELSE cd[1] := Row3I{cmap[FLOOR(dscale*(depthQ-o.dc_DepthNear))][0], cmap[FLOOR(dscale*(depthQ-o.dc_DepthNear))][1], cmap[FLOOR(dscale*(depthQ-o.dc_DepthNear))][2]}; END; RETURN cd; END END LineDepthCue; PROCEDURE SetColorMap(READONLY o: Options) = (* Set up the depthcue color map. *) VAR range: INTEGER; BEGIN FOR rgb := 0 TO 2 DO range := o.dc_ColorFar[rgb] - o.dc_ColorNear[rgb]; IF range < 0 THEN range := range - 1; ELSE range := range + 1; END; FOR i := 0 TO o.dc_Levels-1 DO cmap[i][rgb]:= o.dc_ColorNear[rgb]+ (i*range) DIV o.dc_Levels; END END END SetColorMap; PROCEDURE PrintColorMap(READONLY o: Options) = (* Print the depthcue color map. *) <* FATAL Wr.Failure, Thread.Alerted *> BEGIN FOR i := 0 TO o.dc_Levels-1 DO Wr.PutText(stderr," cmap["&Fmt.Pad(Fmt.Int(i),2)&"] is"); FOR rgb := 0 TO 2 DO Wr.PutText(stderr, Fmt.Pad(Fmt.Int(cmap[i][rgb]), 4)); END; Wr.PutText(stderr,"\n"); END END PrintColorMap; PROCEDURE Save( VAR Stack: REF ARRAY OF CARDINAL; VAR top,element: CARDINAL; ) = (* Saves the "element" on the stack "Stack". *) BEGIN Stack[top] := element; top := top + 1; END Save; PROCEDURE Present( READONLY Stack: REF ARRAY OF CARDINAL; top,element: CARDINAL; ) : BOOLEAN = (* Return TRUE if "element" its on the stack, FALSE c.c. *) VAR nstack1: CARDINAL := top; BEGIN WHILE nstack1 > 0 DO nstack1 := nstack1 - 1; IF Stack[nstack1] = element THEN RETURN TRUE END; END; RETURN FALSE; END Present; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFileTp"); o.inFileTp := pp.getNext(); pp.getKeyword("-inFileSt"); o.inFileSt := pp.getNext(); IF pp.keywordPresent("-outFile") THEN o.outFile := pp.getNext() ELSE o.outFile := o.inFileTp END; pp.getKeyword("-projection"); o.projectionName := pp.getNext(); IF NOT (Text.Equal(o.projectionName, "Parallel") OR Text.Equal(o.projectionName, "Perspective")) THEN pp.error("Bad projection \"" & pp.getNext() & "\"\n") END; IF pp.keywordPresent("-normalize") THEN (* Desired radius of model in R^4 *) o.normalize := pp.getNextLongReal(1.0d-10,1.0d+10); ELSE o.normalize := 0.0d0 (* No normalization *) END; IF pp.keywordPresent("-autoProject") THEN o.autoProject := TRUE ELSE IF pp.keywordPresent("-From4") THEN FOR j := 0 TO 3 DO o.From4[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.From4 := LR4.T{0.0d0,0.0d0,0.0d0,-3.0d0}; END; IF pp.keywordPresent("-To4") THEN FOR j := 0 TO 3 DO o.To4[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.To4 := LR4.T{0.0d0,0.0d0,0.0d0,0.0d0}; END; IF pp.keywordPresent("-Up4") THEN FOR j := 0 TO 3 DO o.Up4[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.Up4 := LR4.T{0.0d0,1.0d0,0.0d0,0.0d0}; END; IF pp.keywordPresent("-Over4") THEN FOR j := 0 TO 3 DO o.Over4[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.Over4 := LR4.T{0.0d0,0.0d0,1.0d0,0.0d0}; END; END; IF pp.keywordPresent("-Vangle4") THEN o.Vangle4 := pp.getNextLongReal(1.0d0, 179.0d0); ELSE o.Vangle4 := 25.0d0; END; o.printDepth := pp.keywordPresent("-printDepth"); o.colormap := pp.keywordPresent("-colormap"); IF pp.keywordPresent("-ColorFar") THEN FOR j := 0 TO 2 DO o.dc_ColorFar[j] := pp.getNextInt(0,255); END; ELSE o.dc_ColorFar:= Row3I{255, 255, 255}; END; IF pp.keywordPresent("-ColorNear") THEN FOR j := 0 TO 2 DO o.dc_ColorNear[j] := pp.getNextInt(0,255); END; ELSE o.dc_ColorNear:= Row3I{0, 0, 0}; END; IF pp.keywordPresent("-DepthNear") THEN o.dc_DepthNear := pp.getNextLongReal(-1000.0d0, 1000.0d0); ELSE o.dc_DepthNear:= 2.0d0; END; IF pp.keywordPresent("-DepthFar") THEN o.dc_DepthFar := pp.getNextLongReal(-1000.0d0, 1000.0d0); ELSE o.dc_DepthFar := 6.0d0; END; IF pp.keywordPresent("-DepthCueLevels") THEN o.dc_Levels := pp.getNextInt(0, 10000); ELSE o.dc_Levels := 6; END; IF pp.keywordPresent("-silhouette") THEN o.silhouette := TRUE; IF pp.keywordPresent("-color") THEN FOR j := 0 TO 2 DO o.color[j] := pp.getNextReal(0.0,1.0); END; ELSE o.color := R3.T{1.0,1.0,0.75}; END; IF pp.keywordPresent("-opacity") THEN o.opacity := pp.getNextReal(0.0,1.0); ELSE o.opacity := 0.85; END; END; IF pp.keywordPresent("-faces") THEN o.faces := TRUE; END; pp.finish(); EXCEPT | ParseParams.Error => PutText(stderr, "Usage:\n"); PutText(stderr, " Depthcueing4D -inFileTp \\\n"); PutText(stderr, " -inFileSt [ -outFile ] \\\n"); PutText(stderr, " -projection [ Perspective | Parallel ] \\\n"); PutText(stderr, " [ [ -autoProject ] | \\\n"); PutText(stderr, " [ -From4 ] \\\n"); PutText(stderr, " [ -To4 ] \\\n"); PutText(stderr, " [ -Up4 ] \\\n"); PutText(stderr, " [ -Over4 ] \\\n"); PutText(stderr, " ] [ -Vangle4 ] \\\n"); PutText(stderr, " [ -printDepth ] [ -normalize ] [ -colormap ] \\\n"); PutText(stderr, " [ -ColorFar ] \\\n"); PutText(stderr, " [ -ColorNear ] \\\n"); PutText(stderr, " [ -DepthFar ] [ -DepthNear ] \\\n"); PutText(stderr, " [ -DepthCueLevels ] \\\n"); PutText(stderr, " [ -silhouette [ -color | -opacity ] ] \\\n"); PutText(stderr, " [ -faces ]\n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt(); END Depthcueing4D. (**************************************************************************) (* *) (* Copyright (C) 2001 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/DeterLR3.m3 MODULE DeterLR3 EXPORTS Main; IMPORT Stdio, Wr, LR3, LR3Extras, Fmt; VAR a,b,c: LR3.T; d: LONGREAL; BEGIN a := LR3.T{ 2.0d0, 3.0d0, 0.0d00}; b := LR3.T{ 1.0d0, 0.0d0, 2.0d00}; c := LR3.T{ 1.0d0, 0.0d0, 0.00d0}; d := LR3Extras.Det(a,b,c); Wr.PutText(Stdio.stderr, "Determinante: " & Fmt.LongReal(d, Fmt.Style.Fix,prec := 2) & "\n"); END DeterLR3. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/DirectionEyes.m3 MODULE DirectionEyes EXPORTS Main; IMPORT Stdio, Wr, R3, Thread, Scan, Rd, FloatMode, Lex, Fmt, R3Extras, Math; FROM Stdio IMPORT stderr; CONST up = R3.T{0.0,1.0,0.0}; <* FATAL Wr.Failure, Thread.Alerted, Rd.Failure, FloatMode.Trap, Lex.Error, Rd.EndOfFile *> VAR obs3,int3: R3.T; x: LONGREAL; PROCEDURE ReadLong() : REAL = BEGIN RETURN Scan.Real(Rd.GetLine(Stdio.stdin)); END ReadLong; BEGIN x := Math.pow(2.0d0,1.0d0/3.0d0); Wr.PutText(stderr,"Input the look_at vector (one component by line)\n\n"); Wr.PutText(stderr,"look_at\n"); FOR i := 0 TO 2 DO obs3[i] := ReadLong(); END; Wr.PutText(stderr, "raiz cubica de 2 " & Fmt.LongReal(x) & "\n"); Wr.PutText(stderr, "Input the location camera vector\n\n"); Wr.PutText(stderr, "location\n"); FOR i := 0 TO 2 DO int3[i] := ReadLong(); END; WITH view = R3.Sub(int3,obs3), cross = R3Extras.Cross(view,up), norm = R3.Norm(cross), dirR = R3.Scale(1.0d0/norm,cross), dirL = R3.Scale(-1.0d0/norm,cross) DO Wr.PutText(stderr, "Direction left eye\n"); FOR i := 0 TO 2 DO Wr.PutText(stderr,Fmt.Real(dirL[i]) & " "); END; Wr.PutText(stderr,"\n"); Wr.PutText(stderr, "Direction right eye\n"); FOR i := 0 TO 2 DO Wr.PutText(stderr,Fmt.Real(dirR[i]) & " "); END; Wr.PutText(stderr,"\n"); END END DirectionEyes. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/DualMap.m3 MODULE DualMap EXPORTS Main; (* This program builds the dual topology of any 3D map. This is, the vertex information in the primal correspond to the cell information in the dual, edges to faces, faces to edges and cells to vertices. The geometric configuration of the dual is computed from the primal by geometric duality, assuming the figure is a convex polytope. The geometry will be garbage otherwise. The color and material information is remade from scratch. Therefore this program is useful mostly for original maps and not for their refinements. *) IMPORT Triangulation, ParseParams, Process, Wr, Thread, OSError, Fmt, Mis, Stdio, FileFmt, Text, FileWr, R3, LR4; FROM Stdio IMPORT stderr; FROM Triangulation IMPORT Topology, Coords, OrgV; FROM Mis IMPORT WriteCommentsJS; FROM FileFmt IMPORT WriteHeader, WriteFooter; CONST Boole = Mis.Boole; TYPE Options = RECORD inFileTp: TEXT; (* primal topology file *) inFileSt: TEXT; (* primal geometric file *) outFile : TEXT; (* dual topology and geometric file *) polyroot: BOOLEAN; (* includes the polyhedron root information *) END; PROCEDURE DoIt() = BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToMa(o.inFileTp), top = tc.top, rc = Triangulation.ReadState(o.inFileSt), c = rc^, com = tc.comments & "\nProcessed by DualMap\n", name = o.outFile, cd = ComputeDualState(top, c) DO Triangulation.WriteDualTopology(name, top, com); WriteDualMaterials(name, top, com, o.polyroot); WriteState(name, top.NP, cd^, com); END END DoIt; PROCEDURE WriteDualMaterials( name: TEXT; READONLY top: Topology; com: TEXT; root: BOOLEAN; ) = <* FATAL Thread.Alerted, Wr.Failure , OSError.E *> CONST Black = R3.T{0.0, 0.0, 0.0}; White = R3.T{1.0, 1.0, 1.0}; LightYellow = R3.T{1.0, 1.0, 0.8}; Opaque = R3.T{0.0, 0.0, 0.0}; HalfTransp = R3.T{0.5, 0.5, 0.5}; BEGIN WITH ma = FileWr.Open(name & ".ma"), vWidth = Mis.NumDigits(MAX(1,top.NV - 1)), eWidth = Mis.NumDigits(MAX(1,top.NE - 1)), fWidth = Mis.NumDigits(MAX(1,top.NF - 1)), pWidth = Mis.NumDigits(MAX(1,top.NP - 1)) DO WriteHeader(ma,"materials","99-08-25"); IF NOT Text.Empty(com) THEN WriteCommentsJS(ma, com & "\n", '|') END; WriteCommentsJS(ma, "vertices " & Fmt.Pad(Fmt.Int(top.NP),6), '|'); WriteCommentsJS(ma, "edges " & Fmt.Pad(Fmt.Int(top.NF),6), '|'); WriteCommentsJS(ma, "faces " & Fmt.Pad(Fmt.Int(top.NE),6), '|'); WriteCommentsJS(ma, "polyhedra " & Fmt.Pad(Fmt.Int(top.NV),6), '|'); FOR i := 0 TO top.NP-1 DO WITH vexists = TRUE, vfixed = FALSE, vradius = 0.02, vlabel = "VV" DO (* materials *) Wr.PutText(ma, Fmt.Pad(Fmt.Int(i), pWidth)); Wr.PutText(ma, " "); Wr.PutText(ma, Fmt.Char(Boole[vexists])); Wr.PutText(ma, " "); Wr.PutText(ma, Fmt.Char(Boole[vfixed])); Wr.PutText(ma, " "); WriteColor(ma, Black); Wr.PutText(ma, " "); WriteColor(ma, Opaque); Wr.PutText(ma, " "); WriteRadius(ma, vradius); Wr.PutText(ma, " "); WriteLabel(ma, vlabel); Wr.PutText(ma, "\n"); END; END; WriteCommentsJS(ma, "\nEdge data:\n", '|'); FOR i := 0 TO top.NF-1 DO WITH f = top.face[i], eexists = TRUE, edegenerate = FALSE, eradius = 0.01 DO (* materials *) Wr.PutText(ma, Fmt.Pad(Fmt.Int(f.num), fWidth)); Wr.PutText(ma, " "); Wr.PutText(ma, Fmt.Char(Boole[eexists])); Wr.PutText(ma, " "); WriteColor(ma, Black); Wr.PutText(ma, " "); WriteColor(ma, Opaque); Wr.PutText(ma, " "); WriteRadius(ma, eradius); Wr.PutText(ma, " "); Wr.PutText(ma, Fmt.Char(Boole[edegenerate])); Wr.PutText(ma, " "); Wr.PutText(ma, Fmt.Pad(Fmt.Int(f.num), fWidth)); Wr.PutText(ma, "\n"); END END; WriteCommentsJS(ma, "\nFace data:\n", '|'); FOR i := 0 TO top.NE-1 DO WITH e = top.edge[i], fexists = TRUE, fdegenerate = FALSE DO Wr.PutText(ma, Fmt.Pad(Fmt.Int(e.num), eWidth)); Wr.PutText(ma, " "); Wr.PutText(ma, Fmt.Char(Boole[fexists])); Wr.PutText(ma, " "); WriteColor(ma, LightYellow); Wr.PutText(ma, " "); WriteColor(ma, HalfTransp); Wr.PutText(ma, " "); Wr.PutText(ma, Fmt.Char(Boole[fdegenerate])); Wr.PutText(ma, " "); Wr.PutText(ma, Fmt.Pad(Fmt.Int(e.num), eWidth)); Wr.PutText(ma, "\n"); END END; IF top.NV # 0 THEN WriteCommentsJS(ma, "\nPolyhedron data:\n", '|'); END; FOR i := 0 TO top.NV-1 DO WITH pexists = TRUE, pdegenerate = FALSE DO Wr.PutText(ma, Fmt.Pad(Fmt.Int(i), vWidth)); Wr.PutText(ma, " "); Wr.PutText(ma, Fmt.Char(Boole[pexists])); Wr.PutText(ma, " "); WriteColor(ma, White); Wr.PutText(ma, " "); WriteColor(ma, White); Wr.PutText(ma, " "); Wr.PutText(ma, Fmt.Char(Boole[pdegenerate])); IF root THEN Wr.PutText(ma, " "); Wr.PutText(ma, Fmt.Pad(Fmt.Int(i), vWidth)); END; Wr.PutText(ma, "\n"); END END; WriteFooter(ma, "materials"); Wr.Close(ma); END; END WriteDualMaterials; PROCEDURE ComputeDualState( READONLY top: Topology; READONLY c: Coords ): REF Coords = VAR nv: CARDINAL; a : LR4.T; BEGIN WITH cd = NEW(REF Coords, top.NP) DO FOR i := 0 TO top.NP-1 DO WITH da = top.region[i], ptop = Triangulation.MakePolyhedronTopology(da) DO a := LR4.T{0.0d0, 0.0d0, 0.0d0, 0.0d0}; nv := 0; FOR i := 0 TO LAST(ptop.vRef^) DO WITH v = OrgV(ptop.vRef[i]) DO IF v # NIL THEN INC(nv); a := LR4.Add(a, c[v.num]) END; END; END; cd[i] := LR4.Scale(1.0d0/FLOAT(ptop.NV,LONGREAL), a); END END; RETURN cd END END ComputeDualState; PROCEDURE WriteIntensity(wr: Wr.T; r: REAL) = <* FATAL Thread.Alerted, Wr.Failure *> BEGIN Wr.PutText(wr, Fmt.Real(r, Fmt.Style.Fix, prec := 2)); END WriteIntensity; PROCEDURE WriteColor(wr: Wr.T; READONLY c: R3.T) = <* FATAL Thread.Alerted, Wr.Failure *> BEGIN WriteIntensity(wr,c[0]); Wr.PutText(wr, " "); WriteIntensity(wr,c[1]); Wr.PutText(wr, " "); WriteIntensity(wr,c[2]); END WriteColor; PROCEDURE WriteRadius(wr: Wr.T; r: REAL) = <* FATAL Thread.Alerted, Wr.Failure *> BEGIN IF r = 0.00 THEN Wr.PutText(wr, "0.00"); ELSE Wr.PutText(wr,Fmt.Real(r, prec := 2)); END END WriteRadius; PROCEDURE WriteLabel(wr: Wr.T; label: TEXT) = <* FATAL Thread.Alerted, Wr.Failure *> BEGIN Wr.PutText(wr, label); END WriteLabel; PROCEDURE WriteState( name: TEXT; READONLY nv: CARDINAL; READONLY c: Coords; com: TEXT := " "; ) = <* FATAL Wr.Failure, Thread.Alerted, OSError.E *> BEGIN WITH st = FileWr.Open(name & ".st"), vWidth = Mis.NumDigits(nv- 1) DO PROCEDURE WriteCoord(x: LONGREAL) = BEGIN Wr.PutText(st, Fmt.Pad(Fmt.LongReal(x, Fmt.Style.Sci, prec := 3), 7)); END WriteCoord; PROCEDURE WritePoint(READONLY c: LR4.T) = BEGIN WriteCoord(c[0]); Wr.PutText(st, " "); WriteCoord(c[1]); Wr.PutText(st, " "); WriteCoord(c[2]); Wr.PutText(st, " "); WriteCoord(c[3]); END WritePoint; BEGIN WriteHeader(st,"state","99-08-25"); Wr.PutText(st, "vertices "); Wr.PutText(st, Fmt.Int(nv) & "\n"); IF NOT Text.Empty(com) THEN WriteCommentsJS(st, com & "\n", '|') END; WriteCommentsJS(st, "\nVertex data:\n", '|'); FOR i := 0 TO nv-1 DO (* state *) Wr.PutText(st, Fmt.Pad(Fmt.Int(i), vWidth)); Wr.PutText(st, " "); WritePoint(c[i]); Wr.PutText(st, "\n"); END; END; WriteFooter(st, "state"); Wr.Close(st); END; END WriteState; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFileTp"); o.inFileTp := pp.getNext(); pp.getKeyword("-inFileSt"); o.inFileSt := pp.getNext(); pp.getKeyword("-outFile"); o.outFile := pp.getNext(); o.polyroot := pp.keywordPresent("-polyroot"); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: DualMap -inFileTp \\\n"); Wr.PutText(stderr, " -inFileSt -outFile \\\n"); Wr.PutText(stderr, " [-polyroot]\n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt(); END DualMap. (**************************************************************************) (* *) (* Copyright (C) 2001 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/Explode.m3 MODULE Explode EXPORTS Main; (* This program receives as input a single polyhedron (the envelope) and produces a include file with the barycentric subdivision of faces (2-skeleton) and cells (3-skeleton) but in an exploding way. Revision: 19-05-2000 by lozada *) IMPORT Thread, Wr, Process, LR4, Triangulation, Octf, ParseParams, R3, FileWr, OSError, Text, LR4Extras, LR3; FROM Triangulation IMPORT Coords, Vertex, OrgV, MakeFacetEdge, MakeVertex, SetOrg, Org, Pneg, Ppos, SetAllOrgs; FROM Octf IMPORT Pair, Tors, Spin, Clock, Fnext, SpinBit, OrientationBit, SpliceEdges, Enext, SetFnext, SetEnext, Enext_1, SetEdge, Fnext_1, SetEdgeAll, SetFaceAll; FROM Stdio IMPORT stderr; FROM Pov IMPORT WritePOVCylinder, WritePOVTriangle; FROM Wr IMPORT PutText; TYPE Options = RECORD inFileTp: TEXT; (* Input file name (minus ".tp" extension) *) inFileSt: TEXT; (* Input file name (minus ".st" extension) *) outFile: TEXT; (* Output file name prefix *) projectionName: TEXT; autoProject: BOOLEAN; From4: LR4.T; (* *) To4: LR4.T; (* 4D viewing parameters as expected by the *) Up4: LR4.T; (* "Wire4"- Interactive 4D Wireframe Display *) Over4: LR4.T; (* Program. *) Vangle4: LONGREAL; (* *) explode: BOOLEAN; (* For explode the configuration *) element: Element; (* Choose the element to explode (face or cell) *) eleName: TEXT; END; Element = {Face, Cell}; CONST Epsilon = 0.0000000001d0; PROCEDURE DoIt() = <* FATAL Wr.Failure, Thread.Alerted, OSError.E *> VAR NNE: CARDINAL := 0; NNV: CARDINAL := 0; gi : REF ARRAY OF ARRAY OF Pair; ntop: Triangulation.Topology; vf : REF ARRAY OF Vertex; o : Options := GetOptions(); inc : FileWr.T; BEGIN WITH tc = Triangulation.ReadToMa(o.inFileTp), top = tc.top, rc = Triangulation.ReadState(o.inFileSt), c = rc^, half = NEW(REF ARRAY OF Pair, 2*top.NFE)^, vnew = NEW(REF ARRAY OF Vertex, top.NV)^ DO IF o.explode THEN IF o.element = Element.Face THEN inc := FileWr.Open(o.outFile & "-Ex-Face.inc"); ELSIF o.element = Element.Cell THEN inc := FileWr.Open(o.outFile & "-Ex-Cell.inc"); END END; Wr.PutText(stderr, "Subdividing from: " & o.inFileTp & ".tp\n"); gi := NEW(REF ARRAY OF ARRAY OF Pair, top.NP, 4); vf := NEW(REF ARRAY OF Vertex, top.NF); PROCEDURE Half(a: Pair): Pair = BEGIN WITH na = a.facetedge.num, oa = OrientationBit(a), sa = SpinBit(a), h = half[2*na + oa] DO IF sa = 0 THEN RETURN h ELSE RETURN Spin(h) END END END Half; PROCEDURE CreateVertex(a: Pair): BOOLEAN = VAR t: Pair := a; BEGIN WITH fe = NARROW(a.facetedge, Triangulation.FacetEdge) DO IF NOT fe.mark THEN fe.mark := TRUE; REPEAT WITH fe = NARROW(t.facetedge, Triangulation.FacetEdge) DO fe.mark := TRUE; END; t := Fnext(t) UNTIL (t = a); RETURN TRUE; END; RETURN FALSE; END; END CreateVertex; PROCEDURE SetAllVhnum(a: Pair; v: Vertex) = PROCEDURE SetVhnum(a: Pair) = BEGIN WITH fe = NARROW(a.facetedge, Triangulation.FacetEdge) DO fe.vh := v; END; END SetVhnum; VAR t: Pair := a; BEGIN REPEAT SetVhnum(t); t := Fnext(t); UNTIL t = a; END SetAllVhnum; PROCEDURE Vhnum(a: Pair): Vertex = BEGIN WITH fe = NARROW(a.facetedge, Triangulation.FacetEdge) DO RETURN fe.vh; END; END Vhnum; BEGIN (* Copy original vertices, save correspondence in "vnew" array: *) FOR iu := 0 TO top.NV-1 DO WITH u = top.vertex[iu], v = MakeVertex() DO v.num := u.num; v.exists := u.exists; v.fixed := u.fixed; v.color := u.color; v.radius := u.radius; vnew[iu] := v END END; (* Create two new facetedges for each original facetedge "fe". The new facetedge corresponding to the origin half of "fe", with same spin and orientation, will be | Half(a) = Spin^s(half[2*a.facetedge.num + s]) where s = SpinBit(a), s = OrientationBit(a) *) VAR ve: REF ARRAY OF Vertex := NEW(REF ARRAY OF Vertex, top.NE); i: CARDINAL := 0; BEGIN FOR ie := 0 TO top.NFE-1 DO WITH a = top.facetedge[ie], oa = OrientationBit(a), sa = SpinBit(a), ho = half[2*ie + oa], hd = half[2*ie + 1 - oa], fe = NARROW(a.facetedge, Triangulation.FacetEdge), b = CreateVertex(a) DO IF b THEN ve[i] := MakeVertex(); ve[i].num := top.NV + NNV; INC (NNV); ve[i].exists := top.edge[fe.edge.num].exists; ve[i].fixed := FALSE; ve[i].radius := fe.edge.radius; ve[i].color := fe.edge.color; SetAllVhnum(a, ve[i]); INC(i); END; ho := MakeFacetEdge(); WITH hoe = NARROW(ho.facetedge, Triangulation.FacetEdge) DO hoe.num := NNE; INC(NNE); hoe.edge.exists := fe.edge.exists; hoe.edge.radius := fe.edge.radius; hoe.edge.color := fe.edge.color; END; IF sa = 1 THEN ho := Spin(ho) END; hd := MakeFacetEdge(); WITH hde = NARROW(hd.facetedge, Triangulation.FacetEdge) DO hde.num := NNE; INC(NNE); hde.edge.exists := fe.edge.exists; hde.edge.radius := fe.edge.radius; hde.edge.color := fe.edge.color; END; IF sa = 1 THEN ho := Spin(ho) END; SpliceEdges(ho, Clock(hd)); WITH m = Vhnum(a) DO SetOrg(Clock(ho),ve[m.num-top.NV]); SetOrg(Clock(hd),ve[m.num-top.NV]); END; SetOrg(ho, vnew[OrgV(a).num]); SetOrg(hd, vnew[OrgV(Clock(a)).num]); END END END; (* Connect the half-facetedges as in the original triangulation *) FOR ie := 0 TO top.NFE-1 DO WITH a = top.facetedge[ie], b = Fnext(a), c = Enext(a), ha = Half(a), hac = Half(Clock(a)), hb = Half(b), hc = Half(c) DO IF b # a AND Fnext(ha) # hb THEN SetFnext(ha, hb); (* so, Fnext(ha) = hb *) SetEdge(hb, ha.facetedge.edge); END; IF c # a AND Enext(Clock(hac)) # hc THEN SetEnext(Clock(hac), hc); (* so, Enext(Clock(hac) = hc *) END; END; WITH a = Clock(top.facetedge[ie]), b = Fnext(a), c = Enext(a), ha = Half(a), hac = Half(Clock(a)), hb = Half(b), hc = Half(c) DO IF b # a AND Fnext(ha) # hb THEN SetFnext(ha, hb); (* so, Fnext(ha) = hb *) SetEdge(hb, ha.facetedge.edge); END; IF Enext(Clock(hac)) # hc THEN SetEnext(Clock(hac), hc); (* so, Enext(Clock(hac) = hc *) END END END; FOR i := 0 TO top.NF-1 DO vf[i] := MakeVertex(); vf[i].num := top.NV + NNV; INC (NNV); END; FOR i := 0 TO top.NF-1 DO VAR a,b,c,d,aa: Pair; BEGIN WITH p = top.face[i].pa DO aa := p; FOR j := 0 TO Octf.DegreeEdgeRing(p)-1 DO WITH ha = Half(aa), hac = Half(Clock(aa)) DO a := MakeFacetEdge(); a.facetedge.num := NNE; INC(NNE); b := MakeFacetEdge(); b.facetedge.num := NNE; INC(NNE); c := MakeFacetEdge(); c.facetedge.num := NNE; INC(NNE); d := MakeFacetEdge(); d.facetedge.num := NNE; INC(NNE); SetOrg(a,Org(Clock(ha))); SetOrg(Clock(a),vf[i]); SetOrg(b,vf[i]); SetOrg(Clock(b),Org(ha)); SetEnext(ha,a); SetEnext(a,b); SetEnext(b,ha); SetFaceAll(a,a.facetedge.face); SetOrg(c,Org(Clock(hac))); SetOrg(Clock(c),vf[i]); SetOrg(d,vf[i]); SetOrg(Clock(d),Org(hac)); SetEnext(hac,c); SetEnext(c,d); SetEnext(d,hac); SetFaceAll(c,c.facetedge.face); SetFnext(a,c); SetFnext(c,a); SetAllOrgs(a,Org(a)); END; aa := Enext(aa); END END END END; FOR i := 0 TO top.NF-1 DO VAR aa: Pair; BEGIN WITH p = top.face[i].pa DO aa := p; FOR j := 0 TO Octf.DegreeEdgeRing(p)-1 DO WITH hpc = Half(Clock(aa)), hq = Half(Enext(aa)) DO SetFnext(Enext_1(hq), Enext_1(hpc)); SetEdgeAll(Enext_1(hq),Enext_1(hq).facetedge.edge); END; aa := Enext(aa); END; SetAllOrgs(Enext_1(Half(p)),vf[i]); END END END; FOR i := 0 TO top.NFE-1 DO WITH a = top.facetedge[i], ha = Half(a), hac = Half(Clock(a)) DO SetEdgeAll(ha, ha.facetedge.edge); SetEdgeAll(hac, hac.facetedge.edge); SetAllOrgs(hac, Org(hac)); SetAllOrgs(ha, Org(ha)); SetAllOrgs(Clock(hac), Org(Clock(hac))); SetAllOrgs(Clock(ha), Org(Clock(ha))); END END; FOR i := 0 TO top.NP-1 DO WITH v = top.region[i], a = Tors(v), af = Fnext_1(a), ae = Enext_1(a), aee = Enext(a) DO <* ASSERT Pneg(a).num = i *> <* ASSERT Org(v).num = i *> IF Ppos(af) # NIL THEN <* ASSERT Pneg(a) = Ppos (af) *> END; gi[i,0] := Clock(Enext(Fnext_1(Enext(Half(a))))); gi[i,1] := Clock(Enext(Fnext(Enext(Half(af))))); gi[i,2] := Clock(Enext(Fnext(Enext(Half(Fnext_1(ae)))))); gi[i,3] := Fnext(Enext(Half(Fnext_1(aee)))); END END; ntop := Triangulation.MakeTopology(Half(top.facetedge[0])); WITH nc = NEW(REF Coords,ntop.NV)^ DO PROCEDURE Compute4DRadius() : LONGREAL = (* compute Data4Radius *) VAR Data4Radius: LONGREAL := 0.0d0; BEGIN FOR i := 0 TO ntop.NV-1 DO WITH v = ntop.vertex[i], Temp4 = LR4.Sub(nc[v.num],o.To4), dist = LR4.Dot(Temp4, Temp4) DO IF dist > Data4Radius THEN Data4Radius := dist; END END END; RETURN Data4Radius; END Compute4DRadius; PROCEDURE CalcV4Matrix(VAR WA,WB,WC,WD: LR4.T) = (* This procedure computes the four basis vectors for the 4D viewing matrix, Wa,Wb,Wc, and Wd. Note that the Up vector transforms to Wb, the Over vector transforms to Wc, and the line of sight transforms to Wd. The Wa vector is then computed from Wb,Wc and Wd. *) VAR norm : LONGREAL; BEGIN (* Calculate Wd, the 4th coordinate vector and line-of-sight.*) WD:= LR4.Sub(o.To4,o.From4); norm := LR4.Norm(Wd); IF norm < Epsilon THEN Wr.PutText(stderr,"4D To Point and From Point are the same\n"); Process.Exit(1); END; WD := LR4.Scale(1.0d0/norm, WD); (* Calculate Wa, the X-axis basis vector. *) WA := LR4Extras.Cross(o.Up4,o.Over4,WD); norm := LR4.Norm(WA); IF norm < Epsilon THEN Wr.PutText(stderr, "4D up,over and view vectors are not perpendicular\n"); Process.Exit(1); END; WA := LR4.Scale(1.0d0/norm, WA); (* Calculate Wb, the perpendicularized Up vector. *) WB := LR4Extras.Cross(o.Over4,WD,WA); norm := LR4.Norm(WB); IF norm < Epsilon THEN Wr.PutText(stderr,"Invalid 4D over vector\n"); Process.Exit(1); END; WB := LR4.Scale(1.0d0/norm, WB); (* Calculate Wc, the perpendicularized Over vector. Note that the resulting vector is already normalized, since Wa, Wb and Wd are all unit vectors. *) WC := LR4Extras.Cross(WD,WA,WB); END CalcV4Matrix; PROCEDURE ProjectTo3D(p: LR4.T) : LR3.T = VAR c3 : LR3.T; BEGIN WITH TempV = LR4.Sub(p,o.From4), rtemp = 1.0d0 / data4 DO c3[0] := rtemp * LR4.Dot(TempV, Wa); c3[1] := rtemp * LR4.Dot(TempV, Wb); c3[2] := rtemp * LR4.Dot(TempV, Wc); RETURN c3; END END ProjectTo3D; PROCEDURE ExplodeFace(un,vn,wn: CARDINAL) = VAR B: LR4.T := LR4.T{0.0d0, ..}; BEGIN WITH cun = nc[un], cvn = nc[vn], cwn = nc[wn], us = LR4.Scale(4.00d0,cun), vs = LR4.Scale(4.00d0,cvn), ws = LR4.Scale(4.00d0,cwn), b = LR4.Add(LR4.Add(LR4.Add(B, cun),cvn),cwn), ba = LR4.Scale(1.0d0/3.0d0, b), ue = LR4.Add(us, ba), ve = LR4.Add(vs, ba), we = LR4.Add(ws, ba), ue3 = ProjectTo3D(ue), ve3 = ProjectTo3D(ve), we3 = ProjectTo3D(we), ra = 0.008, cf = R3.T{1.000, 0.745, 0.745}, ce = R3.T{0.0,0.0,0.0}, tr = 0.0 DO (* Draw cylinders *) WritePOVCylinder(inc,ue3,ve3,ra,ce,tr,TRUE); WritePOVCylinder(inc,ve3,we3,ra,ce,tr,TRUE); WritePOVCylinder(inc,ue3,we3,ra,ce,tr,TRUE); (* Draw face *) WritePOVTriangle(inc,ue3,ve3,we3,cf,tr,TRUE); END END ExplodeFace; PROCEDURE ExplodeTetrahedron(un,vn,wn: CARDINAL) = VAR B: LR4.T := LR4.T{0.0d0, ..}; BEGIN WITH cun = nc[un], cvn = nc[vn], cwn = nc[wn], cxn = bary, us = LR4.Scale(4.00d0,cun), vs = LR4.Scale(4.00d0,cvn), ws = LR4.Scale(4.00d0,cwn), xs = LR4.Scale(4.00d0,cxn), b = LR4.Add(LR4.Add(LR4.Add(LR4.Add(B, cun),cvn),cwn),cxn), ba = LR4.Scale(1.0d0/4.0d0, b), ue = LR4.Add(us, ba), ve = LR4.Add(vs, ba), we = LR4.Add(ws, ba), xe = LR4.Add(xs, ba), ue3 = ProjectTo3D(ue), ve3 = ProjectTo3D(ve), we3 = ProjectTo3D(we), xe3 = ProjectTo3D(xe), ra = 0.008, cf = R3.T{1.000, 0.745, 0.745}, ce = R3.T{0.0,0.0,0.0}, tr = 0.0 DO (* Draw cylinders *) WritePOVCylinder(inc,ue3,ve3,ra,ce,tr,TRUE); WritePOVCylinder(inc,ve3,we3,ra,ce,tr,TRUE); WritePOVCylinder(inc,ue3,we3,ra,ce,tr,TRUE); WritePOVCylinder(inc,ue3,xe3,ra,ce,tr,TRUE); WritePOVCylinder(inc,ve3,xe3,ra,ce,tr,TRUE); WritePOVCylinder(inc,we3,xe3,ra,ce,tr,TRUE); (* Draw triangles *) WritePOVTriangle(inc,ue3,ve3,we3,cf,tr,TRUE); WritePOVTriangle(inc,ue3,ve3,xe3,cf,tr,TRUE); WritePOVTriangle(inc,ve3,we3,xe3,cf,tr,TRUE); WritePOVTriangle(inc,ue3,we3,xe3,cf,tr,TRUE); END END ExplodeTetrahedron; VAR Wa,Wb,Wc,Wd: LR4.T; data4 : LONGREAL; bary : LR4.T; BEGIN FOR j := 0 TO top.NFE-1 DO WITH a = top.facetedge[j], ou = OrgV(a).num, ov = OrgV(Clock(a)).num, nu = OrgV(Half(a)).num, nv = OrgV(Half(Clock(a))).num, nx = OrgV(Clock(Half(a))).num, ny = OrgV(Clock(Half(Clock(a)))).num DO <* ASSERT nx = ny *> nc[nu] := c[ou]; nc[nv] := c[ov]; nc[ny] := LR4.Scale(0.5d0, LR4.Add(c[ou], c[ov])); nc[nx] := nc[ny]; END END; FOR j := 0 TO top.NF-1 DO WITH a = top.face[j].pa, vj = vf[j], vjn = vj.num DO nc[vjn] := Triangulation.FaceBarycenter(a,c); END END; (* compute the 4D viewing Matrix *) CalcV4Matrix(Wa,Wb,Wc,Wd); (* compute the radius of the 4D configuration *) data4 := Compute4DRadius(); (* compute the barycenter of the 4D configuration *) bary := Triangulation.Barycenter(ntop,nc,TRUE); FOR j := 0 TO ntop.NF-1 DO WITH a = ntop.face[j].pa, un = OrgV(a).num, vn = OrgV(Enext(a)).num, wn = OrgV(Enext_1(a)).num DO IF o.element = Element.Cell THEN ExplodeTetrahedron(un,vn,wn); ELSIF o.element = Element.Face THEN ExplodeFace(un,vn,wn); END END END END END END END END DoIt; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFileTp"); o.inFileTp := pp.getNext(); pp.getKeyword("-inFileSt"); o.inFileSt := pp.getNext(); pp.getKeyword("-outFile"); o.outFile := pp.getNext(); pp.getKeyword("-projection"); o.projectionName := pp.getNext(); IF NOT (Text.Equal(o.projectionName, "Parallel") OR Text.Equal(o.projectionName, "Perspective")) THEN pp.error("Bad projection \"" & pp.getNext() & "\"\n") END; IF pp.keywordPresent("-autoProject") THEN o.autoProject := TRUE ELSE IF pp.keywordPresent("-From4") THEN FOR j := 0 TO 3 DO o.From4[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.From4 := LR4.T{0.0d0,0.0d0,0.0d0,-3.0d0}; END; IF pp.keywordPresent("-To4") THEN FOR j := 0 TO 3 DO o.To4[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.To4 := LR4.T{0.0d0,0.0d0,0.0d0,0.0d0}; END; IF pp.keywordPresent("-Up4") THEN FOR j := 0 TO 3 DO o.Up4[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.Up4 := LR4.T{0.0d0,1.0d0,0.0d0,0.0d0}; END; IF pp.keywordPresent("-Over4") THEN FOR j := 0 TO 3 DO o.Over4[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.Over4 := LR4.T{0.0d0,0.0d0,1.0d0,0.0d0}; END; END; IF pp.keywordPresent("-Vangle4") THEN o.Vangle4 := pp.getNextLongReal(1.0d0, 179.0d0); ELSE o.Vangle4 := 25.0d0; END; IF pp.keywordPresent("-explode") THEN o.explode := TRUE; o.eleName := pp.getNext(); IF Text.Equal(o.eleName,"Face") THEN o.element := Element.Face; ELSIF Text.Equal(o.eleName,"Cell") THEN o.element := Element.Cell; ELSE pp.error("Bad element \"" & pp.getNext() & "\"\n") END END; pp.finish(); EXCEPT | ParseParams.Error => PutText(stderr, "Usage: Subdivide \\\n"); PutText(stderr, " -inFileTp \\\n"); PutText(stderr, " -inFileSt \\\n"); PutText(stderr, " -outFile \\\n"); PutText(stderr," -projection [ Perspective | Parallel ] \\\n"); PutText(stderr," [ [ -autoProject ] | \\\n"); PutText(stderr," [ -From4 ] \\\n"); PutText(stderr," [ -To4 ] \\\n"); PutText(stderr," [ -Up4 ] \\\n"); PutText(stderr," [ -Over4 ] \\\n"); PutText(stderr," [ -Vangle4 ] \\\n"); PutText(stderr," ] [ -explode { Face | Cell } ] \n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt() END Explode. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/ExtendedTable.m3 (* Program to build an extended "Topology-Table" that provides more information than "Triangulation.MakeTopologyTable" procedure. See notice of copyright at the end of this file. Last modification: 08-07-2000 *) MODULE ExtendedTable EXPORTS Main; IMPORT Triangulation, Stdio, Wr, Thread, Process, ParseParams, Fmt, Octf; FROM Stdio IMPORT stderr; FROM Triangulation IMPORT Edge; FROM Wr IMPORT PutText; FROM Octf IMPORT Enext, Tors; TYPE Options = RECORD inFile: TEXT; END; (* Initial guess file name (minus ".tp") *) PROCEDURE DoIt() = <* FATAL Thread.Alerted, Wr.Failure *> BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToMa(o.inFile), top = tc.top DO IF top.der # 3 THEN PutText(stderr,"THis topology isn't a triangulation\n"); Process.Exit(1); END; PutText(stderr, "edges:\n"); PutText(stderr, "-----\n"); FOR i := 0 TO top.NE-1 DO WITH ei = NARROW(top.edge[i], Edge), v0 = ei.vertex[0].num, v1 = ei.vertex[1].num DO (* Prints *) PutText(stderr, Fmt.Pad(Fmt.Int(i), 4) & ":"); PutText(stderr, Fmt.Pad(Fmt.Int(v0), 4) & "v"); PutText(stderr, Fmt.Pad(Fmt.Int(v1), 4) & "v\n"); END END; PutText(stderr, "faces:\n"); PutText(stderr, "-----\n"); FOR i := 0 TO top.NF-1 DO WITH fi = top.face[i], (* vertices *) v0 = fi.vertex^[0].num, v1 = fi.vertex^[1].num, v2 = fi.vertex^[2].num, (* edges *) a = fi.pa, b = Enext(a), c = Enext(b), e0 = a.facetedge.edge.num, e1 = b.facetedge.edge.num, e2 = c.facetedge.edge.num DO (* Prints *) PutText(stderr, Fmt.Pad(Fmt.Int(i), 4) & ":"); PutText(stderr, Fmt.Pad(Fmt.Int(v0), 4) & "v "); PutText(stderr, Fmt.Pad(Fmt.Int(v1), 4) & "v "); PutText(stderr, Fmt.Pad(Fmt.Int(v2), 4) & "v - "); PutText(stderr, Fmt.Pad(Fmt.Int(e0), 4) & "e "); PutText(stderr, Fmt.Pad(Fmt.Int(e1), 4) & "e "); PutText(stderr, Fmt.Pad(Fmt.Int(e2), 4) & "e\n"); END END; IF top.NP # 0 THEN PutText(stderr, "polyhedra:\n"); PutText(stderr, "---------\n"); FOR i := 0 TO top.NP-1 DO WITH pi = top.polyhedron[i], ri = top.region[i], a = Tors(ri), v0 = pi.vertex^[0].num, v1 = pi.vertex^[1].num, v2 = pi.vertex^[2].num, v3 = pi.vertex^[3].num, (* faces *) faces = Triangulation.TetraFaces(a), f0 = faces[0].num, f1 = faces[1].num, f2 = faces[2].num, f3 = faces[3].num, (* edges *) edges = Triangulation.TetraEdges(a), e0 = edges[0].num, e1 = edges[1].num, e2 = edges[2].num, e3 = edges[3].num, e4 = edges[4].num, e5 = edges[5].num DO (* Prints *) PutText(stderr, Fmt.Pad(Fmt.Int(i), 4) & ": "); PutText(stderr, Fmt.Pad(Fmt.Int(v0), 3) & "v "); PutText(stderr, Fmt.Pad(Fmt.Int(v1), 3) & "v "); PutText(stderr, Fmt.Pad(Fmt.Int(v2), 3) & "v "); PutText(stderr, Fmt.Pad(Fmt.Int(v3), 3) & "v - "); PutText(stderr, Fmt.Pad(Fmt.Int(f0), 3) & "f "); PutText(stderr, Fmt.Pad(Fmt.Int(f1), 3) & "f "); PutText(stderr, Fmt.Pad(Fmt.Int(f2), 3) & "f "); PutText(stderr, Fmt.Pad(Fmt.Int(f3), 3) & "f - "); PutText(stderr, Fmt.Pad(Fmt.Int(e0), 3) & "e "); PutText(stderr, Fmt.Pad(Fmt.Int(e1), 3) & "e "); PutText(stderr, Fmt.Pad(Fmt.Int(e2), 3) & "e "); PutText(stderr, Fmt.Pad(Fmt.Int(e3), 3) & "e "); PutText(stderr, Fmt.Pad(Fmt.Int(e4), 3) & "e "); PutText(stderr, Fmt.Pad(Fmt.Int(e5), 3) & "e\n"); END END END END END DoIt; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFile"); o.inFile := pp.getNext(); pp.finish(); EXCEPT | ParseParams.Error => PutText(stderr, "Usage: ExtendedTable" ); PutText(stderr, " -inFile \n" ); Process.Exit(1); END END; RETURN o END GetOptions; BEGIN DoIt() END ExtendedTable. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************)~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/GeralBarySubdivision.m3 MODULE GeralBarySubdivision EXPORTS Main; IMPORT Triangulation, Stdio, Wr, Thread, Process, ParseParams, Octf, Bary, R3, Mis; FROM Stdio IMPORT stderr; FROM Triangulation IMPORT Pair, Org, MakeTopology, PposP, PnegP, OrgV, Vertex, Edge, Face; FROM Octf IMPORT Fnext, Srot, Clock, Enext, Fnext_1, Enext_1, Spin, Tors; FROM Bary IMPORT Corner, CCorner, SetCorner; CONST order = 2; mid = 1; TYPE Options = RECORD inFile : TEXT; (* Initial guess file name (minus ".tp") *) outFile : TEXT; (* Output file name prefix *) net : BOOLEAN; END; VAR top : Triangulation.Topology; vlt : TEXT := "VP"; vlf : TEXT := "VF"; net : BOOLEAN; PROCEDURE DoIt() = <* FATAL Wr.Failure, Thread.Alerted *> VAR ps : REF ARRAY OF Pair; BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToMa(o.inFile), NFE = top.NFE DO top := tc.top; net := o.net; ps := NEW(REF ARRAY OF Pair, NFE); Wr.PutText(stderr, "Subdividing from: " & o.inFile & ".tp\n"); FOR i := 0 TO NFE-1 DO WITH aposp = PposP(top.facetedge[i]), apneg = PnegP(top.facetedge[i]) DO IF (aposp # NIL) AND (apneg # NIL) THEN ps[i] := Bary.MakeFacetEdge(order,order); SetTetrahedron2x2(ps[i],i); ELSE ps[i] := Bary.MakeFacetEdge(mid,order); SetTetrahedron1x2(ps[i],i); END END END; (* gluing tetrahedra *) FOR i := 0 TO NFE-1 DO WITH pa = top.facetedge[i] DO GlueTetra(pa); END END; WITH newtop = MakeTopology(top.facetedge[NFE-1].facetedge.ca[1],0), nc = Triangulation.GenCoords(newtop)^, com = "Subdivided from: " & o.inFile & ".tp\n" &"Created by Barycenter Subdivision: "&o.outFile & ".tp on " & Mis.Today() DO Triangulation.WriteTopology(o.outFile, newtop, com); Triangulation.WriteState(o.outFile, newtop, nc, com & "\nRandom Geometry"); Triangulation.WriteMaterials(o.outFile, newtop, com); (* unmark all the facetedges *) FOR i := 0 TO NFE-1 DO WITH fet = top.facetedge[i].facetedge DO fet.marks := FALSE; END END; END END END DoIt; PROCEDURE Internal(a: Pair) : BOOLEAN = BEGIN IF (PposP(a) # NIL) AND (PnegP(a) # NIL) THEN RETURN TRUE; ELSE RETURN FALSE; END; END Internal; PROCEDURE CommonPolyhedron(a,b: Pair) : BOOLEAN = BEGIN WITH app = PposP(a), apn = PnegP(a), bpp = PposP(b), bpn = PnegP(b) DO (*Wr.PutText(Stdio.stderr, "oi\n");*) IF (app = bpn) AND (app # NIL) THEN RETURN TRUE END; IF (apn = bpp) AND (apn # NIL) THEN RETURN TRUE END; RETURN FALSE; END; END CommonPolyhedron; PROCEDURE GlueTetra(a: Pair) = (* Glues the topological tetrahedra such as the topology. *) BEGIN (*<* ASSERT a.bits = 0 *>*) WITH b = Fnext(a), c = Fnext_1(a), d = Enext(a), e = Enext_1(a) DO WITH aa = Corner(a), bb = CCorner(b) DO IF (bb # aa) AND (a#b) THEN IF Internal(a) AND Internal(b) THEN EVAL Triangulation.Glue(bb, aa, order, TRUE); (* Update Corners to mark this pairs facetedges as glued *) SetCorner(a, bb); SetCorner(Spin(Clock(a)), CCorner(Spin(Clock(b)))); ELSIF CommonPolyhedron(a,b) THEN EVAL Triangulation.Glue(bb, aa, order, TRUE); (* Update Corners to mark this pairs facetedges as glued *) SetCorner(a, bb); SetCorner(Spin(Clock(a)), CCorner(Spin(Clock(b)))); END END END; WITH cc = Corner(c), dd = CCorner(a) DO IF (dd # cc) AND (c#a) THEN IF Internal(a) AND Internal(c) THEN EVAL Triangulation.Glue(dd, cc, order, TRUE); (* Update Corners to mark this pairs facetedges as glued *) SetCorner(c, dd); SetCorner(Spin(Clock(c)), CCorner(Spin(Clock(a)))); ELSIF CommonPolyhedron(a,c) THEN EVAL Triangulation.Glue(dd, cc, order, TRUE); (* Update Corners to mark this pairs facetedges as glued *) SetCorner(c, dd); SetCorner(Spin(Clock(c)), CCorner(Spin(Clock(a)))); END END END; WITH ee = Corner(Srot(d)), ff = CCorner(Srot(a)) DO IF (ff # ee) AND (a#d) THEN (* Not yet glued, glue it: *) EVAL Triangulation.Glue(ff, ee, order, TRUE); (* Update Corners to mark this pairs facetedges as glued *) SetCorner(Srot(d), ff); SetCorner(Spin(Tors(d)), CCorner(Spin(Tors(a)))); END END; WITH gg = Corner(Srot(a)), hh = CCorner(Srot(e)) DO IF (gg # hh) AND (a#e) THEN EVAL Triangulation.Glue(hh, gg, order, TRUE); (* Update Corners to mark this pairs facetedges as glued *) SetCorner(Srot(a), hh); SetCorner(Spin(Tors(a)), CCorner(Spin(Tors(e)))); END END END END GlueTetra; PROCEDURE SetTetrahedron2x2(a:Pair; i: CARDINAL) = BEGIN WITH fes = NARROW(a.facetedge, Bary.FacetEdge), fet = top.facetedge[i].facetedge, fn = fet.face.num, en = fet.edge.num, on = OrgV(top.facetedge[i]), dn = OrgV(Clock(top.facetedge[i])), ovr = on.radius, ovc = on.color, ovt = on.transp, ovl = on.label, ove = on.exists, dvr = dn.radius, dvc = dn.color, dvt = dn.transp, dvl = dn.label, dve = dn.exists, era = top.edge[en].radius, eco = top.edge[en].color, eta = top.edge[en].transp, eex = top.edge[en].exists, ero = top.edge[en].root, fco = top.face[fn].color, fta = top.face[fn].transp, fex = top.face[fn].exists, fro = top.face[fn].root DO <* ASSERT Octf.OrientationBit(top.facetedge[i]) = 0 *> fet.ca := fes.ca; SetDual (fet.ca[3],vlt,vlf,FALSE,TRUE); SetPrimal(fet.ca[0],ovr,ovc,ovt,ovl,ove,dvr,dvc, dvt,dvl,dve,era,eco,eta,eex,ero,fco,fta, fex,fro,FALSE,TRUE,net); END END SetTetrahedron2x2; PROCEDURE SetTetrahedron1x2(a:Pair; i: CARDINAL) = BEGIN WITH fes = NARROW(a.facetedge, Bary.FacetEdge), fet = top.facetedge[i].facetedge, fn = fet.face.num, en = fet.edge.num, on = OrgV(top.facetedge[i]), dn = OrgV(Clock(top.facetedge[i])), ovr = on.radius, ovc = on.color, ovt = on.transp, ovl = on.label, ove = on.exists, dvr = dn.radius, dvc = dn.color, dvt = dn.transp, dvl = dn.label, dve = dn.exists, era = top.edge[en].radius, eco = top.edge[en].color, eta = top.edge[en].transp, eex = top.edge[en].exists, ero = top.edge[en].root, fco = top.face[fn].color, fta = top.face[fn].transp, fex = top.face[fn].exists, fro = top.face[fn].root, (* *) pa = top.facetedge[i], paf = Fnext(pa), fef = Fnext(pa).facetedge DO fet.ca := fes.ca; IF NOT fet.marks AND (PposP(pa) = PnegP(paf)) THEN IF PposP(pa) # NIL THEN SetDual(fet.ca[3],vlt,vlf,TRUE,FALSE); SetPrimal(fet.ca[0],ovr,ovc,ovt,ovl,ove,dvr, dvc,dvt,dvl,dve,era,eco,eta,eex,ero, fco,fta,fex,fro,TRUE,FALSE,net); fet.marks := TRUE; END; IF NOT fef.marks THEN SetDual(fet.ca[3],vlt,vlf,TRUE,TRUE); SetPrimal(fet.ca[0],ovr,ovc,ovt,ovl,ove,dvr, dvc,dvt,dvl,dve,era,eco,eta,eex,ero, fco,fta,fex,fro,TRUE,TRUE,net); fef.marks := TRUE; END END END END SetTetrahedron1x2; PROCEDURE SetPrimal( a: Pair; (* pair hanged on topological tetrahedron 2x2 or 1x2 *) ovr: REAL; (* origen vertex radius *) ovc: R3.T; (* origen vertex color *) ovt: R3.T; (* origen vertex transparency *) ovl: TEXT; (* origen vertex label *) ove: BOOLEAN; dvr: REAL; (* destine vertex radius *) dvc: R3.T; (* destine vertex color *) dvt: R3.T; (* destine vertex transparency *) dvl: TEXT; (* destine vertex label *) dve: BOOLEAN; era: REAL; (* edge radius *) eco: R3.T; (* edge color *) eta: R3.T; (* edge transparency *) eex: BOOLEAN; (* edge exists *) ero: INTEGER; (* edge root *) fco: R3.T; (* face color *) fta: R3.T; (* face transparency *) fex: BOOLEAN; (* face exists *) fro: INTEGER; (* face root *) mid: BOOLEAN; (* TRUE iff the topological tetrahedron is 1x2 *) side: BOOLEAN; (* indicate the side of the topological tetrahedron 1x2 *) net : BOOLEAN; (* simulates a grade with thin cylindres and spheres *) ) = PROCEDURE SetVertex( v: Vertex; e: BOOLEAN; (* exists *) c: R3.T; (* color *) t: R3.T; (* transp *) r: REAL; (* radius *) l: TEXT; (* label *) ) = BEGIN v.exists := e; v.color := c; v.transp := t; v.label := l; v.radius := r; END SetVertex; PROCEDURE SetGhostFace(a: Pair) = BEGIN WITH t = NARROW(a.facetedge.face, Face) DO t.exists := FALSE; END; END SetGhostFace; PROCEDURE NewSetTriangle( b: Pair; e: BOOLEAN; (* exists *) c: R3.T; (* color *) t: R3.T; (* transp *) r: INTEGER; (* root *) ) = BEGIN WITH f = NARROW(b.facetedge.face, Face) DO f.exists := e; f.color := c; f.transp := t; f.root := r; END END NewSetTriangle; PROCEDURE NewSetEdge( b: Pair; e: BOOLEAN; (* exists *) c: R3.T; (* color *) t: R3.T; (* transp *) ra: REAL; (* radius *) ro: INTEGER; (* root *) ) = BEGIN WITH ee = NARROW(b.facetedge.edge, Edge) DO ee.exists := e; ee.color := c; ee.transp := t; ee.radius := ra; ee.root := ro; END END NewSetEdge; BEGIN (* set the origin of the pair ca[0] *) SetVertex(Org(a), ove, ovc, ovt, ovr, ovl); (* set the origin of the pair Clock(ca[0]) *) SetVertex(Org(Clock(a)), eex, eco, eta, era, "VE"); (* set the edge component of the topological tetrahedron *) NewSetEdge(a, eex, eco, eta, era, ero); WITH b = Clock(Enext_1(Fnext(Enext(a)))) DO SetVertex(Org(Clock(b)), dve, dvc, dvt, dvr, dvl); NewSetEdge(b, eex, eco, eta, era, ero); END; IF NOT mid THEN SetGhostFace(a); SetGhostFace(Fnext(a)); NewSetTriangle(Fnext_1(a), fex, fco, fta, fro); WITH b = Clock(Enext_1(Fnext(Enext(a)))) DO SetGhostFace(b); SetGhostFace(Fnext(b)); NewSetTriangle(Fnext_1(b), fex, fco, fta, fro); END; IF net THEN WITH X = Enext_1(Fnext_1(a)).facetedge.edge, Y = Enext (Fnext_1(a)).facetedge.edge, Z = Clock(Enext_1(Fnext(Enext(a)))), W = Enext (Fnext_1(Z)).facetedge.edge, S = OrgV(Enext_1(Fnext_1(a))), co = R3.T{1.00,1.000,0.500}, (* color, transparency and radius *) tp = R3.T{0.00,0.000,0.000}, (* of the thin cylinder and sohere*) ra = 0.0025 DO X.exists := TRUE; Y.exists := TRUE; W.exists := TRUE; S.exists := TRUE; X.color := co; X.radius := ra; X.transp := tp; Y.color := co; Y.radius := ra; Y.transp := tp; W.color := co; W.radius := ra; W.transp := tp; S.color := co; S.radius := ra; S.transp := tp; END END ELSIF mid THEN IF side THEN SetGhostFace(a); NewSetTriangle(Fnext_1(a), fex, fco, fta, fro); WITH b = Clock(Enext_1(Fnext(Enext(a)))) DO SetGhostFace(b); NewSetTriangle(Fnext_1(b), fex, fco, fta, fro); END ELSE SetGhostFace(Fnext_1(a)); NewSetTriangle(a, fex, fco, fta, fro); WITH an = Clock(Enext_1(Fnext_1(Enext(Fnext_1(a))))) DO SetGhostFace(an); NewSetTriangle(Fnext_1(an), fex, fco, fta, fro); END END END END SetPrimal; PROCEDURE SetDual( a: Pair; vlt: TEXT; vlf: TEXT; mid: BOOLEAN; side: BOOLEAN; ) = PROCEDURE SetVertex(v: Vertex; label: TEXT) = BEGIN WITH vv = NARROW(v, Vertex) DO vv.exists := FALSE; vv.label := label; END; END SetVertex; PROCEDURE SetGhostFace(a: Pair) = BEGIN WITH t = NARROW(a.facetedge.face, Face) DO t.exists := FALSE; END; END SetGhostFace; PROCEDURE SetGhostEdge(a: Pair) = BEGIN WITH t = NARROW(a.facetedge.edge, Edge) DO t.exists := FALSE; END; END SetGhostEdge; PROCEDURE SetRowEdge(d: Pair; r: CARDINAL) = VAR dn: Pair := d; BEGIN IF r = 3 THEN FOR j := 0 TO r-1 DO IF j=0 THEN FOR i := 0 TO r-1 DO SetGhostEdge(dn); dn := Enext(dn); END; END; dn := Fnext_1(dn); SetGhostEdge(Enext(dn)); SetGhostEdge(Enext_1(dn)); END; ELSIF r = 2 THEN FOR j := 0 TO r-1 DO IF j=0 THEN FOR i := 0 TO r-1 DO SetGhostEdge(dn); dn := Enext(dn); END; dn := Enext(dn); END; dn := Fnext_1(dn); SetGhostEdge(Enext(dn)); END END; END SetRowEdge; PROCEDURE SetRowTriangle(b: Pair) = BEGIN FOR i := 0 TO 2 DO SetGhostFace(b); b := Fnext_1(b); END; END SetRowTriangle; BEGIN IF mid AND side THEN SetVertex(Org(a), vlf); SetVertex(Org(Clock(a)), vlt); SetRowTriangle(a); SetRowEdge(a,3); ELSIF mid AND (NOT side) THEN SetVertex(Org(a), vlt); SetVertex(Org(Clock(a)), vlf); SetRowTriangle(a); SetRowEdge(a,3); ELSIF NOT mid THEN SetVertex(Org(a), vlt); SetVertex(Org(Clock(a)), vlf); SetRowTriangle(a); SetRowEdge(a,3); WITH an = Enext_1(Fnext(Enext(a))) DO SetVertex(Org(an),vlt); SetRowTriangle(an); SetRowEdge(Clock(an),2); END END END SetDual; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFile"); o.inFile := pp.getNext(); pp.getKeyword("-outFile"); o.outFile := pp.getNext(); o.net := pp.keywordPresent("-net"); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: GeralBarySubdivision" ); Wr.PutText(stderr, " -inFile -outFile \\\n" ); Wr.PutText(stderr, " [ -net ] \n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt() END GeralBarySubdivision. (**************************************************************************) (* *) (* Copyright (C) 2001 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/Halo.m3 MODULE Halo EXPORTS Main; (* This program implements the "Atmospheric effect" technique. If we only render vertices, edges, and faces of the 3D model, ignoring the cells, we will get a rather incomplete, ``paper frame'' view of the 3-map---just as incomplete as a wireframe view of a triangle mesh. To complete the picture, we should make the cells themselves visible, by filling them with some semitransparent participating medium ---such as fog, rain, colored liquid, neon glow, etc. Notice: Run the results of this module with the POVRay code in /n/lac/pkg/povray-3.1a-1/PUB/sun4-SunOS-5.5 *) IMPORT Triangulation, FileWr, ParseParams, OSError, Process, Wr, Thread, Stdio, Tridimensional, LR3, LR3Extras, R3, LR4, LR4Extras, Text, Fmt, Math, Mis; FROM Triangulation IMPORT Topology, TetraNegPosVertices, Pair, OrgV, Coords; FROM Stdio IMPORT stderr; FROM Tridimensional IMPORT Coord3D; FROM Octf IMPORT Tors, Enext, Enext_1, Clock; FROM Pov IMPORT WritePOVCylinder, WritePOVSphere, WritePOVTetrahedron, WritePOVTriangle; CONST Epsilon = 0.0000000001d0; VAR Wa,Wb,Wc,Wd : LR4.T; TYPE Quad = RECORD u, v, w, x: CARDINAL END; Options = RECORD inFileTp: TEXT; inFileSt: TEXT; outFile: TEXT; projectionName: TEXT; autoProject: BOOLEAN; normalize: LONGREAL; (* Normalize al vertices onto the S^3 with that radius.*) From4: LR4.T; (* *) To4: LR4.T; (* 4D viewing parameters as expected by the *) Up4: LR4.T; (* "Wire4"- Interactive 4D Wireframe Display *) Over4: LR4.T; (* Program. *) Vangle4: LONGREAL; (* *) silhouette:BOOLEAN; (* TRUE draws the silhouette faces *) filter: BOOLEAN; (* TRUE uses filtered colors, FALSE transmit colors. *) color: R3.T; (* attributes of color and opacity for silhouette *) opacity: REAL; (* faces,Transparent (opacity=1) Opaque (opacity=1)*) all: BOOLEAN; (* drawing all vertices and edges *) cell: CARDINAL; END; PROCEDURE WL(x: LONGREAL) : TEXT = BEGIN RETURN(Fmt.Pad(Fmt.LongReal(x, Fmt.Style.Fix, prec := 2), 6)); END WL; PROCEDURE Sign(d: LONGREAL) : BOOLEAN = (* Return TRUE iff the longreal value is positive, FALSE c.c. *) BEGIN <* ASSERT d # 0.0d0 *> IF d < 0.0d0 THEN RETURN FALSE ELSE RETURN TRUE END; END Sign; PROCEDURE DoIt() = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options := GetOptions(); newcomments: TEXT; BEGIN WITH tc = Triangulation.ReadToTaMa(o.inFileTp), top = tc.top, rc = Triangulation.ReadState(o.inFileSt), c = rc^, rc3 = NEW(REF Tridimensional.Coord3D, top.NV), c3 = rc3^, rdepth = NEW(REF ARRAY OF LONGREAL, top.NV), depth = rdepth^, comments = tc.comments & "\nProjected in " & o.projectionName & ": " & o.outFile & ".st3 on " & Mis.Today() DO IF o.normalize > 0.0d0 THEN Wr.PutText(stderr, "projecting vertices onto the unit S^3\n"); NormalizeVertexCoords(c, o.normalize); END; IF o.autoProject THEN SelectProjection(o, c, top); newcomments := comments & "\nWith AutoProject"; ELSE newcomments := comments & "\nParameters: " & "\nFrom4: " & WL(o.From4[0]) & WL(o.From4[1]) & WL(o.From4[2]) & WL(o.From4[3]) & "\nTo4: " & WL(o.To4[0]) & WL(o.To4[1]) & WL(o.To4[2]) & WL(o.To4[3]) & "\nUp4: " & WL(o.Up4[0]) & WL(o.Up4[1]) & WL(o.Up4[2]) & WL(o.Up4[3]) & "\nOver4: " & WL(o.Over4[0]) & WL(o.Over4[1]) & WL(o.Over4[2]) & WL(o.Over4[3]) & "\nVangle4: " & WL(o.Vangle4); END; ProjectTo3D(o, c, c3, depth, top); WritePOVFile(o.outFile&"-"&Fmt.Int(o.cell), top, c3, o); END END DoIt; PROCEDURE NormalizeVertexCoords(VAR c: Coords; newR: LONGREAL) = BEGIN WITH b = Barycenter(c) DO FOR i := 0 TO LAST(c) DO WITH p = c[i], q = LR4.Sub(p, b), r = LR4.Norm(q) DO IF r > 0.0d0 THEN p := LR4.Scale(newR/r, q) END END END END END NormalizeVertexCoords; PROCEDURE Barycenter(READONLY c: Coords): LR4.T = VAR B: LR4.T := LR4.T{0.0d0, ..}; BEGIN FOR i := 0 TO LAST(c) DO B := LR4.Add(B, c[i]) END; RETURN LR4.Scale(1.0d0/FLOAT(NUMBER(c), LONGREAL), B) END Barycenter; PROCEDURE CalcV4Matrix(READONLY o: Options) = (* This procedure computes the four basis vectors for the 4D viewing matrix, Wa,Wb,Wc, and Wd. Note that the Up vector transforms to Wb, the Over vector transforms to Wc, and the line of sight transforms to Wd. The Wa vector is then computed from Wb,Wc and Wd. *) <* FATAL Wr.Failure, Thread.Alerted *> VAR norm : LONGREAL; BEGIN (* Calculate Wd, the 4th coordinate basis vector and line-of-sight. *) Wd := LR4.Sub(o.To4,o.From4); norm := LR4.Norm(Wd); IF norm < Epsilon THEN Wr.PutText(stderr,"4D To Point and From Point are the same\n"); Process.Exit(1); END; Wd := LR4.Scale(1.0d0/norm, Wd); (* Calculate Wa, the X-axis basis vector. *) Wa := LR4Extras.Cross(o.Up4,o.Over4,Wd); norm := LR4.Norm(Wa); IF norm < Epsilon THEN Wr.PutText(stderr, "4D up,over and view vectors are not perpendicular\n"); Process.Exit(1); END; Wa := LR4.Scale(1.0d0/norm, Wa); (* Calculate Wb, the perpendicularized Up vector. *) Wb := LR4Extras.Cross(o.Over4,Wd,Wa); norm := LR4.Norm(Wb); IF norm < Epsilon THEN Wr.PutText(stderr,"Invalid 4D over vector\n"); Process.Exit(1); END; Wb := LR4.Scale(1.0d0/norm, Wb); (* Calculate Wc, the perpendicularized Over vector. Note that the resulting vector is already normalized, since Wa, Wb and Wd are all unit vectors. *) Wc := LR4Extras.Cross(Wd,Wa,Wb); END CalcV4Matrix; PROCEDURE ProjectTo3D( READONLY o: Options; READONLY c: Coords; VAR c3: Tridimensional.Coord3D; VAR depth: ARRAY OF LONGREAL; READONLY top: Topology ) = <* FATAL Wr.Failure, Thread.Alerted *> VAR Tan2Vangle4, Data4Radius, pconst, rtemp: LONGREAL; TempV : LR4.T; BEGIN WITH angle = o.Vangle4/2.0d0, angler = (FLOAT(Math.Pi,LONGREAL)*angle)/180.0d0 DO Tan2Vangle4 := Math.tan(angler); END; (* Find the radius of the 4D data. The radius of the 4D data is the radius of the smallest enclosing sphere, centered at the To point. Note that during the loop through the vertices, Data4Radius holds the squared radius value. *) Data4Radius := 0.0d0; FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i], Temp4 = LR4.Sub(c[v.num],o.To4), dist = LR4.Dot(Temp4,Temp4) DO IF dist > Data4Radius THEN Data4Radius := dist; END END END; Data4Radius := Math.sqrt(Data4Radius); Wr.PutText(stderr,"Data4Radius: "& Fmt.Pad(Fmt.LongReal(Data4Radius, Fmt.Style.Fix, prec := 4),8)&"\n\n"); CalcV4Matrix(o); IF Text.Equal(o.projectionName, "Parallel") THEN rtemp := 1.0d0 / Data4Radius; ELSE pconst := 1.0d0 / Tan2Vangle4; END; FOR i := 0 TO top.NV-1 DO (* Transform the vertices from 4D World coordinates to 4D eye coordinates. *) WITH v = top.vertex[i] DO TempV := LR4.Sub(c[v.num],o.From4); depth[v.num] := LR4.Dot(TempV,Wd); IF Text.Equal(o.projectionName, "Perspective") THEN rtemp := pconst / depth[v.num]; END; c3[v.num][0] := rtemp * LR4.Dot(TempV, Wa); c3[v.num][1] := rtemp * LR4.Dot(TempV, Wb); c3[v.num][2] := rtemp * LR4.Dot(TempV, Wc); END END END ProjectTo3D; PROCEDURE TetrahedronVertices(f:Triangulation.Pair): ARRAY [0..3] OF CARDINAL = BEGIN WITH g = Tors(f), h = Tors(Clock(Enext_1(f))), p = OrgV(g).num, q = OrgV(Enext(g)).num, r = OrgV(Enext_1(g)).num, s = OrgV(Enext_1(h)).num DO RETURN ARRAY [0..3] OF CARDINAL{p, q, r, s} END END TetrahedronVertices; PROCEDURE SelectProjection( VAR o: Options; READONLY c: Coords; READONLY top: Topology ) = VAR norm: LR4.T := LR4.T{0.0d0, ..}; BEGIN FOR i := 0 TO top.NP-1 DO WITH f = top.region[i], k = TetrahedronVertices(f), p = c[k[0]], q = c[k[1]], r = c[k[2]], s = c[k[3]], pq = LR4.Sub(q, p), pr = LR4.Sub(r, p), ps = LR4.Sub(s, p), v = LR4Extras.Cross(pq, pr, ps), n = LR4.Dir(v) DO norm := LR4.Add(norm, n) END END; WITH m = LR4.Norm(norm) DO IF m < 1.0d-20 THEN norm := LR4.T{1.0d0, 0.0d0, ..} ELSE norm := LR4.Scale(1.0d0/m, norm) END END; WITH bar = Triangulation.Barycenter(top, c) DO o.To4 := bar; o.From4 := LR4.Add(o.To4, norm); SelectTwoIndepDirs(norm, o.Up4, o.Over4); o.Vangle4 := 120.0d0; END; END SelectProjection; PROCEDURE SelectTwoIndepDirs( READONLY u: LR4.T; VAR v, w: LR4.T; ) = (* Selects two vectors "v", "w", independent of each other and of the given vector "u". *) VAR m: CARDINAL := 0; BEGIN (* Find the largest coordinate of "u": *) FOR i := 1 TO 3 DO IF ABS(u[i]) > ABS(u[m]) THEN m := i END END; FOR i := 0 TO 3 DO v[i] := 0.0d0; w[i] := 0.0d0 END; v[(m+1) MOD 4] := 1.0d0; w[(m+2) MOD 4] := 1.0d0; END SelectTwoIndepDirs; PROCEDURE WritePOVFile( name: TEXT; READONLY top: Topology; READONLY c3: Tridimensional.Coord3D; READONLY op : Options; ) = <* FATAL Wr.Failure, Thread.Alerted, OSError.E *> BEGIN WITH wr = FileWr.Open(name & ".inc") DO Wr.PutText(wr, "// Include File: <" & name & ".inc>\n"); WritePOV(wr, top, c3, op); Wr.Close(wr) END END WritePOVFile; PROCEDURE WritePOV( wr: Wr.T; READONLY top: Topology; READONLY c3: Coord3D; READONLY o : Options; ) = <* FATAL Wr.Failure, Thread.Alerted *> PROCEDURE FindOriR3(q: Quad) : LONGREAL = (* For each tetrahedron with extremus vertices numbers u,v,w,x computes its orientation in R^{3} through the 4x4 determinant: _ _ | c3[q.u][0] c3[q.u][1] c3[q.u][2] 1.0d0 | B = | c3[q.v][0] c3[q.v][1] c3[q.v][2] 1.0d0 | | c3[q.w][0] c3[q.w][1] c3[q.w][2] 1.0d0 | | c3[q.x][0] c3[q.x][1] c3[q.x][2] 1.0d0 | - - *) BEGIN WITH a = LR4.T{c3[q.u][0], c3[q.u][1], c3[q.u][2], 1.0d0}, b = LR4.T{c3[q.v][0], c3[q.v][1], c3[q.v][2], 1.0d0}, c = LR4.T{c3[q.w][0], c3[q.w][1], c3[q.w][2], 1.0d0}, d = LR4.T{c3[q.x][0], c3[q.x][1], c3[q.x][2], 1.0d0} DO RETURN LR4Extras.Det(a,b,c,d); END END FindOriR3; PROCEDURE SilhouetteFaces(a: Pair) : BOOLEAN = (* Return TRUE iff the face associated to the pair "a" is a silhouette face, FALSE c.c. *) BEGIN WITH t = TetraNegPosVertices(a), un = t[0].num, vn = t[1].num, wn = t[2].num, xn = t[3].num, yn = t[4].num, t1 = Quad{un,vn,wn,xn}, t2 = Quad{un,vn,wn,yn}, d1 = FindOriR3(t1), d2 = FindOriR3(t2) DO IF (Sign(d1) AND Sign(d2)) OR ((NOT Sign(d1)) AND (NOT Sign(d2))) THEN RETURN TRUE ELSE RETURN FALSE END END END SilhouetteFaces; BEGIN (* drawing the edges *) FOR i := 0 TO top.NE-1 DO WITH e = top.edge[i] DO IF e.exists OR o.all THEN WITH oo = e.vertex[0].num, d = e.vertex[1].num, t3 = e.transp, transp = (t3[0] + t3[1] + t3[2]) / 3.0 DO WritePOVCylinder(wr,c3[oo], c3[d], e.radius, e.color, transp, o.filter); END END END END; (* drawing the vertices *) FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i] DO IF v.exists OR o.all THEN WITH t3 = v.transp, transp = (t3[0] + t3[1] + t3[2]) / 3.0 DO WritePOVSphere(wr,c3[i], v.radius, v.color, transp, o.filter); END END END END; FOR i := 0 TO top.NP-1 DO WITH r = top.region[i], a = Tors(r), t = Triangulation.TetraNegVertices(a), cun = c3[t[0].num], cvn = c3[t[1].num], cwn = c3[t[2].num], cxn = c3[t[3].num], color = top.polyhedron[i].color, dwu = LR3.Sub(cwn,cun), dvu = LR3.Sub(cvn,cun), dxu = LR3.Sub(cxn,cun), dwv = LR3.Sub(cwn,cvn), dxv = LR3.Sub(cxn,cvn), nf0 = LR3Extras.Cross(dwu,dvu), nf02 = LR3.Norm(nf0), nu0 = LR3.Dot(nf0,cun), nf1 = LR3Extras.Cross(dvu,dxu), nf12 = LR3.Norm(nf1), nu1 = LR3.Dot(nf1,cun), nf2 = LR3Extras.Cross(dwv,dxv), nf22 = LR3.Norm(nf2), nu2 = LR3.Dot(nf2,cvn), nf3 = LR3Extras.Cross(dxu,dwu), nf32 = LR3.Norm(nf3), nu3 = LR3.Dot(nf3,cun), df0 = nu0/nf02, df1 = nu1/nf12, df2 = nu2/nf22, df3 = nu3/nf32 DO CASE o.cell OF | 1 => IF color = R3.T{1.0,0.0,0.0} THEN WritePOVTetrahedron(wr,nf0,nf1,nf2,nf3,df0,df1,df2,df3,color, 0.75, o.filter); END; | 2 => IF color = R3.T{0.0,1.0,0.0} THEN WritePOVTetrahedron(wr,nf0,nf1,nf2,nf3,df0,df1,df2,df3,color, 0.75,o.filter); END; | 3 => IF color = R3.T{0.0,0.0,1.0} THEN WritePOVTetrahedron(wr,nf0,nf1,nf2,nf3,df0,df1,df2,df3,color, 0.75,o.filter); END; | 4 => IF color = R3.T{1.0,1.0,0.0} THEN WritePOVTetrahedron(wr,nf0,nf1,nf2,nf3,df0,df1,df2,df3,color, 0.75,o.filter); END; | 5 => IF color = R3.T{0.0,1.0,1.0} THEN WritePOVTetrahedron(wr,nf0,nf1,nf2,nf3,df0,df1,df2,df3,color, 0.75,o.filter); END; | 6 => IF color = R3.T{1.0,0.0,1.0} THEN WritePOVTetrahedron(wr,nf0,nf1,nf2,nf3,df0,df1,df2,df3,color, 0.75,o.filter); END; | 7 => IF color = R3.T{0.0,0.0,0.0} THEN WritePOVTetrahedron(wr,nf0,nf1,nf2,nf3,df0,df1,df2,df3,color, 0.75,o.filter); END; | 8 => IF color = R3.T{1.0,1.0,1.0} THEN WritePOVTetrahedron(wr,nf0,nf1,nf2,nf3,df0,df1,df2,df3,color, 0.75,o.filter); END; ELSE (* nothing *) END END END; IF o.silhouette AND (top.der = 3) THEN FOR i := 0 TO top.NF-1 DO WITH f = top.face[i], a = f.pa, un = f.vertex[0].num, vn = f.vertex[1].num, wn = f.vertex[2].num, c = o.color, t = o.opacity DO IF SilhouetteFaces(a) AND (NOT f.exists) THEN WritePOVTriangle(wr,c3[un], c3[vn], c3[wn],c,t, o.filter); END END END END; Wr.Flush(wr); END WritePOV; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFileTp"); o.inFileTp := pp.getNext(); pp.getKeyword("-inFileSt"); o.inFileSt := pp.getNext(); IF pp.keywordPresent("-outFile") THEN o.outFile := pp.getNext() ELSE o.outFile := o.inFileTp END; o.all := pp.keywordPresent("-all"); o.filter := pp.keywordPresent("-filter"); IF pp.keywordPresent("-silhouette") THEN o.silhouette := TRUE; IF pp.keywordPresent("-color") THEN FOR j := 0 TO 2 DO o.color[j] := pp.getNextReal(0.0,1.0); END; ELSE o.color := R3.T{1.0,1.0,0.85}; END; IF pp.keywordPresent("-opacity") THEN o.opacity := pp.getNextReal(0.0,1.0); ELSE o.opacity := 0.85; END END; pp.getKeyword("-projection"); o.projectionName := pp.getNext(); IF NOT (Text.Equal(o.projectionName, "Parallel") OR Text.Equal(o.projectionName, "Perspective")) THEN pp.error("Bad projection \"" & pp.getNext() & "\"\n") END; IF pp.keywordPresent("-normalize") THEN (* Desired radius of model in R^4 *) o.normalize := pp.getNextLongReal(1.0d-10,1.0d+10); ELSE o.normalize := 0.0d0 (* No normalization *) END; IF pp.keywordPresent("-autoProject") THEN o.autoProject := TRUE ELSE IF pp.keywordPresent("-From4") THEN FOR j := 0 TO 3 DO o.From4[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.From4 := LR4.T{0.0d0,0.0d0,0.0d0,-3.0d0}; END; IF pp.keywordPresent("-To4") THEN FOR j := 0 TO 3 DO o.To4[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.To4 := LR4.T{0.0d0,0.0d0,0.0d0,0.0d0}; END; IF pp.keywordPresent("-Up4") THEN FOR j := 0 TO 3 DO o.Up4[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.Up4 := LR4.T{0.0d0,1.0d0,0.0d0,0.0d0}; END; IF pp.keywordPresent("-Over4") THEN FOR j := 0 TO 3 DO o.Over4[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.Over4 := LR4.T{0.0d0,0.0d0,1.0d0,0.0d0}; END; END; IF pp.keywordPresent("-Vangle4") THEN o.Vangle4 := pp.getNextLongReal(1.0d0, 179.0d0); ELSE o.Vangle4 := 25.0d0; END; IF pp.keywordPresent("-cell") THEN o.cell := pp.getNextInt(1, 24); END; pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: Halo \\\n"); Wr.PutText(stderr," -inFileTp -inFileSt \\\n"); Wr.PutText(stderr," [ -outFile ] [ -all ] \\\n"); Wr.PutText(stderr, " -projection [ Perspective | Parallel ]\\\n"); Wr.PutText(stderr, " [ [ -autoProject ] | \\\n"); Wr.PutText(stderr, " [ -From4 ] \\\n"); Wr.PutText(stderr, " [ -To4 ] \\\n"); Wr.PutText(stderr, " [ -Up4 ] \\\n"); Wr.PutText(stderr, " [ -Over4 ]\\\n"); Wr.PutText(stderr, " ] [ -Vangle4 ] \\\n"); Wr.PutText(stderr," [ -silhouette [ -color | -opacity | -filter ] ]\\\n"); Wr.PutText(stderr," [ -cell ]\n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt(); END Halo. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/JSNewExplode.m3 MODULE JSNewExplode EXPORTS Main; (* This program recieves as input a topology and geometry of a 3D map with border and produces a ".inc" file for the PovRay. The cells are presented in the exploding way. Revisions: 27-01-2001 : Modified for exploding cubic cells. *) IMPORT Thread, Wr, Process, Triangulation, ParseParams, R3, FileWr, LR3, Tridimensional, OSError, Octf; FROM LR3 IMPORT Add, Scale; FROM Stdio IMPORT stderr; FROM Pov IMPORT WritePOVCylinder, WritePOVTriangle, WritePOVSphere; FROM Wr IMPORT PutText; FROM Octf IMPORT Enext, Clock; FROM Triangulation IMPORT Pair, Org, Vertex, Node; TYPE Options = RECORD inFileTp: TEXT; (* Input file name (minus ".tp" extension) *) inFileSt3: TEXT; (* Input file name (minus ".st3" extension) *) outFile: TEXT; (* Output file name prefix *) opacity : REAL; (* opacity factor *) radius : REAL; (* radius drawing *) factor : REAL; (* factor exploding *) END; PROCEDURE DoIt() = <* FATAL OSError.E *> VAR c : REF Tridimensional.Coord3D; inc: Wr.T; PROCEDURE DrawDisplacedVertex(e: Pair; READONLY delta: LR3.T; ra: REAL; color: R3.T; tr: REAL) = (* Draws the vertex OrgV(e) displaced by delta *) BEGIN WITH v = NARROW(Org(e), Vertex), p = Add(c[v.num], delta) DO WritePOVSphere(inc,p,ra,color,tr,TRUE) END END DrawDisplacedVertex; PROCEDURE DrawDisplacedEdge(e: Pair; READONLY delta: LR3.T; ra: REAL; color: R3.T; tr: REAL) = (* Draws the edge Edge(e) displaced by delta *) BEGIN WITH u = NARROW(Org(e), Vertex), v = NARROW(Org(Clock(e)), Vertex), p = Add(c[u.num], delta), q = Add(c[v.num], delta) DO WritePOVCylinder(inc,p,q,ra,color,tr,TRUE) END END DrawDisplacedEdge; PROCEDURE DrawDisplacedFace(e: Pair; READONLY delta: LR3.T; color: R3.T; tr: REAL) = (* Draws the face ``e.facetedge.face'' (polygonal face) displaced by delta *) VAR b, d: Pair; BEGIN b := Enext(e); d := Enext(b); REPEAT WITH u = Org(e), v = Org(b), w = Org(d), p = Add(c[u.num], delta), q = Add(c[v.num], delta), r = Add(c[w.num], delta) DO WritePOVTriangle(inc,p,q,r,color,tr,TRUE); b := d; d := Enext(d) END UNTIL d = e; END DrawDisplacedFace; BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToTaMa(o.inFileTp), top = tc.top, pink = R3.T{1.000, 0.745, 0.745}, black = R3.T{0.0, 0.0, 0.0} DO inc := FileWr.Open(o.outFile & "-Ex.inc"); c := Tridimensional.ReadState3D(o.inFileSt3); FOR i := 0 TO top.NP-1 DO WITH ptop = Triangulation.MakePolyhedronTopology(top.region[i]), pi = top.polyhedron[i], pv = pi.vertex^, bar = ComputeBarycenter(c, pv), delta = Scale(FLOAT(o.factor,LONGREAL), bar) DO (* Write vertices: *) FOR i := 0 TO ptop.NV-1 DO WITH e = ptop.vRef[i] DO DrawDisplacedVertex(e, delta, o.radius, black, 0.0) END END; (* Write edges: *) FOR i := 0 TO ptop.NE-1 DO WITH e = ptop.eRef[i] DO DrawDisplacedEdge(e, delta, o.radius, black, 0.0) END END; (* Write Faces: *) FOR i := 0 TO ptop.NF-1 DO WITH e = ptop.fRef[i] DO DrawDisplacedFace(e, delta, pink, o.opacity) END END; END END END END DoIt; PROCEDURE ComputeBarycenter(READONLY c: REF Tridimensional.Coord3D; READONLY pv : ARRAY OF Node) : LR3.T = VAR B: LR3.T := LR3.T{0.0d0, ..}; N: CARDINAL := 0; BEGIN FOR i := 0 TO LAST(pv)-1 DO B := LR3.Add(B, c[i]); INC(N); END; RETURN LR3.Scale(1.0d0/FLOAT(N, LONGREAL), B) END ComputeBarycenter; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFileTp"); o.inFileTp := pp.getNext(); pp.getKeyword("-inFileSt3"); o.inFileSt3 := pp.getNext(); pp.getKeyword("-outFile"); o.outFile := pp.getNext(); IF pp.keywordPresent("-opacity") THEN o.opacity := pp.getNextReal(0.0, 1.0); ELSE o.opacity := 0.65; END; IF pp.keywordPresent("-radius") THEN o.radius := pp.getNextReal(0.0, 0.1); ELSE o.radius := 0.005; END; IF pp.keywordPresent("-factor") THEN o.factor := pp.getNextReal(1.0, 6400.0); END; pp.finish(); EXCEPT | ParseParams.Error => PutText(stderr, "Usage: NewExplode \\\n"); PutText(stderr, " -inFileTp \\\n"); PutText(stderr, " -inFileSt3 \\\n"); PutText(stderr, " -outFile \\\n"); PutText(stderr, " [-opacity ] [-radius ] \\\n"); PutText(stderr, " [-factor ]\n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt() END JSNewExplode. (**************************************************************************) (* *) (* Copyright (C) 2001 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/JSRefineTriang.m3 MODULE RefineTriang EXPORTS Main; (* Refines (or duplicate) a given triangulation (".tp" file). See notice of copyright at the end of this file. Revisions: 21-05-2000: Fixed and removed a bug that increases the number of original vertices of type "VV". 31-05-2000: Added the heredity of the "root" attributes for edges and faces. 11-06-2000: Hidden the new elements insert in the refiment process: edges and vertices are set with the attibute "exists= FALSE" 25-11-2000: Added the option "net" for simulate textures on existing faces with thin cylinders and small spheres. *) IMPORT Thread, Wr, Process, LR4, Triangulation, Octf, ParseParams, R3; FROM Triangulation IMPORT Coords, Vertex, OrgV, MakeFacetEdge, MakeVertex, SetOrg, Org, Pneg, Ppos, MakePolyhedron, FacetEdge, Node, SetAllOrgs, SetNextPneg; FROM Octf IMPORT Pair, Tors, Spin, Clock, Fnext, SpinBit, OrientationBit, SpliceEdges, Enext, SetFnext, SetEnext, SetFace, Enext_1, SetEdge, Fnext_1, SetEdgeAll, Srot, SetFaceAll; FROM Stdio IMPORT stderr; VAR x: REF ARRAY OF Vertex; NNV: CARDINAL := 0; TYPE Options = RECORD inFileTp: TEXT; (* Input file name (minus ".tp" extension) *) inFileSt: TEXT; (* Input file name (minus ".st" extension) *) outFile : TEXT; (* Output file name prefix *) fixOri : BOOLEAN; (* TRUE to fix original vertices *) assert : BOOLEAN; (* make some strong assertions *) net : BOOLEAN; (* simulate a net as small spheres and thin cylinders. *) END; RowT = ARRAY [0..3] OF Pair; CONST ThinEdgeExists = FALSE; PROCEDURE DoIt() = <* FATAL Wr.Failure, Thread.Alerted *> VAR gi : REF ARRAY OF ARRAY OF Pair; ntop : Triangulation.Topology; BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToTaMa(o.inFileTp,FALSE), (* TRUE for indicate root of tetrahedra *) top = tc.top, rc = Triangulation.ReadState(o.inFileSt), c = rc^, half = NEW(REF ARRAY OF Pair, 2*top.NFE)^, vnew = NEW(REF ARRAY OF Vertex, top.NV)^ DO Wr.PutText(stderr, "Refining from: " & o.inFileTp & ".tp\n"); gi := NEW(REF ARRAY OF ARRAY OF Pair, top.NP, 4); x := NEW(REF ARRAY OF Vertex, top.NP); PROCEDURE Half(a: Pair): Pair = BEGIN WITH na = a.facetedge.num, oa = OrientationBit(a), sa = SpinBit(a), h = half[2*na + oa] DO IF sa = 0 THEN RETURN h ELSE RETURN Spin(h) END END END Half; (* ==== Refine the Tetrahedral Cell ==== *) PROCEDURE RefineCell(g: RowT; in: CARDINAL) = BEGIN (* To insert four faces obliques "i", "j", "k", "l" *) WITH i = MakeTriangle(FALSE), j = MakeTriangle(FALSE), k = MakeTriangle(FALSE), l = MakeTriangle(FALSE) DO (* the facet "i" will be splice with g[1], g[2], g[3] *) SetFnext(i,Clock(g[1])); SetFnext(Enext(i),Enext(g[3])); SetFnext(Enext_1(i),Clock(g[2])); (* updating component edge *) SetEdgeAll(i, g[1].facetedge.edge); SetEdgeAll(Enext(i), Enext(g[3]).facetedge.edge); SetEdgeAll(Enext_1(i), g[2].facetedge.edge); (* updating origins *) SetOrg(i, Org(g[2])); SetOrg(Clock(i), Org(g[1])); SetOrg(Enext(i), Org(Clock(i))); SetOrg(Clock(Enext(i)), Org(Enext(g[2]))); SetOrg(Enext_1(i), Org(Clock(Enext(i)))); SetOrg(Clock(Enext_1(i)), Org(i)); (* the facet "j" will be splice with: g[0], g[1], g[2] *) SetFnext(j,Enext(g[0])); SetFnext(Enext(j),Clock(Enext(g[1]))); SetFnext(Enext_1(j),Clock(Enext_1(g[2]))); (* updating component edge *) SetEdgeAll(j, Enext(g[0]).facetedge.edge); SetEdgeAll(Enext(j), Enext(g[1]).facetedge.edge); SetEdgeAll(Enext_1(j), Enext_1(g[2]).facetedge.edge); (* updating origins *) SetOrg(j, Org(Enext(g[0]))); SetOrg(Clock(j), Org(Enext_1(g[0]))); SetOrg(Enext(j), Org(Clock(j))); SetOrg(Clock(Enext(j)), Org(g[2])); SetOrg(Enext_1(j), Org(Clock(Enext(j)))); SetOrg(Clock(Enext_1(j)), Org(j)); (* the facet "k" will be splice with: g[0], g[1], g[3]) *) SetFnext(k,Clock(Fnext_1(Enext_1(g[0])))); SetFnext(Enext(k),Fnext(Enext_1(g[1]))); SetFnext(Enext_1(k),Clock(Fnext_1(g[3]))); (* updating component edge *) SetEdgeAll(k,Enext_1(g[0]).facetedge.edge); SetEdgeAll(Enext(k),Enext_1(g[1]).facetedge.edge); SetEdgeAll(Enext_1(k),g[3].facetedge.edge); (* updating origins *) SetOrg(k, Org(g[0])); SetOrg(Clock(k), Org(Enext_1(g[0]))); SetOrg(Enext(k), Org(Clock(k))); SetOrg(Clock(Enext(k)), Org(g[1])); SetOrg(Enext_1(k), Org(Clock(Enext(k)))); SetOrg(Clock(Enext_1(k)), Org(k)); (* the facet "l" will be splice with: g[0], g[2], g[3] *) SetFnext(l, Clock(Fnext_1(g[0]))); SetFnext(Enext(l), Clock(Fnext_1(Enext_1(g[3])))); SetFnext(Enext_1(l), Fnext(Enext(g[2]))); (* updating component edge *) SetEdgeAll(l, g[0].facetedge.edge); SetEdgeAll(Enext(l), Enext_1(g[3]).facetedge.edge); SetEdgeAll(Enext_1(l), Enext(g[2]).facetedge.edge); (* updating origins *) SetOrg(l, Org(Clock(g[0]))); SetOrg(Clock(l), Org(g[0])); SetOrg(Enext(l), Org(Clock(l))); SetOrg(Clock(Enext(l)), Org(Enext(g[2]))); SetOrg(Enext_1(l), Org(Clock(Enext(l)))); SetOrg(Clock(Enext_1(l)), Org(l)); (* Subdivision of the Octahedron (in four tetrahedron) delimitate by the medial vertices *) WITH o1 = MakeTriangle(FALSE), o2 = MakeTriangle(FALSE), o3 = MakeTriangle(FALSE), o4 = MakeTriangle(FALSE) DO <* ASSERT i = Fnext_1(Clock(g[1])) *> <* ASSERT i = Clock(Fnext(g[1])) *> <* ASSERT i = Clock(Enext_1(Fnext(g[2]))) *> <* ASSERT j = Fnext_1(Enext(g[0])) *> <* ASSERT k = Clock(Fnext_1(Enext_1(g[0]))) *> <* ASSERT k = Clock(Enext_1(Fnext_1(g[3]))) *> <* ASSERT l = Clock(Fnext_1(g[0])) *> (* triangle o1 *) SetFnext(o1, Enext(k)); SetFnext(Enext_1(g[1]), o1); SetFnext(Enext_1(o1), Enext(g[0])); SetFnext(j, Enext_1(o1)); (* updating component edge *) SetEdgeAll(o1, Enext(k).facetedge.edge); SetEdgeAll(Enext_1(o1), j.facetedge.edge); (* updating origins *) SetOrg(o1, Org(Enext_1(g[1]))); SetOrg(Clock(o1), Org(Clock(Enext_1(g[1])))); SetOrg(Enext_1(o1), Org(Enext(g[0]))); SetOrg(Clock(Enext_1(o1)), Org(Clock(Enext(g[0])))); SetOrg(Enext(o1), Org(Enext_1(k))); SetOrg(Clock(Enext(o1)), Org(j)); (* triangle o2 *) SetFnext(Enext(o2), Enext(g[3])); SetFnext(Enext(i), Enext(o2)); SetFnext(Enext_1(o2), Enext_1(l)); SetFnext(Enext(g[2]), Enext_1(o2)); (* updating component edge *) SetEdgeAll(Enext(o2), Enext(g[3]).facetedge.edge); SetEdgeAll(Enext_1(o2), Enext(g[2]).facetedge.edge); (* updating origins *) SetOrg(o2, Org(j)); SetOrg(Clock(o2), Org(Enext_1(k))); SetOrg(Enext(o2), Org(Enext(g[3]))); SetOrg(Clock(Enext(o2)), Org(Clock(Enext(g[3])))); SetOrg(Enext_1(o2), Org(Enext(g[2]))); SetOrg(Clock(Enext_1(o2)), Org(Clock(Enext(g[2])))); (* triangle o3 *) SetFnext(o3, l); SetFnext(Clock(g[0]), o3); SetFnext(Enext(o3), g[3]); SetFnext(Clock(Enext_1(k)), Enext(o3)); (* updating component edge *) SetEdgeAll(o3, l.facetedge.edge); SetEdgeAll(Enext(o3), g[3].facetedge.edge); (* updating origins *) SetOrg(o3, Org(Clock(g[0]))); SetOrg(Clock(o3), Org(g[0])); SetOrg(Enext(o3), Org(g[3])); SetOrg(Clock(Enext(o3)), Org(Clock(g[3]))); SetOrg(Enext_1(o3), Org(Enext_1(k))); SetOrg(Clock(Enext_1(o3)), Org(j)); (* triangle o4 *) SetFnext(g[1], Enext(o4)); SetFnext(Enext(o4), Clock(i)); SetFnext(Enext_1(j), Enext_1(o4)); SetFnext(Enext_1(o4), Clock(Enext_1(g[2]))); SetFnext(o4, o2); SetFnext(o2, Clock(Enext_1(o3))); SetFnext(Clock(Enext_1(o3)), Clock(Enext(o1))); (* updating component edge *) SetEdgeAll(Enext(o4), Clock(i).facetedge.edge); SetEdgeAll(Enext_1(o4), Enext_1(j).facetedge.edge); SetEdgeAll(o2, o2.facetedge.edge); (* updating origins *) SetOrg(Enext(o4), Org(g[1])); SetOrg(Clock(Enext(o4)), Org(Clock(g[1]))); SetOrg(Enext_1(o4), Org(Clock(Enext_1(g[2])))); SetOrg(Clock(Enext_1(o4)), Org(Enext_1(g[2]))); SetOrg(o4, Org(o2)); SetOrg(Clock(o4), Org(Clock(o2))); (* making eigth tetrahedral cells *) SetAllPneg(j); SetAllPneg(Clock(Fnext_1(Enext_1(Fnext(k))))); SetAllPneg(Clock(Fnext_1(Enext(i)))); SetAllPneg(Clock(Fnext_1(Enext(Fnext(l))))); SetAllPneg(Enext_1(Fnext(o1))); SetAllPneg(o2); SetAllPneg(Fnext(o3)); SetAllPneg(o4); IF o.assert THEN (* Some strong assertions *) <* ASSERT Org(Srot(j)) = Pneg(j) *> <* ASSERT Org(Srot(Clock(Fnext_1(Enext_1(Fnext(k)))))) = Pneg(Clock(Fnext_1(Enext_1(Fnext(k))))) *> <* ASSERT Org(Srot(Clock(Fnext_1(Enext(i))))) = Pneg(Clock(Fnext_1(Enext(i)))) *> <* ASSERT Org(Srot(Clock(Fnext_1(Enext(Fnext(l)))))) = Pneg(Clock(Fnext_1(Enext(Fnext(l))))) *> <* ASSERT Org(Srot(Fnext(o3))) = Pneg(Fnext(o3)) *> <* ASSERT Org(Srot(Enext_1(Fnext(o1)))) = Pneg(Enext_1(Fnext(o1))) *> <* ASSERT Org(Srot(o4)) = Pneg(o4) *> <* ASSERT Org(Srot(o2)) = Pneg(o2) *> WITH v = Srot(j), v1 = Clock(Enext_1(Srot(j))) DO <* ASSERT Pneg(Tors(v)) = Pneg(Tors(v1)) *> END; WITH v = Srot(Fnext(o3)), v1 = Clock(Enext_1(Srot(Fnext(o3)))) DO <* ASSERT Pneg(Tors(v)) = Pneg(Tors(v1)) *> END; WITH v = Srot(o2), v1 = Clock(Enext_1(Srot(o2))) DO <* ASSERT Pneg(Tors(v)) = Pneg(Tors(v1)) *> END; WITH v = Srot(o4), v1 = Clock(Enext_1(Srot(o4))) DO <* ASSERT Pneg(Tors(v)) = Pneg(Tors(v1)) *> END; WITH v = Srot(Enext_1(Fnext(o1))), v1 = Clock(Enext_1(Srot(Enext_1(Fnext(o1))))) DO <* ASSERT Pneg(Tors(v)) = Pneg(Tors(v1)) *> END; WITH v = Srot(Clock(Fnext_1(Enext_1(Fnext(k))))), v1 = Clock(Enext_1(Srot(Clock(Fnext_1(Enext_1(Fnext(k))))))) DO <* ASSERT Pneg(Tors(v)) = Pneg(Tors(v1)) *> END; WITH v = Srot(Clock(Fnext_1(Enext(i)))), v1 = Clock(Enext_1(Srot(Clock(Fnext_1(Enext(i)))))) DO <* ASSERT Pneg(Tors(v)) = Pneg(Tors(v1)) *> END; WITH v = Srot(Clock(Fnext_1(Enext(Fnext(l))))), v1 = Clock(Enext_1(Srot(Clock(Fnext_1(Enext(Fnext(l))))))) DO <* ASSERT Pneg(Tors(v)) = Pneg(Tors(v1)) *> END END; (* Now, refine the subdivision of the octahedron in more four tetrahedra, through the subdivision of the diagonal edge of the octahedron. *) SubdivideEdge(o2,in,o.net); END END; END RefineCell; PROCEDURE CreateVertex(a: Pair): BOOLEAN = VAR t: Pair := a; BEGIN WITH fe = NARROW(a.facetedge,FacetEdge) DO IF NOT fe.mark THEN fe.mark := TRUE; REPEAT WITH fe = NARROW(t.facetedge,FacetEdge) DO fe.mark := TRUE; END; t := Fnext(t) UNTIL t = a; RETURN TRUE; END; RETURN FALSE; END; END CreateVertex; PROCEDURE SetAllVh(a: Pair; v: Vertex) = (* Set all adjacents pairs to "a" with the same medial vertex "v" *) PROCEDURE SetVh(b: Pair) = (* Set the pair "b" with the medial vertex "v". *) BEGIN WITH fe = NARROW(b.facetedge, FacetEdge) DO fe.vh := v; END; END SetVh; VAR t: Pair := a; BEGIN REPEAT SetVh(t); t := Fnext(t); UNTIL t = a; END SetAllVh; PROCEDURE SetAllPneg(a : Pair) = (* set the (12) pairs facetedges belonging to same 3-cell *) VAR t: Pair := a; BEGIN WITH p = MakePolyhedron() DO SetNextPneg(t,p); REPEAT SetNextPneg(Clock(Fnext_1(t)),p); t := Enext_1(t); UNTIL t = a; END END SetAllPneg; PROCEDURE Vhnum(a: Pair): CARDINAL = (* given the pair "a", this procedure return the number of its medial vertex "vh". *) BEGIN WITH fe = NARROW(a.facetedge, FacetEdge) DO RETURN fe.vh.num; END; END Vhnum; BEGIN (* Copy the original vertices, save icorrespondence in "vnew" array: *) FOR iu := 0 TO top.NV-1 DO WITH u = top.vertex[iu], v = MakeVertex() DO v.num := u.num; v.exists := u.exists; v.fixed := u.fixed OR o.fixOri; v.color := u.color; v.radius := u.radius; v.label := u.label; vnew[iu] := v END END; (* Create two new facetedges for each original facetedge "fe". The new facetedge corresponding to the origin half of "fe", with same spin and orientation, will be | Half(a) = Spin^s(half[2*a.facetedge.num + o]) where s = SpinBit(a), o = OrientationBit(a) *) VAR ve: REF ARRAY OF Vertex := NEW(REF ARRAY OF Vertex, top.NE); i: CARDINAL := 0; BEGIN FOR ie := 0 TO top.NFE-1 DO WITH a = top.facetedge[ie], oa = OrientationBit(a), sa = SpinBit(a), ho = half[2*ie + oa], hd = half[2*ie + 1 - oa], fe = NARROW(a.facetedge, FacetEdge), fn = fe.face.num, en = fe.edge.num DO IF CreateVertex(a) THEN ve[i] := MakeVertex(); ve[i].num := top.NV + NNV; INC(NNV); ve[i].exists := top.edge[en].exists; ve[i].fixed := FALSE; ve[i].color := top.edge[en].color; ve[i].transp := top.edge[en].transp; ve[i].radius := top.edge[en].radius; ve[i].label := "VE"; SetAllVh(a, ve[i]); INC(i); END; ho := MakeFacetEdge(); WITH hoe = NARROW(ho.facetedge, FacetEdge) DO hoe.edge.exists := top.edge[en].exists; hoe.edge.color := top.edge[en].color; hoe.edge.transp := top.edge[en].transp; hoe.edge.radius := top.edge[en].radius; (* set the "root" edge *) hoe.edge.root := top.edge[en].root; hoe.face.exists := top.face[fn].exists; hoe.face.color := top.face[fn].color; hoe.face.transp := top.face[fn].transp; END; IF sa = 1 THEN ho := Spin(ho) END; hd := MakeFacetEdge(); WITH hde = NARROW(hd.facetedge, FacetEdge) DO hde.edge.exists := top.edge[en].exists; hde.edge.color := top.edge[en].color; hde.edge.transp := top.edge[en].transp; hde.edge.radius := top.edge[en].radius; (* set the "root" edge *) hde.edge.root := top.edge[en].root; hde.face.exists := top.face[fn].exists; hde.face.color := top.face[fn].color; hde.face.transp := top.face[fn].transp; END; IF sa = 1 THEN hd := Spin(hd) END; SpliceEdges(ho, Clock(hd)); WITH m = Vhnum(a) DO SetOrg(Clock(ho),ve[m-top.NV]); SetOrg(Clock(hd),ve[m-top.NV]); END; SetOrg(ho, vnew[OrgV(a).num]); SetOrg(hd, vnew[OrgV(Clock(a)).num]); END END END; (* Connect the half-facetedges as in the original triangulation *) FOR ie := 0 TO top.NFE-1 DO WITH a = top.facetedge[ie], b = Fnext(a), c = Enext(a), ha = Half(a), hac = Half(Clock(a)), hb = Half(b), hc = Half(c) DO IF b # a AND Fnext(ha) # hb THEN SetFnext(ha, hb); (* so, Fnext(ha) = hb *) SetEdge(hb, ha.facetedge.edge); END; IF c # a AND Enext(Clock(hac)) # hc THEN SetEnext(Clock(hac), hc); (* so, Enext(Clock(hac) = hc *) END; END; WITH a = Clock(top.facetedge[ie]), b = Fnext(a), c = Enext(a), ha = Half(a), hac= Half(Clock(a)), hb = Half(b), hc = Half(c) DO IF b # a AND Fnext(ha) # hb THEN SetFnext(ha, hb); (* so, Fnext(ha) = hb *) SetEdge(hb, ha.facetedge.edge); END; IF Enext(Clock(hac)) # hc THEN SetEnext(Clock(hac), hc); (* so, Enext(Clock(hac) = hc *) END; END END; FOR j := 0 TO top.NF-1 DO VAR d,e,f,g : Pair; BEGIN WITH fa = top.face[j], fr = fa.root, a = fa.pa, b = Enext(a), c = Enext_1(a), ha = Half(a), hac = Half(Clock(a)), hb = Half(b), hbc = Half(Clock(b)), hc = Half(c), hcc = Half(Clock(c)) DO IF NUMBER(fa.vertex^) # 3 THEN BadElement() END; d := MakeFacetEdge(); d.facetedge.edge.exists := ThinEdgeExists; e := MakeFacetEdge(); e.facetedge.edge.exists := ThinEdgeExists; f := MakeFacetEdge(); f.facetedge.edge.exists := ThinEdgeExists; IF fa.exists AND o.net THEN WITH co = R3.T{1.00,1.00,0.50}, (* color and radius for the thin *) ra = 0.0025, (* edge on the net *) de = d.facetedge.edge, ee = e.facetedge.edge, fe = f.facetedge.edge DO de.exists := TRUE; ee.exists := TRUE; fe.exists := TRUE; de.color := co; de.radius := ra; ee.color := co; ee.radius := ra; fe.color := co; fe.radius := ra; END END; (* Make the first link facetedge *) SetEnext(hc, d); SetEnext(d, Clock(hbc)); SetEnext(Clock(hc), hbc); (* updating origins *) SetOrg(d, Org(Clock(hc))); SetOrg(Clock(d), Org(Clock(hbc))); (* updating component face *) SetFace(hc, d.facetedge.face); SetFace(hbc, d.facetedge.face); d.facetedge.face.exists := top.face[j].exists; d.facetedge.face.color := top.face[j].color; d.facetedge.face.transp := top.face[j].transp; (* Make the second link facetedge *) SetEnext(ha, e); SetEnext(e, Clock(hcc)); SetEnext(Clock(ha), hcc); (* updating origins *) SetOrg(e, Org(Clock(ha))); SetOrg(Clock(e), Org(Clock(hcc))); (* updating component face *) SetFace(ha, e.facetedge.face); SetFace(hcc, e.facetedge.face); e.facetedge.face.exists := top.face[j].exists; e.facetedge.face.color := top.face[j].color; e.facetedge.face.transp := top.face[j].transp; (* Make the third link facetedge *) SetEnext(hac, f); SetEnext(f, Clock(hb)); SetEnext(Clock(hac), hb); (* updating origins *) SetOrg(f, Org(Clock(hac))); SetOrg(Clock(f), Org(Clock(hb))); (* updating component facet *) SetFace(hac, f.facetedge.face); SetFace(hb, f.facetedge.face); f.facetedge.face.exists := top.face[j].exists; f.facetedge.face.color := top.face[j].color; f.facetedge.face.transp := top.face[j].transp; (* Creating Triangular face to insert *) IF top.face[j].exists THEN g := MakeTriangle(TRUE); ELSE g := MakeTriangle(FALSE); END; (* making the connections *) SetFnext(Enext(hc), Clock(g)); SetFnext(Enext(hbc), g); SetFnext(Enext(g), Enext(hcc)); SetFnext(Clock(Enext(g)), Clock(Enext(hcc))); SetFnext(Clock(Enext(hb)), Enext_1(g)); SetFnext(Clock(Enext(hac)),Clock(Enext_1(g))); (* updating the edge component *) SetEdgeAll(g ,d.facetedge.edge); SetEdgeAll(Enext(g) ,e.facetedge.edge); SetEdgeAll(Enext_1(g) ,f.facetedge.edge); (* updating origins *) SetOrg(g, Org(Clock(d))); SetOrg(Clock(g), Org(d)); SetOrg(Enext(g), Org(Clock(e))); SetOrg(Clock(Enext(g)), Org(e)); SetOrg(Enext_1(g), Org(f)); SetOrg(Clock(Enext_1(g)), Org(Clock(f))); g.facetedge.face.color := top.face[j].color; g.facetedge.face.transp := top.face[j].transp; (* set the "root" face *) d.facetedge.face.root := fr; e.facetedge.face.root := fr; f.facetedge.face.root := fr; g.facetedge.face.root := fr; (* end of the setting *) END END END; FOR i := 0 TO top.NFE-1 DO WITH a = top.facetedge[i], ha = Half(a), hac = Half(Clock(a)) DO SetEdgeAll(ha, ha.facetedge.edge); SetEdgeAll(hac, hac.facetedge.edge); END; END; FOR i := 0 TO top.NP-1 DO WITH v = top.region[i], a = Tors(v), af = Fnext_1(a), ae = Enext_1(a), aee = Enext(a) DO <* ASSERT Pneg(a).num = i *> <* ASSERT Org(v).num = i *> IF Ppos(af) # NIL THEN <* ASSERT Pneg(a) = Ppos (af) *> END; IF NUMBER(Pneg(a).vertex^) # 4 THEN BadElement() END; gi[i,0] := Clock(Enext(Fnext_1(Enext(Half(a))))); gi[i,1] := Clock(Enext(Fnext(Enext(Half(af))))); gi[i,2] := Clock(Enext(Fnext(Enext(Half(Fnext_1(ae)))))); gi[i,3] := Fnext(Enext(Half(Fnext_1(aee)))); END END; FOR i := 0 TO top.NP-1 DO RefineCell(RowT{gi[i,0],gi[i,1],gi[i,2],gi[i,3]},i); END; IF top.bdr = 0 THEN ntop := Triangulation.MakeTopology(Half(top.facetedge[1]),0); ELSE ntop := Triangulation.MakeTopology(Half(top.facetedge[1]),1); END; WITH nc = NEW(REF Coords, ntop.NV)^, com = "Refined from: " & o.inFileTp & ".tp\n" & "Created by RefineTriang: " & o.outFile & ".tp" DO <* ASSERT ntop.NV = top.NV + top.NE + top.NP *> <* ASSERT ntop.NE = 2*top.NE + 3*top.NF + 6*top.NP*> <* ASSERT ntop.NF = 4*top.NF + 16*top.NP *> <* ASSERT ntop.NP = 12*top.NP *> IF top.bdr = 0 THEN <* ASSERT ntop.NFE = 72*top.NP *> END; FOR j := 0 TO top.NFE-1 DO WITH a = top.facetedge[j], ou = OrgV(a).num, ov = OrgV(Clock(a)).num, nu = OrgV(Half(a)).num, nv = OrgV(Half(Clock(a))).num, nx = OrgV(Clock(Half(a))).num, ny = OrgV(Clock(Half(Clock(a)))).num DO <* ASSERT nx = ny *> nc[nu] := c[ou]; nc[nv] := c[ov]; nc[nx] := LR4.Scale(0.5d0, LR4.Add(c[ou], c[ov])); END END; IF o.net THEN (* we compute the number of existing faces in the previus topology. *) VAR nefp: CARDINAL := 0; (* existing faces in the previus topology*) neep: CARDINAL := 0; (* existing edges in the previus topology*) neea: CARDINAL := 0; (* existing edges in the actual topology*) BEGIN FOR i := 0 TO top.NF-1 DO WITH f = top.face[i] DO IF f.exists THEN INC(nefp) END END END; FOR i := 0 TO top.NE-1 DO WITH e = top.edge[i] DO IF e.exists THEN INC(neep) END; END END; FOR i := 0 TO ntop.NE-1 DO WITH e = ntop.edge[i] DO IF e.exists THEN INC(neea) END END END; <* ASSERT neea = 3 * nefp + 2 * neep *> END END; FOR i := 0 TO top.NP-1 DO WITH ou = OrgV(gi[i,1]).num, ov = OrgV(Enext_1(gi[i,2])).num DO nc[x[i].num] := LR4.Scale(0.5d0, LR4.Add(nc[ou], nc[ov])); END END; Triangulation.WriteTopology (o.outFile, ntop, com); Triangulation.WriteTable (o.outFile, ntop, com); Triangulation.WriteState (o.outFile, ntop, nc, com); Triangulation.WriteMaterials(o.outFile, ntop, com, FALSE); (* Now, unmark the attribute "mark" of FacetEdge *) FOR i:= 0 TO top.NFE-1 DO WITH fe = NARROW(top.facetedge[i].facetedge, FacetEdge) DO IF fe.mark THEN fe.mark := FALSE; END; END END END END END END DoIt; PROCEDURE BadElement() = BEGIN Wr.PutText(stderr,"This topology isn't a triangulation\n"); Process.Exit(1); END BadElement; PROCEDURE SubdivideEdge(an : Pair; i: INTEGER; net: BOOLEAN) = VAR a,bn,m1,m2,m3,t0,t1,t2: REF ARRAY OF Pair; wn, p: REF ARRAY OF Node; CONST n = 4; BEGIN a := NEW(REF ARRAY OF Pair,n); bn := NEW(REF ARRAY OF Pair,n); m1 := NEW(REF ARRAY OF Pair,n); m2 := NEW(REF ARRAY OF Pair,n); m3 := NEW(REF ARRAY OF Pair,n); t0 := NEW(REF ARRAY OF Pair,n); t1 := NEW(REF ARRAY OF Pair,n); t2 := NEW(REF ARRAY OF Pair,n); (* save the pairs *) a := NEW(REF ARRAY OF Pair,n); a[0] := an; FOR i := 1 TO n-1 DO a[i] := Fnext(a[i-1]); END; (* save the vertices *) wn := NEW(REF ARRAY OF Node,n); FOR i := 0 TO n-1 DO wn[i] := Org(Enext_1(a[i])); END; (* save the polyhedra *) p := NEW(REF ARRAY OF Node,n); FOR i := 0 TO n-1 DO p[i] := Pneg(a[i]); END; (* save other pairs *) bn := NEW(REF ARRAY OF Pair,n); FOR i := 0 TO n-1 DO bn[i] := Clock(Enext_1(Fnext(Enext_1(a[i])))); END; (* insert facetedges and edges *) FOR i := 0 TO n-1 DO m1[i] := MakeFacetEdge(); m2[i] := MakeFacetEdge(); m3[i] := MakeFacetEdge(); t0[i] := MakeTriangle(FALSE); t1[i] := Enext(t0[i]); t2[i] := Enext(t1[i]); (* If net=TRUE the simulates the net with cylinders ans spheres, *) IF net AND bn[i].facetedge.edge.exists THEN t0[i].facetedge.edge.exists := TRUE; t0[i].facetedge.edge.radius := 0.0025; t0[i].facetedge.edge.color := R3.T{1.0,1.0,0.5}; END; WITH f = t0[i].facetedge.face, e1 = t1[i].facetedge.edge, e2 = t2[i].facetedge.edge DO f.exists := FALSE; e1.exists := FALSE; e2.exists := FALSE; END END; (* Now subdivide edge and extend the subdivision on the star of the edge *) x[i] := MakeVertex(); WITH v = NARROW(x[i], Vertex) DO v.exists := FALSE; v.label := "VE"; END; FOR j := 0 TO n-1 DO WITH ee = a[j].facetedge.edge, ff = m2[j].facetedge.edge, b = Enext(a[j]), be = b.facetedge.edge, c = Enext(b), ce = c.facetedge.edge, u = Org(a[j]), v = Org(b), w = Org(c), (* save the attributes of the edge-face component of the pair a[j] *) f = a[j].facetedge.face, g = m3[j].facetedge.face, ge = g.exists, h = m3[j].facetedge.edge DO ee.exists := FALSE; ff.exists := FALSE; SetEnext(a[j],m1[j]); SetEnext(m1[j],c); SetEnext(m2[j],m3[j]); SetEnext(m3[j],Clock(b)); SetOrg(a[j], u); SetOrg(Clock(a[j]), x[i]); SetOrg(m2[j],v); SetOrg(Clock(m2[j]), x[i]); SetOrg(m3[j], x[i]); SetOrg(Clock(m3[j]), w); SetOrg(m1[j], x[i]); SetOrg(Clock(m1[j]), w); SetFnext(m1[j],m3[j]); (* set the attributes for the face component *) ge := FALSE; SetFaceAll(a[j],f); SetFaceAll(m3[j],g); SetEdgeAll(m3[j],h); SetEdgeAll(b,be); SetEdgeAll(c,ce); SetEdgeAll(a[j],ee); SetEdgeAll(m2[j],ff); SetFaceAll(bn[j],bn[j].facetedge.face); SetFaceAll(Fnext_1(bn[j]),Fnext_1(bn[j]).facetedge.face); END END; FOR j := 0 TO n-1 DO SetFnext(Clock(m2[j]),Clock(m2[(j+1) MOD n])); END; WITH ff = m2[0].facetedge.edge DO SetEdgeAll(m2[0],ff); END; FOR j := 0 TO n-1 DO WITH cn = Fnext(bn[j]), e0 = t0[j].facetedge.edge, e1 = t1[j].facetedge.edge, e2 = t2[j].facetedge.edge DO SetAllOrgs(t0[j],wn[j]); SetAllOrgs(t1[j],wn[(j+1) MOD n]); SetAllOrgs(t2[j],x[i]); SetFnext(bn[j], t0[j]); SetFnext(t0[j],cn); SetFnext(m1[j],t2[j]); SetFnext(t2[j],m3[j]); SetFnext(Clock(m1[(j+1) MOD n]), t1[j]); SetFnext(t1[j],Clock(m3[(j+1) MOD n])); SetEdgeAll(t0[j],e0); SetEdgeAll(t1[j],e1); SetEdgeAll(t2[j],e2); SetEdgeAll(Enext(t0[j]),Enext(t0[j]).facetedge.edge); SetEdgeAll(Enext(t1[j]),Enext(t1[j]).facetedge.edge); SetEdgeAll(Enext(t2[j]),Enext(t2[j]).facetedge.edge); END; END; (* insert polyhedra *) FOR j := 0 TO n-1 DO WITH q = Triangulation.MakePolyhedron() DO Triangulation.SetAllPneg(a[j],p[j]); Triangulation.SetAllPneg(m2[j],q); END END; END SubdivideEdge; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFileTp"); o.inFileTp := pp.getNext(); pp.getKeyword("-inFileSt"); o.inFileSt := pp.getNext(); pp.getKeyword("-outFile"); o.outFile := pp.getNext(); o.fixOri := pp.keywordPresent("-fixOri"); o.net := pp.keywordPresent("-net"); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: RefineTriang \\\n"); Wr.PutText(stderr, " -inFileTp \\\n"); Wr.PutText(stderr, " -inFileSt \\\n"); Wr.PutText(stderr, " -outFile \\\n"); Wr.PutText(stderr, " [ -fixOri ] [-assert] [-net]\n"); Process.Exit (1); END END; RETURN o END GetOptions; PROCEDURE MakeTriangle(exists: BOOLEAN) : Pair = (* Make one triangular face and set of the three pairs facetedges with the same face component. If exists is TRUE then the triangular face exists, FALSE otherwise. *) BEGIN WITH a = MakeFacetEdge(), b = MakeFacetEdge(), c = MakeFacetEdge(), f = a.facetedge.face, u = MakeVertex(), v = MakeVertex(), w = MakeVertex() DO IF exists THEN f.exists := TRUE ELSE f.exists := FALSE END; a.facetedge.edge.exists := ThinEdgeExists; SetOrg(a, u); SetOrg(Clock(a),v); b.facetedge.edge.exists := ThinEdgeExists; SetEnext(a,b); SetFace (b,f); SetOrg (b,v); SetOrg(Clock(b),w); c.facetedge.edge.exists := ThinEdgeExists; SetEnext(b,c); SetFace (c,f); SetOrg (c, w); SetOrg(Clock(c), Org(a)); RETURN a END END MakeTriangle; BEGIN DoIt() END RefineTriang. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/MakeAdjacencyMatrix.m3 MODULE MakeAdjacencyMatrix EXPORTS Main; (* This program implements the ShortestPath Algorithm from R. Floyd on Communications of the ACM, Volume 5, Number 6, June, 1962, pag 345 Algorithm 97 SHORTEST PATH Robert W. Floyd Procedure --------- shortest path(m,n); value n; integer n; array m; Comments -------- Initially m[i,j] is the length of a direct link from point i of a network to point j. If no direct link exists, m[i,j] is initially 10^{10}. At completion, m[i,j] is the length of the shortest path from i to j. If nome exists, m[i,j] is 10^{10}. begin integer i,j,k; real inf,s; inf := 10^{10}; for i:= 1 step 1 until n do for j:= 1 step 1 until n do if m[j,i] < inf then for k:= 1 step 1 until n do if m[i,k] < inf then begin s:= m[j,i] + m[i,k]; if s < m[j,k] then m[j,k] := s end end shortest path Created by L. P. Lozada (see the copyright and authorship futher down). Last modification: 02-11-99 *) IMPORT Triangulation, Stdio, Wr, Thread, Process, ParseParams, Fmt, Math; FROM Stdio IMPORT stderr; TYPE Options = RECORD inFile: TEXT; (* Initial guess file name (minus ".top") *) END; AdjacencyMatrix = ARRAY OF ARRAY OF LONGREAL; VAR inf : LONGREAL := Math.pow(10.0d0,10.0d0); PROCEDURE DoIt() = <* FATAL Wr.Failure, Thread.Alerted *> VAR max : LONGREAL; m : REF AdjacencyMatrix; BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToMa(o.inFile), top = tc.top DO m := MakeAdjacencyMatrix(top); Wr.PutText(stderr, "\nInput of the ShortestPath Algorithm: " & o.inFile & ".tp\n"); PrintHalfMatrix(m,top.NV); ShortestPath(m,top.NV); Wr.PutText(stderr, "\nOutput of the ShortestPath Algorithm\n" & "\n"); PrintHalfMatrix(m,top.NV); max := FindMaxDistance(m,top.NV); Wr.PutText(stderr, "\nMax Distance: " & Fmt.LongReal(max) & "\n"); END END DoIt; PROCEDURE MakeAdjacencyMatrix( READONLY top : Triangulation.Topology; ) : REF AdjacencyMatrix = VAR m: REF ARRAY OF ARRAY OF LONGREAL; v: REF ARRAY OF INTEGER; BEGIN m := NEW(REF ARRAY OF ARRAY OF LONGREAL, top.NV, top.NV); FOR i := 0 TO top.NV-1 DO FOR j := 0 TO top.NV-1 DO m[i,j] := inf; END END; FOR i := 0 TO top.NV-1 DO WITH a = top.out[i], star = Triangulation.Neighbors(a,top), nv = Triangulation.NumberNeighborVertex(star) DO m[i,i] := 0.0d0; v := NEW(REF ARRAY OF INTEGER, nv); FOR k := 0 TO nv-1 DO v[k] := star[k].num; m[i,v[k]] := 1.0d0; m[v[k],i] := 1.0d0; END END END; RETURN m; END MakeAdjacencyMatrix; <* UNUSED *> PROCEDURE PrintAdjacencyMatrix(READONLY m : REF AdjacencyMatrix; n: INTEGER) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN FOR i := 0 TO n-1 DO FOR j := 0 TO n-1 DO IF m[i,j] = inf THEN Wr.PutText(stderr, "# "); ELSE Wr.PutText(stderr, Fmt.LongReal(m[i,j]) & " "); END END; Wr.PutText(stderr, "\n"); END; END PrintAdjacencyMatrix; PROCEDURE PrintHalfMatrix(READONLY m : REF AdjacencyMatrix; n: INTEGER) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN FOR i := 0 TO n-1 DO FOR j := 0 TO i DO IF m[i,j] = inf THEN Wr.PutText(stderr, "# "); ELSE Wr.PutText(stderr, Fmt.LongReal(m[i,j]) & " "); END END; Wr.PutText(stderr, "\n"); END; END PrintHalfMatrix; PROCEDURE FindMaxDistance( READONLY m : REF AdjacencyMatrix; n: INTEGER; ) : LONGREAL = VAR max := 0.0d0; BEGIN FOR i := 0 TO n-1 DO FOR j := 0 TO i DO IF m[i,j] > max THEN max := m[i,j]; END END END; RETURN max; END FindMaxDistance; PROCEDURE ShortestPath(VAR m : REF AdjacencyMatrix; n : INTEGER) = VAR s : LONGREAL; BEGIN FOR i := 0 TO n-1 DO FOR j := 0 TO n-1 DO IF m[i,j] < inf THEN FOR k := 0 TO n-1 DO IF m[i,k] < inf THEN s := m[j,i] + m[i,k]; IF s < m[j,k] THEN m[j,k] := s END; END END END END END END ShortestPath; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFile"); o.inFile := pp.getNext(); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: MakeAdjacencyMatrix" ); Wr.PutText(stderr, " -inFile \n" ); Process.Exit (1); END; END; RETURN o END GetOptions; BEGIN DoIt() END MakeAdjacencyMatrix. (**************************************************************************) (* *) (* Copyright (C) 1999 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/MakeBigCubeFixed.m3 MODULE MakeBigCubeFixed EXPORTS Main; (* Made a tridimensional array of cubic cells with fixed geometry. *) IMPORT LR4, Octf, Triangulation, Stdio, Wr, Thread, Fmt, ParseParams, Process, Squared; FROM Octf IMPORT Enext_1, Clock, Fnext, Enext, Fnext_1; FROM Squared IMPORT SetCubeProperties; FROM Triangulation IMPORT Pair, Coords, OrgV, Topology; FROM Stdio IMPORT stderr; TYPE Options = RECORD gridOrder: CARDINAL; (* order of the grid. *) original: BOOLEAN; (* emphazise the original elements on a cube. *) END; PAIRS = ARRAY[0..3] OF Pair; TriPair = ARRAY OF ARRAY OF ARRAY [0..1] OF Pair; PROCEDURE MakeBigRawCube(order: CARDINAL; original: BOOLEAN) : Pair = (* Builds one tridimensional array of cubic cells with fixed geometry. IF "original=TRUE" then the procedure emphasize the original elements on a cube. *) VAR cd : REF ARRAY OF ARRAY OF ARRAY OF PAIRS; a : REF TriPair; name: TEXT; BEGIN cd := NEW(REF ARRAY OF ARRAY OF ARRAY OF PAIRS, order, order,order); a := NEW(REF TriPair, order,order); FOR i := 0 TO order-1 DO WITH cc = Squared.MakeColumnCube(order) DO FOR j := 0 TO order-1 DO FOR k := 0 TO order-1 DO FOR l := 0 TO 1 DO cd[i,j,k,l] := cc[j,k,l]; END END END END END; IF original THEN (* Selecting the pairs for emphasize *) FOR j := 0 TO order-1 DO FOR k := 0 TO order-1 DO a[j,k,0] := cd[0,k,j,0]; a[j,k,1] := cd[order-1,k,j,1]; END END; END; (* gluing *) FOR i := 0 TO order-2 DO FOR k := 0 TO order-1 DO FOR j := 0 TO order-1 DO EVAL Squared.GlueCube(cd[i,k,j,1],Clock(cd[i+1,k,j,0])); END END END; (* Fix the coordinates *) WITH top = Triangulation.MakeTopology(cd[0,0,0,0]), r = NEW(REF Coords, top.NV), c = r^, zero = 0.0d0, uno = 1.0d0, comments = " " DO name := "Bigcube-" & Fmt.Int(order); PROCEDURE SetCorner(e: Pair; i: CARDINAL) = BEGIN WITH ii = FLOAT(i,LONGREAL), cv = LR4.T{ii,zero,zero,zero} DO c[OrgV(e).num] := cv; END; END SetCorner; PROCEDURE SetCorner1(e: Pair; o: LR4.T) = BEGIN c[OrgV(e).num] := LR4.T{o[0], o[1]+uno, o[2], o[3]}; END SetCorner1; PROCEDURE SetCorner2(e: Pair; o: LR4.T) = BEGIN c[OrgV(e).num] := LR4.T{o[0], o[1], o[2]+uno, o[3]}; END SetCorner2; PROCEDURE SetCorner3(e: Pair; o: LR4.T) = BEGIN c[OrgV(e).num] := LR4.T{o[0], o[1]-uno, o[2], o[3]}; END SetCorner3; VAR p : Pair; BEGIN FOR i := 0 TO order-1 DO SetCorner(Clock(Enext(cd[i,0,0,0])),i); FOR j := 0 TO order-1 DO p := Clock(Enext(cd[i,j,0,0])); FOR k := 0 TO order-1 DO SetCorner1(Enext(p),c[OrgV(p).num]); SetCorner2(Enext(Enext(p)),c[OrgV(Enext(p)).num]); SetCorner3(Enext(Enext(Enext(p))),c[OrgV(Enext(Enext(p))).num]); p := Enext(Fnext_1(Fnext_1(cd[i,j,k,0]))); END END END; (* finally *) SetCorner(Enext_1(cd[order-1,0,0,1]),order); FOR j := 0 TO order-1 DO p := Enext_1(cd[order-1,j,0,1]); FOR k := 0 TO order-1 DO SetCorner1(Enext(p),c[OrgV(p).num]); SetCorner2(Enext(Enext(p)),c[OrgV(Enext(p)).num]); SetCorner3(Enext(Enext(Enext(p))),c[OrgV(Enext(Enext(p))).num]); p := Clock(Enext_1(Fnext(cd[order-1,j,k,1]))); END END; IF original THEN (* Set all elements (vertices, edges, faces, as non-existing *) FOR i := 0 TO top.NF-1 DO WITH f = top.face[i] DO f.exists := FALSE; END END; FOR i := 0 TO top.NE-1 DO WITH e = top.edge[i] DO e.exists := FALSE; END END; FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i] DO v.exists := FALSE; END END; (* Now emphasize the original elements (vertices,edges,faces) *) SetCubeProperties(a, order, top); name := name; END; (* set the root elements *) FOR i := 0 TO top.NF-1 DO WITH f = top.face[i] DO f.root := f.num; END END; FOR i := 0 TO top.NE-1 DO WITH e = top.edge[i] DO e.root := e.num; END END; Triangulation.WriteTopology(name,top); Triangulation.WriteState(name, top, c, comments); Triangulation.WriteMaterials(name, top, comments); RETURN cd[0,0,0,0]; END END; END MakeBigRawCube; <* UNUSED *> PROCEDURE FixCoordsCube( READONLY ca: ARRAY[0..5] OF Pair; READONLY ct: Topology; ): REF Coords = (* Build one cubic array with fixed geometry. *) BEGIN WITH r = NEW(REF Coords, ct.NV), c = r^, o1 = LR4.T{ 1.0d0, 1.0d0, 1.0d0,1.0d0}, (* the vertex ( 1, 1, 1,1) *) o2 = LR4.T{ 1.0d0, 1.0d0,-1.0d0,1.0d0}, (* the vertex ( 1, 1,-1,1) *) o3 = LR4.T{ 1.0d0,-1.0d0, 1.0d0,1.0d0}, (* the vertex ( 1,-1, 1,1) *) o4 = LR4.T{ 1.0d0,-1.0d0,-1.0d0,1.0d0}, (* the vertex ( 1,-1,-1,1) *) o5 = LR4.T{-1.0d0, 1.0d0, 1.0d0,1.0d0}, (* the vertex (-1, 1, 1,1) *) o6 = LR4.T{-1.0d0, 1.0d0,-1.0d0,1.0d0}, (* the vertex (-1, 1,-1,1) *) o7 = LR4.T{-1.0d0,-1.0d0, 1.0d0,1.0d0}, (* the vertex (-1,-1, 1,1) *) o8 = LR4.T{-1.0d0,-1.0d0,-1.0d0,1.0d0} (* the vertex (-1,-1,-1,1) *) DO PROCEDURE SetCornerCoords(e: Pair; cv: LR4.T) = BEGIN c[OrgV(e).num] := cv; END SetCornerCoords; BEGIN (* Set the corners *) SetCornerCoords(ca[5],o1); SetCornerCoords(ca[1],o2); SetCornerCoords(Clock(ca[4]),o3); SetCornerCoords(ca[4],o4); SetCornerCoords(Clock(ca[5]),o5); SetCornerCoords(ca[2],o6); SetCornerCoords(Clock(ca[3]),o7); SetCornerCoords(ca[3],o8); END; RETURN r END END FixCoordsCube; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-gridOrder"); o.gridOrder := pp.getNextInt(1,10); o.original := pp.keywordPresent("-original"); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: MakeRawCube -gridOrder \\\n"); Wr.PutText(stderr, " [ -original] \n"); Process.Exit (1); END END; RETURN o END GetOptions; PROCEDURE Main() = VAR a: Pair; BEGIN WITH o = GetOptions() DO a := MakeBigRawCube(o.gridOrder, o.original); END; END Main; BEGIN Main(); END MakeBigCubeFixed. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/MakeBipyramid.m3 MODULE MakeBipyramid EXPORTS Main; (* Generates ".tp",".tb",".ma" and ".st" files for some simples 3D polyhedrons called `bipyramids'. The vertex coordinates are random numbers in [-1..+1] or computed with fixed geometry ("-fixed") option. If the "-open" flag is given, the last tetrahedron is not glued to the first one. See the copyright and authorship futher down. Revisions: 20-05-2000: Emphasize the original elements for drawing purposes. 13-09-2000: Added the option "pyramid" for the generation of bipyramids with geometry of pyramids. *) IMPORT ParseParams, Octf, Triangulation, Wr, Stdio, Thread, Process, Mis, Fmt, Math, LR4; FROM Octf IMPORT Spin, Enext_1, Clock, Fnext, Enext; FROM Triangulation IMPORT MakeTetraTopo, Glue, Pair, Coords, Topology, OrgV, Face, Edge, Vertex, Org; FROM Stdio IMPORT stderr; FROM Wr IMPORT PutText; TYPE Options = RECORD output : TEXT; order : CARDINAL; open : BOOLEAN; elong : BOOLEAN; fixed : BOOLEAN; pyramid: BOOLEAN; (* Attribute the geometry of a pyramid. *) END; PROCEDURE DoIt() = <* FATAL Wr.Failure, Thread.Alerted *> VAR c: REF Coords; flag: TEXT; BEGIN WITH o = GetOptions(), m = BuildBipyramid(o), t = Triangulation.MakeTopology(m) DO (* setting the "root" attribute for faces and edges. *) FOR i := 0 TO t.NF-1 DO WITH f = t.face[i] DO f.root := f.num; END END; FOR i := 0 TO t.NE-1 DO WITH e = t.edge[i] DO e.root := e.num; END END; c := NEW(REF Coords, t.NV); IF NOT o.fixed THEN c := Triangulation.GenCoords(t); flag := "-ran"; Triangulation.WriteTopology( o.output & flag,t,"Created by MakeBipyramid: " & o.output & "-ran.tp on " & Mis.Today() ); Triangulation.WriteState( o.output & flag,t,c^,"Created by MakeBipyramid:" & o.output & "-ran.st on " & Mis.Today() & "\nRandom Geometry"); Triangulation.WriteMaterials( o.output & flag,t,"Created by MakeBipyramid: " & o.output & "-ran.ma on " & Mis.Today() ); ELSE IF o.open THEN Wr.PutText(stderr,"\nThe fixed coordinates is only for bipyramids\n"); <* ASSERT NOT o.open *> ELSE c := FixCoordsBipyramid(m,o,t); flag := "-fix"; Triangulation.WriteTopology( o.output & flag,t,"Created by MakeBipyramid: " & o.output & "-fix.tp on " & Mis.Today() ); Triangulation.WriteState( o.output & flag,t,c^,"Created by MakeBipyramid:" & o.output & "-fix.st on " & Mis.Today() ); Triangulation.WriteMaterials( o.output & flag,t,"Created by MakeBipyramid: " & o.output & "-fix.ma on " & Mis.Today() ); END END END END DoIt; PROCEDURE SetRingFace(a: Pair; faceExists: BOOLEAN) = (* Set the face as non existing. *) PROCEDURE SetFace(b: Pair) = BEGIN WITH t = NARROW(b.facetedge.face, Face) DO t.exists := faceExists; END END SetFace; VAR an: Pair := a; BEGIN REPEAT SetFace(an); an := Fnext(an) UNTIL an = a END SetRingFace; PROCEDURE SetEdge(a: Pair; edgeExists: BOOLEAN) = (* Set the edge as non existing. *) BEGIN WITH e = NARROW(a.facetedge.edge, Edge) DO e.exists := edgeExists; END END SetEdge; PROCEDURE SetGhostVertex(a: Pair) = (* Set the vertex as non existing. *) BEGIN WITH v = NARROW(Org(a), Vertex) DO v.exists := FALSE; END END SetGhostVertex; PROCEDURE BuildBipyramid(READONLY o : Options): Pair = <* FATAL Wr.Failure, Thread.Alerted *> VAR a : ARRAY [0..51] OF ARRAY [0..7] OF Pair; b : Pair; BEGIN IF NOT o.elong THEN (* creating the tetrahedra *) FOR i := 0 TO o.order-1 DO a[i] := MakeTetraTopo(1,1); END; (* glueing *) FOR i := 0 TO o.order-2 DO EVAL Glue(Spin(a[i,1]),a[(i+1) MOD o.order,0],1); END; IF NOT o.open THEN EVAL Glue(Spin(a[o.order-1,1]),a[0,0],1); (* Emphasize the original elements *) SetRingFace(a[0][1],FALSE); SetEdge(a[0][1],FALSE); PutText(stderr,"Building a topology of Bipyramid-" & Fmt.Int(o.order) & "\n"); ELSE PutText(stderr,"Building a topology of Openring-"&Fmt.Int(o.order)& "\n"); END; b := a[0,1]; ELSIF o.elong THEN PutText(stderr,"Building a topology of Elongated Bipyramid-" & Fmt.Int(o.order)&"\n"); b := MakeElongated(o.order); END; RETURN b; END BuildBipyramid; PROCEDURE MakeElongated(n: CARDINAL) : Pair = (* Builds an elongated bipyramid. The icosahedron is obtain with n=5 *) <* FATAL Thread.Alerted, Wr.Failure *> VAR a: REF ARRAY OF ARRAY[0..7] OF Pair; BEGIN IF n < 3 THEN Wr.PutText(stderr, "The order for elongated Bipyramid " & "should be greater than two\n"); <* ASSERT n > 2 *> END; a := NEW(REF ARRAY OF ARRAY[0..7] OF Pair, 4*n); FOR i := 0 TO 4*n-1 DO a[i] := MakeTetraTopo(1,1); END; (* first level *) FOR i := 0 TO n-1 DO EVAL Glue(Spin(a[(i+1) MOD n][1]),a[i][0],1); END; (* next level *) FOR i := 0 TO n-1 DO EVAL Glue(Spin(a[i][3]),a[i+n][2],1); END; FOR i := n TO 2*n-1 DO EVAL Glue(Clock(Enext_1(a[i][0])), a[i+n][0], 1); IF i = 2*n-1 THEN EVAL Glue( Clock(Enext_1(a[n][1])), a[n+i][1], 1); ELSE EVAL Glue( Clock(Enext_1(a[(i+1)][1])), a[n+i][1],1); END; END; (* Last level *) FOR i := 2*n TO 3*n-1 DO EVAL Glue(Spin(a[i][2]),a[i+n][7],1); END; FOR i := 3*n TO 4*n-1 DO IF i = 4*n-1 THEN EVAL Glue(Spin(a[3*n][1]),a[i][0],1); ELSE EVAL Glue(Spin(a[(i+1)][1]),a[i][0],1); END END; (* Emphasize the original elements *) SetRingFace(a[0][1],FALSE); SetEdge(a[0][1],FALSE); SetRingFace(a[2*n-1][1],FALSE); SetEdge(a[4*n-1][1],FALSE); SetGhostVertex(a[2*n-1][1]); FOR i := 0 TO n-1 DO SetRingFace(Enext(a[i][1]),FALSE); END; FOR i := n TO 2*n-1 DO SetEdge(Enext_1(a[i][1]),FALSE); END; FOR i := 3*n TO 4*n-1 DO SetRingFace(Enext_1(a[i][1]),FALSE); SetEdge(Enext_1(a[i][1]),FALSE); END; RETURN a[0][1]; END MakeElongated; PROCEDURE FixCoordsBipyramid( a: Pair; READONLY o : Options; READONLY top: Topology; ): REF Coords = VAR theta: LONGREAL := 0.0d0; y : LONGREAL; BEGIN (* first, we compute the coordinates on a circle of radius one*) WITH count = 360 DIV o.order, r = NEW(REF Coords, top.NV), c = r^ DO PROCEDURE SetCoords(e: Pair; cv: LR4.T) = (* set the coordinates of the vertex OrgV(e). *) BEGIN c[OrgV(e).num] := cv; END SetCoords; VAR an: Pair := a; BEGIN FOR i := 0 TO o.order-1 DO theta := FLOAT(count,LONGREAL) + theta; WITH rad = FLOAT((theta * FLOAT(Math.Pi,LONGREAL))/180.0d0,LONGREAL), x = Math.cos(rad), x2 = FLOAT(x * x,LONGREAL) DO IF rad > FLOAT(Math.Pi,LONGREAL) THEN y := Math.sqrt(1.0d0-x2); ELSE y := -Math.sqrt(1.0d0-x2); END; SetCoords(Enext_1(an), LR4.T{x,y,0.0d0,1.0d0}); an := Fnext(an); END END; (* set the coordinates of the axis edge in the bipyramid. *) IF o.pyramid THEN SetCoords(a, LR4.T{0.0d0,0.0d0,0.0d0,1.0d0}); ELSE SetCoords(a, LR4.T{0.0d0,0.0d0,-1.0d0,1.0d0}); END; SetCoords(Clock(a), LR4.T{0.0d0,0.0d0, 1.0d0,1.0d0}); RETURN r END END END FixCoordsBipyramid; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-output"); o.output := pp.getNext(); pp.getKeyword("-order"); o.order := pp.getNextInt(2,51); o.open := pp.keywordPresent("-open"); o.fixed := pp.keywordPresent("-fixed"); o.pyramid := pp.keywordPresent("-pyramid"); o.elong := pp.keywordPresent("-elong"); pp.finish(); EXCEPT | ParseParams.Error => PutText(stderr, "Usage: MakeBipyramid \\\n"); PutText(stderr, " -output NAME \\\n"); PutText(stderr, " -order NUM [ -open ] [ -fixed [-pyramid] ]" & " [ -elong ]\n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt(); END MakeBipyramid. (**************************************************************************) (* *) (* Copyright (C) 1999 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/MakeComplex.m3 MODULE MakeComplex EXPORTS Main; (* This program generates ".tp",".tb",".st" and ".ma" files for some simples tridimensional maps homeomorphics to three-manifolds. The vertex coordinates are random numbers in [-1..+1]. The maps builds through the "MakeComplex" program results in dege- neracies. So, is necessary submit these resulting maps to aditional procedures for remove such degeneracies, such as the "BarySubdivision" and "SelectSubdivision" procedures. Revisions: 28-09-2000: Added the 3D maps "Dodecahedral Seifert-Weber and Poincare Space". This maps have topology of closed 3D manifolds and aren't homemorphic to the hypersphere S^{3}. *) IMPORT ParseParams, Text, Octf, Triangulation, Wr, Stdio, Thread, Process, Mis, Squared; FROM Octf IMPORT Spin, Clock, Enext_1, Fnext, Fnext_1, Enext; FROM Stdio IMPORT stderr; FROM Triangulation IMPORT Pair, MakeTetraTopo, Glue, Org, Vertex; FROM Squared IMPORT MakeBall, GlueBall, MakeBigCube, GlueBigCube; CONST Order = 1; TYPE Shape = { Sphere, Cm2t, Torus, Pseudo, Seifert, Poincare, Lens1, Lens2, Lens3, Lens4, Lens5 }; Options = RECORD shape: Shape; shapeName: TEXT; END; Penta = ARRAY [0..4] OF ARRAY [0..1] OF Pair; Free = ARRAY [0..4] OF Pair; PROCEDURE DoIt() = BEGIN WITH o = GetOptions(), m = MakeMap(o.shape), t = Triangulation.MakeTopology(m,0), c = Triangulation.GenCoords(t)^ DO (* setting the root elements for edges and faces *) FOR i := 0 TO t.NF-1 DO WITH f = t.face[i] DO f.root := f.num; END END; FOR i := 0 TO t.NE-1 DO WITH e = t.edge[i] DO e.root := e.num; END END; Triangulation.WriteTopology( o.shapeName, t, "Created by MakeComplex: " & o.shapeName & ".tp on " & Mis.Today() ); Triangulation.WriteTable( o.shapeName, t, "Created by MakeComplex: " & o.shapeName & ".st on " & Mis.Today() ); Triangulation.WriteState( o.shapeName, t, c, "Created by MakeComplex: " & o.shapeName & ".st on " & Mis.Today() & "\nRandom Geometry"); (*Triangulation.FindDegeneracies(t);*) Triangulation.WriteMaterials( o.shapeName, t, "Created by MakeComplex: " & o.shapeName & ".ma on " & Mis.Today() ); END END DoIt; PROCEDURE MakeMap(shape: Shape): Pair = BEGIN CASE shape OF | Shape.Sphere => RETURN MakeSphere(); | Shape.Cm2t => RETURN MakeCm2t(); | Shape.Torus => RETURN MakeTorus(); | Shape.Pseudo => RETURN MakePseudo(); | Shape.Seifert => RETURN MakeSeifert(); | Shape.Poincare => RETURN MakePoincare(); | Shape.Lens1 => RETURN MakeLens1(); | Shape.Lens2 => RETURN MakeLens2(); | Shape.Lens3 => RETURN MakeLens3(); | Shape.Lens4 => RETURN MakeLens4(); | Shape.Lens5 => RETURN MakeLens5(); END END MakeMap; PROCEDURE MakeTorus(): Pair = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH a = MakeBigCube(Order) DO EVAL GlueBigCube(Clock(Spin(Fnext_1(a[Order-1,0,0]))), Spin(Fnext_1(Enext_1(Enext_1(a[0,0,0])))), Order); EVAL GlueBigCube(Spin(a[Order-1,0,1]), Clock(Spin(a[Order-1,0,0])),Order); EVAL GlueBigCube(Spin(Fnext(Enext_1(a[0,0,1]))), Clock(Spin(Fnext(Enext(a[0,Order-1,1])))), Order); Wr.PutText(stderr, "Building topology of Torus: \n"); (* Return one pair not kill by the GlueBigCube procedure *) RETURN a[0,0,1]; END; END MakeTorus; PROCEDURE MakeSphere(): Pair = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH a = MakeTetraTopo(Order,Order) DO EVAL Glue(Spin(a[1]),a[0],Order); EVAL Glue(Spin(a[3]),a[2],Order); Wr.PutText(stderr, "Building topology of Sphere: \n"); (* Return one pair not kill by the Glue Procedure *) RETURN a[1]; END; END MakeSphere; <* UNUSED *> PROCEDURE MakeSphere_H1(): Pair = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH a = MakeTetraTopo(Order,Order) DO EVAL Glue(Spin(a[5]),a[4],Order); EVAL Glue(Spin(a[7]),a[6],Order); Wr.PutText(stderr, "Building topology of Sphere-h1: \n"); (* Return one pair not kill by the Glue Procedure *) RETURN a[5]; END; END MakeSphere_H1; <* UNUSED *> PROCEDURE MakeSphere_H2(): Pair = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH a = MakeTetraTopo(Order,Order) DO EVAL Glue(Spin(a[1]),a[0],Order); EVAL Glue(Spin(a[7]),a[6],Order); Wr.PutText(stderr, "Building topology of Sphere-h2: \n"); (* Return one pair not kill by the Glue Procedure *) RETURN a[1]; END; END MakeSphere_H2; <* UNUSED *> PROCEDURE MakeSphere_H3(): Pair = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH a = MakeTetraTopo(Order,Order) DO EVAL Glue(Spin(a[5]),a[4],Order); EVAL Glue(Spin(a[3]),a[2],Order); Wr.PutText(stderr, "Building topology of Sphere-h3: \n"); (* Return one pair not kill by the Glue Procedure *) RETURN a[5]; END; END MakeSphere_H3; PROCEDURE MakeCm2t(): Pair = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH a = MakeTetraTopo(Order,Order), b = MakeTetraTopo(Order,Order) DO EVAL Glue(Spin(a[1]),b[0],Order); EVAL Glue(Spin(a[3]),a[2],Order); EVAL Glue(Spin(b[1]),a[0],Order); EVAL Glue(Spin(b[3]),b[2],Order); Wr.PutText(stderr, "Building topology of Cm2t: \n"); (* Return one pair not kill by the Glue Procedure *) RETURN Spin(a[3]); END; END MakeCm2t; PROCEDURE MakeMyDodecahedron() : REF ARRAY OF Free = (* Build a triangualted dodecahedron, as the gluing of sixty tetrahedra, the gluings are done manually one to one (not automatically). *) (* Procedures for emphasize the original elements of the map. *) PROCEDURE SetFaceExis(b: Pair; faceExists: BOOLEAN) = (* Set the face as existing or not. *) BEGIN WITH f = NARROW(b.facetedge.face, Triangulation.Face) DO f.exists := faceExists; END END SetFaceExis; PROCEDURE SetRingFaceExis(a: Pair; faceExists: BOOLEAN) = (* Set the ring of faces as existing or not. *) VAR an: Pair := a; BEGIN REPEAT SetFaceExis(an, faceExists); an := Fnext(an) UNTIL an = a END SetRingFaceExis; PROCEDURE SetEdgeExis(a: Pair; edgeExists: BOOLEAN) = (* Set the edge as existing or not . *) BEGIN WITH e = NARROW(a.facetedge.edge, Triangulation.Edge) DO e.exists := edgeExists; END END SetEdgeExis; PROCEDURE SetVertexExis(a: Pair) = (* Set the vertex as not existing. *) BEGIN WITH v = NARROW(Org(a), Vertex) DO v.exists := FALSE; END END SetVertexExis; PROCEDURE BuildPentaPyramid() : Penta = (* Builds a pentagonal pyramid as the gluing of five tetrahedra. This procedure is a special case of the procedure MakeBipyramid in the module with the same name. *) VAR a : ARRAY[0..4] OF ARRAY[0..7] OF Pair; p : Penta; BEGIN (* creating the tetrahedra *) FOR i := 0 TO 4 DO a[i] := MakeTetraTopo(1,1); END; (* gluing *) FOR i := 0 TO 4 DO EVAL Glue(Spin(a[i,1]),a[(i+1) MOD 5,0],1); END; (* emphasize the original elements *) SetRingFaceExis(a[0,1], FALSE); FOR i := 0 TO 4 DO SetEdgeExis( a[i][1] ,FALSE); SetEdgeExis(Enext (a[i][1]),FALSE); SetEdgeExis(Enext_1(a[i][1]),FALSE); SetFaceExis(a[i][3] ,FALSE); END; SetVertexExis(a[0,1]); SetVertexExis(Clock(a[0,1])); (* choosing the pairs that will be returned *) FOR j := 0 TO 4 DO p[j][0] := a[j][3]; p[j][1] := a[j][2]; END; RETURN p; END BuildPentaPyramid; VAR ap : ARRAY [0..11] OF Penta; fr := NEW(REF ARRAY OF Free, 12); BEGIN (* creating the pentagonal pyramids *) FOR i := 0 TO 11 DO ap[i] := BuildPentaPyramid(); END; (* Building the first half-dodecahedron : gluing the pentagonal pyramids: p[0][0][0] <----> p[1][0][0] p[0][1][0] <----> p[2][0][0] p[0][2][0] <----> p[3][0][0] p[0][3][0] <----> p[4][0][0] p[0][4][0] <----> p[5][0][0] *) FOR i := 1 TO 5 DO EVAL Glue(Clock(ap[0][i-1][0]), ap[i][0][0], 1); END; (* p1-p2 *) EVAL Glue(Clock(ap[2][1][0]), ap[1][4][0], 1); (* p2-p3 *) EVAL Glue(Clock(ap[3][1][0]), ap[2][4][0], 1); (* p3-p4 *) EVAL Glue(Clock(ap[4][1][0]), ap[3][4][0], 1); (* p4-p5 *) EVAL Glue(Clock(ap[5][1][0]), ap[4][4][0], 1); (* p5-p1 *) EVAL Glue(Clock(ap[1][1][0]), ap[5][4][0], 1); (* Building the second half-dodecahedron : gluing the pentagonal pyramids: p[6][0][0] <----> p[7 ][0][0] p[6][1][0] <----> p[8 ][0][0] p[6][2][0] <----> p[9 ][0][0] p[6][3][0] <----> p[10][0][0] p[6][4][0] <----> p[11][0][0] *) FOR i := 7 TO 11 DO EVAL Glue(Clock(ap[6][i-7][0]), ap[i][0][0], 1); END; (* p8-p7 *) EVAL Glue(Clock(ap[8][1][0]), ap[7][4][0], 1); (* p9-p8 *) EVAL Glue(Clock(ap[9][1][0]), ap[8][4][0], 1); (* p10-p9 *) EVAL Glue(Clock(ap[10][1][0]), ap[9][4][0], 1); (* p11-p10 *) EVAL Glue(Clock(ap[11][1][0]), ap[10][4][0], 1); (* p7-p11 *) EVAL Glue(Clock(ap[7][1][0]), ap[11][4][0], 1); (* Gluing the two half dodecahedra *) EVAL Glue(Clock(ap[7][2][0]), ap[1][2][0], 1); EVAL Glue(Clock(ap[7][3][0]), ap[5][3][0], 1); EVAL Glue(Clock(ap[8][2][0]), ap[5][2][0], 1); EVAL Glue(Clock(ap[8][3][0]), ap[4][3][0], 1); EVAL Glue(Clock(ap[9][2][0]), ap[4][2][0], 1); EVAL Glue(Clock(ap[9][3][0]), ap[3][3][0], 1); EVAL Glue(Clock(ap[10][2][0]), ap[3][2][0], 1); EVAL Glue(Clock(ap[10][3][0]), ap[2][3][0], 1); EVAL Glue(Clock(ap[11][2][0]), ap[2][2][0], 1); EVAL Glue(Clock(ap[11][3][0]), ap[1][3][0], 1); FOR j := 0 TO 11 DO FOR k := 0 TO 4 DO fr[j][k] := ap[j][k][1]; END END; RETURN fr; END MakeMyDodecahedron; PROCEDURE MakePoincare(): Pair = (* This procedure builds the 3-map so called as: "Poincare Dodecahedral Space", generated by gluing pairs of opposite face of a triangulated dodecahedron, when one menber of each pair is matched to its conter- part after a rotation of one-tenth of a turn = PI/5. Equal to the Lens1 procedure below. I believe that still persist one bug !!!. Since the map must be have: nv = 12 and ne = 72 and not nv = 13 and ne = 73 !!!. *) <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH d = MakeMyDodecahedron( ) DO (* the opposite faces are: d[0] d[6] d[1] d[9] d[2] d[8] d[3] d[7] d[4] d[11] d[5] d[10] *) EVAL Glue(Clock(d[0][0]), d[6][0],1); EVAL Glue(Clock(d[0][1]), d[6][4],1); EVAL Glue(Clock(d[0][2]), d[6][3],1); EVAL Glue(Clock(d[0][3]), d[6][2],1); EVAL Glue(Clock(d[0][4]), d[6][1],1); EVAL Glue(Clock(d[1][0]), d[9][0],1); EVAL Glue(Clock(d[1][1]), d[9][4],1); EVAL Glue(Clock(d[1][2]), d[9][3],1); EVAL Glue(Clock(d[1][3]), d[9][2],1); EVAL Glue(Clock(d[1][4]), d[9][1],1); EVAL Glue(Clock(d[2][0]), d[8][0],1); EVAL Glue(Clock(d[2][1]), d[8][4],1); EVAL Glue(Clock(d[2][2]), d[8][3],1); EVAL Glue(Clock(d[2][3]), d[8][2],1); EVAL Glue(Clock(d[2][4]), d[8][1],1); EVAL Glue(Clock(d[3][0]), d[7][0],1); EVAL Glue(Clock(d[3][1]), d[7][4],1); EVAL Glue(Clock(d[3][2]), d[7][3],1); EVAL Glue(Clock(d[3][3]), d[7][2],1); EVAL Glue(Clock(d[3][4]), d[7][1],1); EVAL Glue(Clock(d[4][0]), d[11][0],1); EVAL Glue(Clock(d[4][1]), d[11][4],1); EVAL Glue(Clock(d[4][2]), d[11][3],1); EVAL Glue(Clock(d[4][3]), d[11][2],1); EVAL Glue(Clock(d[4][4]), d[11][1],1); EVAL Glue(Clock(d[5][0]), d[10][0],1); EVAL Glue(Clock(d[5][1]), d[10][4],1); EVAL Glue(Clock(d[5][2]), d[10][3],1); EVAL Glue(Clock(d[5][3]), d[10][2],1); EVAL Glue(Clock(d[5][4]), d[10][1],1); Wr.PutText(stderr, "Building the topology of the Poincare Dodecahedral Space:\n"); (* Return one pair not kill by the Glue Procedure *) RETURN d[0][0]; END; END MakePoincare; PROCEDURE MakeSeifert(): Pair = (* This procedure builds the 3-map so called as: "Seifert-Weber Space", generated by gluing pairs of opposite face of a triangulated dodecahedron, when one menber of each pair is matched to its conter- part after a rotation of three-tenth of a turn = 3/5 PI. Equal to the Lens4 procedure bellow. *) <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH d = MakeMyDodecahedron( ) DO (* the opposite faces are: d[0] d[6] d[1] d[9] d[2] d[8] d[3] d[7] d[4] d[11] d[5] d[10] *) EVAL Glue(Clock(d[0][0]), d[6][3],1); EVAL Glue(Clock(d[0][1]), d[6][2],1); EVAL Glue(Clock(d[0][2]), d[6][1],1); EVAL Glue(Clock(d[0][3]), d[6][0],1); EVAL Glue(Clock(d[0][4]), d[6][4],1); EVAL Glue(Clock(d[1][0]), d[9][3],1); EVAL Glue(Clock(d[1][1]), d[9][2],1); EVAL Glue(Clock(d[1][2]), d[9][1],1); EVAL Glue(Clock(d[1][3]), d[9][0],1); EVAL Glue(Clock(d[1][4]), d[9][4],1); EVAL Glue(Clock(d[2][0]), d[8][3],1); EVAL Glue(Clock(d[2][1]), d[8][2],1); EVAL Glue(Clock(d[2][2]), d[8][1],1); EVAL Glue(Clock(d[2][3]), d[8][0],1); EVAL Glue(Clock(d[2][4]), d[8][4],1); EVAL Glue(Clock(d[3][0]), d[7][3],1); EVAL Glue(Clock(d[3][1]), d[7][2],1); EVAL Glue(Clock(d[3][2]), d[7][1],1); EVAL Glue(Clock(d[3][3]), d[7][0],1); EVAL Glue(Clock(d[3][4]), d[7][4],1); EVAL Glue(Clock(d[4][0]), d[11][3],1); EVAL Glue(Clock(d[4][1]), d[11][2],1); EVAL Glue(Clock(d[4][2]), d[11][1],1); EVAL Glue(Clock(d[4][3]), d[11][0],1); EVAL Glue(Clock(d[4][4]), d[11][4],1); EVAL Glue(Clock(d[5][0]), d[10][3],1); EVAL Glue(Clock(d[5][1]), d[10][2],1); EVAL Glue(Clock(d[5][2]), d[10][1],1); EVAL Glue(Clock(d[5][3]), d[10][0],1); EVAL Glue(Clock(d[5][4]), d[10][4],1); Wr.PutText(stderr, "Building the topology of the Seifert-Weber Space:\n"); (* Return one pair not kill by the Glue Procedure *) RETURN d[0][0]; END; END MakeSeifert; PROCEDURE MakeLens1(): Pair = (* This procedure builds the 3-map generated by gluing pairs of opposite face of a triangulated dodecahedron, when one menber of each pair is matched to its conterpart after a rotation of 36 degrees of a turn. *) <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH d = MakeMyDodecahedron( ) DO (* the opposite faces are: d[0] d[6] d[1] d[9] d[2] d[8] d[3] d[7] d[4] d[11] d[5] d[10] *) EVAL Glue(Clock(d[0][0]), d[6][0],1); EVAL Glue(Clock(d[0][1]), d[6][4],1); EVAL Glue(Clock(d[0][2]), d[6][3],1); EVAL Glue(Clock(d[0][3]), d[6][2],1); EVAL Glue(Clock(d[0][4]), d[6][1],1); EVAL Glue(Clock(d[1][0]), d[9][0],1); EVAL Glue(Clock(d[1][1]), d[9][4],1); EVAL Glue(Clock(d[1][2]), d[9][3],1); EVAL Glue(Clock(d[1][3]), d[9][2],1); EVAL Glue(Clock(d[1][4]), d[9][1],1); EVAL Glue(Clock(d[2][0]), d[8][0],1); EVAL Glue(Clock(d[2][1]), d[8][4],1); EVAL Glue(Clock(d[2][2]), d[8][3],1); EVAL Glue(Clock(d[2][3]), d[8][2],1); EVAL Glue(Clock(d[2][4]), d[8][1],1); EVAL Glue(Clock(d[3][0]), d[7][0],1); EVAL Glue(Clock(d[3][1]), d[7][4],1); EVAL Glue(Clock(d[3][2]), d[7][3],1); EVAL Glue(Clock(d[3][3]), d[7][2],1); EVAL Glue(Clock(d[3][4]), d[7][1],1); EVAL Glue(Clock(d[4][0]), d[11][0],1); EVAL Glue(Clock(d[4][1]), d[11][4],1); EVAL Glue(Clock(d[4][2]), d[11][3],1); EVAL Glue(Clock(d[4][3]), d[11][2],1); EVAL Glue(Clock(d[4][4]), d[11][1],1); EVAL Glue(Clock(d[5][0]), d[10][0],1); EVAL Glue(Clock(d[5][1]), d[10][4],1); EVAL Glue(Clock(d[5][2]), d[10][3],1); EVAL Glue(Clock(d[5][3]), d[10][2],1); EVAL Glue(Clock(d[5][4]), d[10][1],1); Wr.PutText(stderr, "Building topology of Lens1 :\n"); (* Return one pair not kill by the Glue Procedure *) RETURN d[0][0]; END; END MakeLens1; PROCEDURE MakeLens2(): Pair = (* This procedure builds the 3-map generated by gluing pairs of opposite face of a triangulated dodecahedron, when one menber of each pair is matched to its conterpart after a rotation of 108 degrees of a turn. *) <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH d = MakeMyDodecahedron( ) DO (* the opposite faces are: d[0] d[6] d[1] d[9] d[2] d[8] d[3] d[7] d[4] d[11] d[5] d[10] *) EVAL Glue(Clock(d[0][0]), d[6][1],1); EVAL Glue(Clock(d[0][1]), d[6][0],1); EVAL Glue(Clock(d[0][2]), d[6][4],1); EVAL Glue(Clock(d[0][3]), d[6][3],1); EVAL Glue(Clock(d[0][4]), d[6][2],1); EVAL Glue(Clock(d[1][0]), d[9][1],1); EVAL Glue(Clock(d[1][1]), d[9][0],1); EVAL Glue(Clock(d[1][2]), d[9][4],1); EVAL Glue(Clock(d[1][3]), d[9][3],1); EVAL Glue(Clock(d[1][4]), d[9][2],1); EVAL Glue(Clock(d[2][0]), d[8][1],1); EVAL Glue(Clock(d[2][1]), d[8][0],1); EVAL Glue(Clock(d[2][2]), d[8][4],1); EVAL Glue(Clock(d[2][3]), d[8][3],1); EVAL Glue(Clock(d[2][4]), d[8][2],1); EVAL Glue(Clock(d[3][0]), d[7][1],1); EVAL Glue(Clock(d[3][1]), d[7][0],1); EVAL Glue(Clock(d[3][2]), d[7][4],1); EVAL Glue(Clock(d[3][3]), d[7][3],1); EVAL Glue(Clock(d[3][4]), d[7][2],1); EVAL Glue(Clock(d[4][0]), d[11][1],1); EVAL Glue(Clock(d[4][1]), d[11][0],1); EVAL Glue(Clock(d[4][2]), d[11][4],1); EVAL Glue(Clock(d[4][3]), d[11][3],1); EVAL Glue(Clock(d[4][4]), d[11][2],1); EVAL Glue(Clock(d[5][0]), d[10][1],1); EVAL Glue(Clock(d[5][1]), d[10][0],1); EVAL Glue(Clock(d[5][2]), d[10][4],1); EVAL Glue(Clock(d[5][3]), d[10][3],1); EVAL Glue(Clock(d[5][4]), d[10][2],1); Wr.PutText(stderr, "Building topology of Lens2 :\n"); (* Return one pair not kill by the Glue Procedure *) RETURN d[0][0]; END; END MakeLens2; PROCEDURE MakeLens3(): Pair = (* This procedure builds the 3-map generated by gluing pairs of opposite face of a triangulated dodecahedron, when one menber of each pair is matched to its conterpart after a rotation of 180 degree of a turn. *) <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH d = MakeMyDodecahedron( ) DO (* the opposite faces are: d[0] d[6] d[1] d[9] d[2] d[8] d[3] d[7] d[4] d[11] d[5] d[10] *) EVAL Glue(Clock(d[0][0]), d[6][2],1); EVAL Glue(Clock(d[0][1]), d[6][1],1); EVAL Glue(Clock(d[0][2]), d[6][0],1); EVAL Glue(Clock(d[0][3]), d[6][4],1); EVAL Glue(Clock(d[0][4]), d[6][3],1); EVAL Glue(Clock(d[1][0]), d[9][2],1); EVAL Glue(Clock(d[1][1]), d[9][1],1); EVAL Glue(Clock(d[1][2]), d[9][0],1); EVAL Glue(Clock(d[1][3]), d[9][4],1); EVAL Glue(Clock(d[1][4]), d[9][3],1); EVAL Glue(Clock(d[2][0]), d[8][2],1); EVAL Glue(Clock(d[2][1]), d[8][1],1); EVAL Glue(Clock(d[2][2]), d[8][0],1); EVAL Glue(Clock(d[2][3]), d[8][4],1); EVAL Glue(Clock(d[2][4]), d[8][3],1); EVAL Glue(Clock(d[3][0]), d[7][2],1); EVAL Glue(Clock(d[3][1]), d[7][1],1); EVAL Glue(Clock(d[3][2]), d[7][0],1); EVAL Glue(Clock(d[3][3]), d[7][4],1); EVAL Glue(Clock(d[3][4]), d[7][3],1); EVAL Glue(Clock(d[4][0]), d[11][2],1); EVAL Glue(Clock(d[4][1]), d[11][1],1); EVAL Glue(Clock(d[4][2]), d[11][0],1); EVAL Glue(Clock(d[4][3]), d[11][4],1); EVAL Glue(Clock(d[4][4]), d[11][3],1); EVAL Glue(Clock(d[5][0]), d[10][2],1); EVAL Glue(Clock(d[5][1]), d[10][1],1); EVAL Glue(Clock(d[5][2]), d[10][0],1); EVAL Glue(Clock(d[5][3]), d[10][4],1); EVAL Glue(Clock(d[5][4]), d[10][3],1); Wr.PutText(stderr, "Building topology of Lens3 :\n"); (* Return one pair not kill by the Glue Procedure *) RETURN d[0][0]; END; END MakeLens3; PROCEDURE MakeLens4(): Pair = (* This procedure builds the 3-map generated by gluing pairs of opposite face of a triangulated dodecahedron, when one menber of each pair is matched to its conterpart after a rotation of 252 degree of a turn. (three-tenth of turn in the clockwise sense). *) <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH d = MakeMyDodecahedron( ) DO (* the opposite faces are: d[0] d[6] d[1] d[9] d[2] d[8] d[3] d[7] d[4] d[11] d[5] d[10] *) EVAL Glue(Clock(d[0][0]), d[6][3],1); EVAL Glue(Clock(d[0][1]), d[6][2],1); EVAL Glue(Clock(d[0][2]), d[6][1],1); EVAL Glue(Clock(d[0][3]), d[6][0],1); EVAL Glue(Clock(d[0][4]), d[6][4],1); EVAL Glue(Clock(d[1][0]), d[9][3],1); EVAL Glue(Clock(d[1][1]), d[9][2],1); EVAL Glue(Clock(d[1][2]), d[9][1],1); EVAL Glue(Clock(d[1][3]), d[9][0],1); EVAL Glue(Clock(d[1][4]), d[9][4],1); EVAL Glue(Clock(d[2][0]), d[8][3],1); EVAL Glue(Clock(d[2][1]), d[8][2],1); EVAL Glue(Clock(d[2][2]), d[8][1],1); EVAL Glue(Clock(d[2][3]), d[8][0],1); EVAL Glue(Clock(d[2][4]), d[8][4],1); EVAL Glue(Clock(d[3][0]), d[7][3],1); EVAL Glue(Clock(d[3][1]), d[7][2],1); EVAL Glue(Clock(d[3][2]), d[7][1],1); EVAL Glue(Clock(d[3][3]), d[7][0],1); EVAL Glue(Clock(d[3][4]), d[7][4],1); EVAL Glue(Clock(d[4][0]), d[11][3],1); EVAL Glue(Clock(d[4][1]), d[11][2],1); EVAL Glue(Clock(d[4][2]), d[11][1],1); EVAL Glue(Clock(d[4][3]), d[11][0],1); EVAL Glue(Clock(d[4][4]), d[11][4],1); EVAL Glue(Clock(d[5][0]), d[10][3],1); EVAL Glue(Clock(d[5][1]), d[10][2],1); EVAL Glue(Clock(d[5][2]), d[10][1],1); EVAL Glue(Clock(d[5][3]), d[10][0],1); EVAL Glue(Clock(d[5][4]), d[10][4],1); Wr.PutText(stderr, "Building topology of Lens4 :\n"); (* Return one pair not kill by the Glue Procedure *) RETURN d[0][0]; END; END MakeLens4; PROCEDURE MakeLens5(): Pair = (* This procedure builds the 3-map generated by gluing pairs of opposite face of a triangulated dodecahedron, when one menber of each pair is matched to its conterpart after a rotation of 324 degree of a turn. *) <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH d = MakeMyDodecahedron( ) DO (* the opposite faces are: d[0] d[6] d[1] d[9] d[2] d[8] d[3] d[7] d[4] d[11] d[5] d[10] *) EVAL Glue(Clock(d[0][0]), d[6][4],1); EVAL Glue(Clock(d[0][1]), d[6][3],1); EVAL Glue(Clock(d[0][2]), d[6][2],1); EVAL Glue(Clock(d[0][3]), d[6][1],1); EVAL Glue(Clock(d[0][4]), d[6][0],1); EVAL Glue(Clock(d[1][0]), d[9][4],1); EVAL Glue(Clock(d[1][1]), d[9][3],1); EVAL Glue(Clock(d[1][2]), d[9][2],1); EVAL Glue(Clock(d[1][3]), d[9][1],1); EVAL Glue(Clock(d[1][4]), d[9][0],1); EVAL Glue(Clock(d[2][0]), d[8][4],1); EVAL Glue(Clock(d[2][1]), d[8][3],1); EVAL Glue(Clock(d[2][2]), d[8][2],1); EVAL Glue(Clock(d[2][3]), d[8][1],1); EVAL Glue(Clock(d[2][4]), d[8][0],1); EVAL Glue(Clock(d[3][0]), d[7][4],1); EVAL Glue(Clock(d[3][1]), d[7][3],1); EVAL Glue(Clock(d[3][2]), d[7][2],1); EVAL Glue(Clock(d[3][3]), d[7][1],1); EVAL Glue(Clock(d[3][4]), d[7][0],1); EVAL Glue(Clock(d[4][0]), d[11][4],1); EVAL Glue(Clock(d[4][1]), d[11][3],1); EVAL Glue(Clock(d[4][2]), d[11][2],1); EVAL Glue(Clock(d[4][3]), d[11][1],1); EVAL Glue(Clock(d[4][4]), d[11][0],1); EVAL Glue(Clock(d[5][0]), d[10][4],1); EVAL Glue(Clock(d[5][1]), d[10][3],1); EVAL Glue(Clock(d[5][2]), d[10][2],1); EVAL Glue(Clock(d[5][3]), d[10][1],1); EVAL Glue(Clock(d[5][4]), d[10][0],1); Wr.PutText(stderr, "Building topology of Lens5 :\n"); (* Return one pair not kill by the Glue Procedure *) RETURN d[0][0]; END; END MakeLens5; PROCEDURE MakePseudo() : Pair = (* Build the tridimensional cellular map so called "PseudoManifold". This map under this gluing will produce degenerate configuration. *) <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH ca = MakeBall() DO EVAL GlueBall(ca[0], Fnext_1(ca[1])); EVAL GlueBall(ca[1], Fnext_1(ca[2])); Wr.PutText(stderr, "Building Topology of PseudoManifold: \n"); (* Return one pair not kill by the GlueBall Procedure *) RETURN ca[2] END END MakePseudo; <* UNUSED *> PROCEDURE MakeCm2t_H1(): Pair = (* This complex is homeomorphic to cm2t manifold *) <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH a = MakeTetraTopo(Order,Order), b = MakeTetraTopo(Order,Order) DO EVAL Glue(Spin(b[3]),a[2],Order); EVAL Glue(Spin(a[3]),b[2],Order); EVAL Glue(Spin(b[1]),b[0],Order); EVAL Glue(Spin(a[1]),a[0],Order); Wr.PutText(stderr, "Building topology of cm2t-h1: \n"); (* Return one pair not kill by the Glue Procedure *) RETURN Spin(b[1]); END; END MakeCm2t_H1; <* UNUSED *> PROCEDURE MakeCm2t_H2(): Pair = (* This complex is homeomorphic to cm2t manifold *) <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH a = MakeTetraTopo(Order,Order), b = MakeTetraTopo(Order,Order) DO EVAL Glue(Spin(a[6]),b[3],Order); EVAL Glue(Spin(a[7]),b[2],Order); EVAL Glue(Spin(b[1]),b[0],Order); EVAL Glue(Spin(a[1]),a[0],Order); Wr.PutText(stderr, "Building topology of cm2t-h2: \n"); (* Return one pair not kill by the Glue Procedure *) RETURN Spin(a[6]); END; END MakeCm2t_H2; <* UNUSED *> PROCEDURE MakeCm2t_H3(): Pair = (* This complex is homeomorphic to cm2t manifold *) <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH a = MakeTetraTopo(Order,Order), b = MakeTetraTopo(Order,Order) DO EVAL Glue(Spin(a[7]),b[3],Order); EVAL Glue(Spin(a[6]),b[2],Order); EVAL Glue(Spin(b[1]),b[0],Order); EVAL Glue(Spin(a[1]),a[0],Order); Wr.PutText(stderr, "Building topology of cm2t-h3:\n"); (* Return one pair not kill by the Glue Procedure *) RETURN Spin(a[7]); END; END MakeCm2t_H3; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-shape"); o.shapeName := pp.getNext(); IF Text.Equal(o.shapeName, "sphere") THEN o.shape := Shape.Sphere ELSIF Text.Equal(o.shapeName,"cm2t") THEN o.shape := Shape.Cm2t ELSIF Text.Equal(o.shapeName,"torus") THEN o.shape := Shape.Torus ELSIF Text.Equal(o.shapeName,"pseudo") THEN o.shape := Shape.Pseudo ELSIF Text.Equal(o.shapeName,"seifert") THEN o.shape := Shape.Seifert ELSIF Text.Equal(o.shapeName,"poincare") THEN o.shape := Shape.Poincare ELSIF Text.Equal(o.shapeName,"lens1") THEN o.shape := Shape.Lens1 ELSIF Text.Equal(o.shapeName,"lens2") THEN o.shape := Shape.Lens2 ELSIF Text.Equal(o.shapeName,"lens3") THEN o.shape := Shape.Lens3 ELSIF Text.Equal(o.shapeName,"lens4") THEN o.shape := Shape.Lens4 ELSIF Text.Equal(o.shapeName,"lens5") THEN o.shape := Shape.Lens5 ELSE pp.error("Bad shape \"" & pp.getNext() & "\"\n") END; pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: MakeComplex \\\n"); Wr.PutText(stderr, " -shape { Seifert | Poincare | ..}\n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt(); END MakeComplex. (**************************************************************************) (* *) (* Copyright (C) 2001 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/MakeComplexWf.m3 MODULE MakeComplexWf EXPORTS Main; (* Generates ".tp",".tb",".st" and ".ma" files for some simples tridimensional maps with boundary. The vertex coordinates are random numbers in [-1..+1]. Revisions: 30-08-2000 : nice version of the "MakeOctahedron" procedure. *) IMPORT ParseParams, Text, Octf, Triangulation, Wr, Stdio, Thread, Process, Mis, Squared, Fmt; FROM Octf IMPORT Fnext, PrintPair, Spin, Enext_1, Clock, Enext, Fnext_1; FROM Triangulation IMPORT MakeTetraTopo, Glue, Pair; FROM Stdio IMPORT stderr; TYPE Shape = { Triang, Tetra1, Tetra2, Tetra3, TetraRe, CubeTriang, BigCube, Octa1, Octa2, Octa3, Pyramid }; Options = RECORD order: CARDINAL; shape: Shape; shapeName: TEXT; END; PROCEDURE DoIt() = VAR t : Triangulation.Topology; BEGIN WITH o = GetOptions(), m = MakeMap(o.shape, o.order) DO t := Triangulation.MakeTopology(m); WITH c = Triangulation.GenCoords(t)^ DO (* set the edge and face roots *) FOR i := 0 TO t.NF-1 DO WITH f = t.face[i] DO f.root := f.num; END END; FOR i := 0 TO t.NE-1 DO WITH e = t.edge[i] DO e.root := e.num; END END; (* Now writes *) Triangulation.WriteTopology(o.shapeName & "-" & Fmt.Int(o.order), t, "Created by MakeComplexWf: " & o.shapeName & "-" & Fmt.Int(o.order) & ".tp on " & Mis.Today() ); Triangulation.WriteState(o.shapeName & "-" & Fmt.Int(o.order), t, c, "Created by MakeComplexWf: " & o.shapeName & "-" & Fmt.Int(o.order) & ".st on " & Mis.Today() &"\nRandom Geometry"); Triangulation.WriteMaterials(o.shapeName & "-" & Fmt.Int(o.order), t, "Created by MakeComplexWf: " & o.shapeName & "-" & Fmt.Int(o.order) & ".ma on " & Mis.Today()); END END END DoIt; PROCEDURE MakeMap(shape: Shape; order: CARDINAL): Pair = BEGIN CASE shape OF | Shape.Triang => RETURN Squared.MakeTriangle(); | Shape.Tetra1 => RETURN MakeTetra(order); | Shape.Tetra2 => RETURN MakeTetra2(order); | Shape.Tetra3 => RETURN MakeTetra3(order); | Shape.TetraRe => RETURN Make12Fold(order); | Shape.CubeTriang => RETURN MakeCubeTriang(order); | Shape.BigCube => RETURN MakeBigcube(order); | Shape.Octa1 => RETURN MakeOctahedron(order); | Shape.Octa2 => RETURN MakeTwoOctaGlue(order); | Shape.Octa3 => RETURN MakeThreeOctaGlue(order); | Shape.Pyramid => RETURN MakePyramid(order); END END MakeMap; (* Shape builders: *) PROCEDURE MakeTetra(<* UNUSED *> or: CARDINAL): Pair = (* unglued topological tetrahedron *) <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH a = Squared.MakeTetrahedron() DO Wr.PutText(stderr,"Building topology of one topological tetrahedron\n"); RETURN a[0]; END; END MakeTetra; PROCEDURE MakeOctahedron(<* UNUSED *> or: CARDINAL): Pair = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH o = Squared.MakeOctahedron() DO Wr.PutText(stderr, "Building the topology of one octahedral cell\n"); RETURN o[0]; END; END MakeOctahedron; PROCEDURE MakeTwoOctaGlue(<* UNUSED *> or: CARDINAL): Pair = <* FATAL Wr.Failure, Thread.Alerted *> (* Builds the topology of the map with two octahedral cell gluing them along of a common face. *) BEGIN WITH o1 = Squared.MakeOctahedron(), o2 = Squared.MakeOctahedron() DO EVAL Glue(Spin(o1[1]), o2[6],1); Wr.PutText(stderr,"Building the topology of two octahedral cells\n"); RETURN o1[0]; END; END MakeTwoOctaGlue; PROCEDURE MakeThreeOctaGlue(<* UNUSED *> or: CARDINAL): Pair = <* FATAL Wr.Failure, Thread.Alerted *> (* Build the topology of the map with three octahedral cell gluing them along of common edge. *) BEGIN WITH o1 = Squared.MakeOctahedron(), o2 = Squared.MakeOctahedron(), o3 = Squared.MakeOctahedron() DO EVAL Glue(Spin(o1[1]), o2[6],1); EVAL Glue(Spin(o1[5]), Spin(Enext_1(o3[2])), 1); EVAL Glue(Clock(Enext(o3[1])), o2[2],1); Wr.PutText(stderr,"Building the topology of three octahedral cells\n"); RETURN o1[0]; END; END MakeThreeOctaGlue; PROCEDURE Make12Fold(<* UNUSED *> or: CARDINAL): Pair = <* FATAL Wr.Failure, Thread.Alerted *> (* This procedure builds a refined tetrahedron as the subdivision scheme know as "12fold", but with one octahedral cell more eigth tetrahedral cells. *) BEGIN WITH o = Squared.MakeOctahedron(), t0 = Squared.MakeTetrahedron(), t1 = Squared.MakeTetrahedron(), t2 = Squared.MakeTetrahedron(), t3 = Squared.MakeTetrahedron(), t4 = Squared.MakeTetrahedron(), t5 = Squared.MakeTetrahedron(), t6 = Squared.MakeTetrahedron(), t7 = Squared.MakeTetrahedron() DO (* first glue the 8 tetrahedra to the central octahedron *) EVAL Glue(t0[0],o[0],1); (* 5 *) EVAL Glue(t1[0],o[1],1); (* 6 *) EVAL Glue(t2[0],o[2],1); (* 7 *) EVAL Glue(t3[0],o[3],1); (* 8 *) EVAL Glue(t4[0],Fnext(t0[0]),1); (* 5 *) EVAL Glue(t5[0],Fnext(t1[0]),1); (* 6 *) EVAL Glue(t6[0],Fnext(t2[0]),1); (* 7 *) EVAL Glue(t7[0],Fnext(t3[0]),1); (* 8 *) EVAL Glue(o[4],Fnext(t4[0]),1); (* 5 *) EVAL Glue(o[5],Fnext(t5[0]),1); (* 6 *) EVAL Glue(o[6],Fnext(t6[0]),1); (* 7 *) EVAL Glue(o[7],Fnext(t7[0]),1); (* 8 *) EVAL Glue(Clock(Fnext(Enext_1(t1[0]))),Fnext(Enext(t0[0])),1); (* 9 *) EVAL Glue(Clock(Fnext(Enext_1(t2[0]))),Fnext(Enext(t1[0])),1); (* 10 *) EVAL Glue(Clock(Fnext(Enext_1(t3[0]))),Fnext(Enext(t2[0])),1); (* 11 *) EVAL Glue(Clock(Fnext(Enext_1(t0[0]))),Fnext(Enext(t3[0])),1); (* 12 *) EVAL Glue(Fnext_1(Enext(o[4])),Clock(Fnext_1(Enext_1(o[5]))), 1); EVAL Glue(Fnext_1(Enext(o[5])),Clock(Fnext_1(Enext_1(o[6]))), 1); EVAL Glue(Fnext_1(Enext(o[6])),Clock(Fnext_1(Enext_1(o[7]))), 1); EVAL Glue(Fnext_1(Enext(o[7])),Clock(Fnext_1(Enext_1(o[4]))), 1); Wr.PutText(stderr, "Building a refined tetrahedron with an octahedral cell in the center\n"); RETURN t0[0]; END; END Make12Fold; PROCEDURE MakeTetra2(or: CARDINAL): Pair = (* Glues two topological tetrahedron along a one triangulated face. *) <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH a = MakeTetraTopo(or,or), b = MakeTetraTopo(or,or) DO EVAL Glue(Spin(b[3]),a[2],or); Wr.PutText(stderr, "Building the topology of 2 tetrahedra glued along one triang. face\n"); RETURN b[3]; END; END MakeTetra2; PROCEDURE MakeTetra3(or: CARDINAL): Pair = (* Glues three topological tetrahedron two by two along a common edge, i.e. builds a map "edgestar" of degree three. *) <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH a = MakeTetraTopo(or,or), b = MakeTetraTopo(or,or), c = MakeTetraTopo(or,or) DO EVAL Glue(Spin(a[1]),b[0],or); EVAL Glue(Spin(b[1]),c[0],or); EVAL Glue(Spin(c[1]),a[0],or); Wr.PutText(stderr, "Building the topology of 3 tetrahedra glued along a common edge\n"); RETURN a[1]; END; END MakeTetra3; PROCEDURE MakeCubeTriang(or: CARDINAL): Pair = (* A simple triangulated cube, building by the glue of six simples tetrahedron. *) <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH a = MakeTetraTopo(or,or), b = MakeTetraTopo(or,or), c = MakeTetraTopo(or,or), d = MakeTetraTopo(or,or), e = MakeTetraTopo(or,or), f = MakeTetraTopo(or,or) DO EVAL Glue(Spin(b[1]),a[0],or); EVAL Glue(Spin(c[1]),b[0],or); EVAL Glue(Spin(d[1]),c[0],or); EVAL Glue(Spin(e[1]),d[0],or); EVAL Glue(Spin(f[1]),e[0],or); EVAL Glue(Spin(a[1]),f[0],or); Wr.PutText(stderr,"Building the topology of one triangulated cube\n"); RETURN a[1]; END; END MakeCubeTriang; PROCEDURE MakeBigcube(or: CARDINAL) : Pair = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH a = Squared.MakeBigCube(or) DO Wr.PutText(stderr, "Building the topology of an array of cubes\n"); RETURN a[0,0,0]; END; END MakeBigcube; PROCEDURE MakePyramid(or: CARDINAL) : Pair = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH a = Squared.MakePyramid(or) DO Wr.PutText(stderr, "Building the topology of a pyramid with base as a " & Fmt.Int(or) & "-gon\n"); RETURN a[0]; END; END MakePyramid; <* UNUSED *> PROCEDURE Prt (a: Pair) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(stderr, "faceedge: "); PrintPair(stderr, a); Wr.PutText(stderr, " fnext: "); PrintPair(stderr, Fnext(a)); Wr.PutText(stderr, "\n"); END Prt; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-order"); o.order := pp.getNextInt(1, 9); pp.getKeyword("-shape"); o.shapeName := pp.getNext(); IF Text.Equal(o.shapeName , "tetra1") THEN o.shape := Shape.Tetra1 ELSIF Text.Equal(o.shapeName, "tetra2") THEN o.shape := Shape.Tetra2 ELSIF Text.Equal(o.shapeName, "tetra3") THEN o.shape := Shape.Tetra3 ELSIF Text.Equal(o.shapeName, "tetrare") THEN o.shape := Shape.TetraRe ELSIF Text.Equal(o.shapeName, "cubetriang") THEN o.shape := Shape.CubeTriang ELSIF Text.Equal(o.shapeName, "bigcube") THEN o.shape := Shape.BigCube ELSIF Text.Equal(o.shapeName, "octa1") THEN o.shape := Shape.Octa1 ELSIF Text.Equal(o.shapeName, "octa2") THEN o.shape := Shape.Octa2 ELSIF Text.Equal(o.shapeName, "octa3") THEN o.shape := Shape.Octa3 ELSIF Text.Equal(o.shapeName, "pyramid") THEN o.shape := Shape.Pyramid ELSIF Text.Equal(o.shapeName, "triangle") THEN o.shape := Shape.Triang ELSE pp.error("Bad shape \"" & pp.getNext() & "\"\n") END; pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: MakeComplexWf -order \\\n"); Wr.PutText(stderr, " -shape { tetra1 | ... | cubetriang | ...}\n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt(); END MakeComplexWf. (**************************************************************************) (* *) (* Copyright (C) 1999 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/MakeElongBip.m3 MODULE MakeElongBip EXPORTS Main; (* Generates ".tp",".tb",".ma" and ".st" files for some simples 3D polyhedrons called `elongated bipyramids'. The vertex coordinates are random numbers in [-1..+1]. See the copyright and authorship futher down. *) IMPORT ParseParams, Octf, Triangulation, Wr, Stdio, Thread, Process, Mis; FROM Octf IMPORT Spin, Enext_1, Clock, Fnext, Enext; FROM Triangulation IMPORT MakeTetraTopo, Glue, Pair, Face, Edge, Vertex, Org; FROM Stdio IMPORT stderr; FROM Wr IMPORT PutText; TYPE Options = RECORD outName : TEXT; order: CARDINAL; (* Number of tetrahedra per layer. *) END; PROCEDURE DoIt() = BEGIN WITH o = GetOptions(), m = MakeElongBip(o.order), t = Triangulation.MakeTopology(m,1), c = Triangulation.GenCoords(t) DO (* setting the "root" attribute for faces and edges. *) FOR i := 0 TO t.NF-1 DO WITH f = t.face[i] DO f.root := f.num END END; FOR i := 0 TO t.NE-1 DO WITH e = t.edge[i] DO e.root := e.num END END; Triangulation.WriteTopology( o.outName,t,"Created by MakeElongBip: " & o.outName & ".tp on " & Mis.Today() ); Triangulation.WriteState( o.outName,t,c^,"Created by MakeElongBip:" & o.outName & ".st on " & Mis.Today() & "\n" & "Random Geometry."); Triangulation.WriteMaterials( o.outName,t,"Created by MakeElongBip: " & o.outName & ".ma on " & Mis.Today() ); END END DoIt; PROCEDURE SetRingFace(a: Pair; faceExists: BOOLEAN) = (* Set the face as non existing. *) PROCEDURE SetFace(b: Pair) = BEGIN WITH t = NARROW(b.facetedge.face, Face) DO t.exists := faceExists; END END SetFace; VAR an: Pair := a; BEGIN REPEAT SetFace(an); an := Fnext(an) UNTIL an = a END SetRingFace; PROCEDURE SetEdge(a: Pair; edgeExists: BOOLEAN) = (* Set the edge as non existing. *) BEGIN WITH e = NARROW(a.facetedge.edge, Edge) DO e.exists := edgeExists; END END SetEdge; PROCEDURE SetGhostVertex(a: Pair) = (* Set the vertex as non existing. *) BEGIN WITH v = NARROW(Org(a), Vertex) DO v.exists := FALSE; END END SetGhostVertex; PROCEDURE MakeElongBip(n: CARDINAL) : Pair = (* Builds an elongated bipyramid. The icosahedron is obtained with n=5. *) BEGIN <* ASSERT n >= 3 *> WITH a = NEW(REF ARRAY OF ARRAY[0..7] OF Pair, 4*n)^ DO FOR i := 0 TO 4*n-1 DO a[i] := MakeTetraTopo(1,1); END; (* first level *) FOR i := 0 TO n-1 DO EVAL Glue(Spin(a[(i+1) MOD n][1]),a[i][0],1); END; (* next level *) FOR i := 0 TO n-1 DO EVAL Glue(Spin(a[i][3]),a[i+n][2],1); END; FOR i := n TO 2*n-1 DO EVAL Glue(Clock(Enext_1(a[i][0])), a[i+n][0], 1); IF i = 2*n-1 THEN EVAL Glue( Clock(Enext_1(a[n][1])), a[n+i][1], 1); ELSE EVAL Glue( Clock(Enext_1(a[(i+1)][1])), a[n+i][1],1); END; END; (* Last level *) FOR i := 2*n TO 3*n-1 DO EVAL Glue(Spin(a[i][2]),a[i+n][7],1); END; FOR i := 3*n TO 4*n-1 DO IF i = 4*n-1 THEN EVAL Glue(Spin(a[3*n][1]),a[i][0],1); ELSE EVAL Glue(Spin(a[(i+1)][1]),a[i][0],1); END END; (* Emphasize the original elements *) SetRingFace(a[0][1],FALSE); SetEdge(a[0][1],FALSE); SetRingFace(a[2*n-1][1],FALSE); SetEdge(a[4*n-1][1],FALSE); SetGhostVertex(a[2*n-1][1]); FOR i := 0 TO n-1 DO SetRingFace(Enext(a[i][1]),FALSE); END; FOR i := n TO 2*n-1 DO SetEdge(Enext_1(a[i][1]),FALSE); END; FOR i := 3*n TO 4*n-1 DO SetRingFace(Enext_1(a[i][1]),FALSE); SetEdge(Enext_1(a[i][1]),FALSE); END; RETURN a[0][1]; END END MakeElongBip; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-outName"); o.outName := pp.getNext(); pp.getKeyword("-order"); o.order := pp.getNextInt(3,100); pp.finish(); EXCEPT | ParseParams.Error => PutText(stderr, "Usage: MakeElongBip \\\n"); PutText(stderr, " -outName NAME \\\n"); PutText(stderr, " -order NUM\n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt(); END MakeElongBip. (**************************************************************************) (* *) (* Copyright (C) 1999 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (* Last edited on 2001-05-14 23:53:13 by stolfi *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/MakeGem.m3 MODULE MakeGem EXPORTS Main; (* This program builds the topology of some Sosten'es 3-Gems *) IMPORT Stdio, Wr, Thread, ParseParams, Process, Octf, Triangulation, Mis, Text; FROM Triangulation IMPORT Pair, MakeTetraTopo; FROM Stdio IMPORT stderr; FROM Octf IMPORT Spin, Clock, Enext_1, Enext; TYPE Handle = ARRAY[0..3] OF Pair; Shape = { projective, r24_20}; Options = RECORD shape: Shape; shapeName: TEXT; END; VAR handles : REF ARRAY OF Handle; PROCEDURE MakeGemCell() : Handle = VAR ha : Handle; BEGIN WITH te = MakeTetraTopo(1,1), h0 = Spin(Clock(Enext_1(te[0]))), h1 = Spin(Clock(Enext_1(te[6]))), h2 = Enext(te[1]), h3 = Spin(Clock(Enext_1(te[2]))) DO ha[0] := h0; ha[1] := h1; ha[2] := h2; ha[3] := h3; END; RETURN ha; END MakeGemCell; PROCEDURE DoIt() = BEGIN WITH o = GetOptions() DO IF Text.Equal(o.shapeName,"projective") THEN handles := NEW(REF ARRAY OF Handle, 8); FOR i := 0 TO 7 DO handles[i] := MakeGemCell(); END; (* Projective Space *) GlueGem(0, 1, 3); GlueGem(0, 6, 0); GlueGem(0, 4, 1); GlueGem(0, 3, 2); GlueGem(1, 2, 2); GlueGem(1, 5, 1); GlueGem(1, 7, 0); GlueGem(2, 6, 1); GlueGem(2, 4, 0); GlueGem(2, 3, 3); GlueGem(3, 7, 1); GlueGem(3, 5, 0); GlueGem(4, 7, 2); GlueGem(4, 5, 3); GlueGem(5, 6, 2); GlueGem(6, 7, 3); ELSIF Text.Equal(o.shapeName,"r24-20") THEN handles := NEW(REF ARRAY OF Handle, 24); FOR i := 0 TO 23 DO handles[i] := MakeGemCell(); END; (* Cor 0: *) GlueGem( 1-1, 2-1, 0); GlueGem( 3-1, 4-1, 0); GlueGem( 5-1, 6-1, 0); GlueGem( 7-1, 8-1, 0); GlueGem( 9-1, 10-1, 0); GlueGem(11-1, 12-1, 0); GlueGem(13-1, 14-1, 0); GlueGem(15-1, 16-1, 0); GlueGem(17-1, 18-1, 0); GlueGem(19-1, 20-1, 0); GlueGem(21-1, 22-1, 0); GlueGem(23-1, 24-1, 0); (* Cor 1: *) GlueGem( 1-1, 8-1, 1); GlueGem( 2-1, 3-1, 1); GlueGem( 4-1, 5-1, 1); GlueGem( 6-1, 7-1, 1); GlueGem( 9-1, 14-1, 1); GlueGem(10-1, 11-1, 1); GlueGem(12-1, 13-1, 1); GlueGem(15-1, 20-1, 1); GlueGem(16-1, 17-1, 1); GlueGem(18-1, 19-1, 1); GlueGem(21-1, 24-1, 1); GlueGem(22-1, 23-1, 1); (* Cor 2: *) GlueGem( 1-1, 20-1, 2); GlueGem( 2-1, 19-1, 2); GlueGem( 3-1, 18-1, 2); GlueGem( 4-1, 17-1, 2); GlueGem( 5-1, 16-1, 2); GlueGem( 6-1, 13-1, 2); GlueGem( 7-1, 24-1, 2); GlueGem( 8-1, 9-1, 2); GlueGem(10-1, 23-1, 2); GlueGem(11-1, 22-1, 2); GlueGem(12-1, 21-1, 2); GlueGem(14-1, 15-1, 2); (* Cor 3: *) GlueGem( 1-1, 18-1, 3); GlueGem( 2-1, 17-1, 3); GlueGem( 3-1, 16-1, 3); GlueGem( 4-1, 9-1, 3); GlueGem( 5-1, 24-1, 3); GlueGem( 6-1, 11-1, 3); GlueGem( 7-1, 20-1, 3); GlueGem( 8-1, 19-1, 3); GlueGem(10-1, 15-1, 3); GlueGem(12-1, 23-1, 3); GlueGem(13-1, 22-1, 3); GlueGem(14-1, 21-1, 3); END; WITH t = Triangulation.MakeTopology(handles[0][0]), c = Triangulation.GenCoords(t)^, name = o.shapeName DO Triangulation.WriteTopology(name, t, "Created by MakeGem: " & name & ".tp on " & Mis.Today() ); Triangulation.WriteMaterials(name, t, "Created by MakeGem: " & name& ".ma on " & Mis.Today()); Triangulation.WriteState(name, t, c, "Created by MakeGem: " & name & ".st on " & Mis.Today() &"\nRandom Geometry"); END; END END DoIt; PROCEDURE GlueGem(i, j, cor : CARDINAL) = BEGIN EVAL Triangulation.Glue(Spin(handles[i,cor]), handles[j,cor],1); END GlueGem; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-shape"); o.shapeName := pp.getNext(); IF Text.Equal(o.shapeName, "projective") THEN o.shape := Shape.projective ELSIF Text.Equal(o.shapeName, "r24-20") THEN o.shape := Shape.r24_20 ELSE pp.error("Bad shape \"" & pp.getNext() & "\"\n") END; pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: MakeGem -shape { projective | r24-20 }\n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt() END MakeGem. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/MakeGemR2420.m3 (* Cor 0: *) GlueGem( 1-1, 2-1, 0); GlueGem( 3-1, 4-1, 0); GlueGem( 5-1, 6-1, 0); GlueGem( 7-1, 8-1, 0); GlueGem( 9-1, 10-1, 0); GlueGem(11-1, 12-1, 0); GlueGem(13-1, 14-1, 0); GlueGem(15-1, 16-1, 0); GlueGem(17-1, 18-1, 0); GlueGem(19-1, 20-1, 0); GlueGem(21-1, 22-1, 0); GlueGem(23-1, 24-1, 0); (* Cor 1: *) GlueGem( 1-1, 8-1, 1); GlueGem( 2-1, 3-1, 1); GlueGem( 4-1, 5-1, 1); GlueGem( 6-1, 7-1, 1); GlueGem( 9-1, 14-1, 1); GlueGem(10-1, 11-1, 1); GlueGem(12-1, 13-1, 1); GlueGem(15-1, 20-1, 1); GlueGem(16-1, 17-1, 1); GlueGem(18-1, 19-1, 1); GlueGem(21-1, 24-1, 1); GlueGem(22-1, 23-1, 1); (* Cor 2: *) GlueGem( 1-1, 20-1, 2); GlueGem( 2-1, 19-1, 2); GlueGem( 3-1, 18-1, 2); GlueGem( 4-1, 17-1, 2); GlueGem( 5-1, 16-1, 2); GlueGem( 6-1, 13-1, 2); GlueGem( 7-1, 24-1, 2); GlueGem( 8-1, 9-1, 2); GlueGem(10-1, 23-1, 2); GlueGem(11-1, 22-1, 2); GlueGem(12-1, 21-1, 2); GlueGem(14-1, 15-1, 2); (* Cor 3: *) GlueGem( 1-1, 18-1, 3); GlueGem( 2-1, 17-1, 3); GlueGem( 3-1, 16-1, 3); GlueGem( 4-1, 9-1, 3); GlueGem( 5-1, 24-1, 3); GlueGem( 6-1, 11-1, 3); GlueGem( 7-1, 20-1, 3); GlueGem( 8-1, 19-1, 3); GlueGem(10-1, 15-1, 3); GlueGem(12-1, 23-1, 3); GlueGem(13-1, 22-1, 3); GlueGem(14-1, 21-1, 3); ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/MakeGon.m3 MODULE MakeGon EXPORTS Main; (* Generates ".tp",".tb",".ma" and ".st" files for n-gons, for 2 <= n <= 20. Implemented by L. Lozada (see the copyright and authorship futher down). Last version 11-11-99 *) IMPORT ParseParams, Squared, Wr, Stdio, Thread, Process, Fmt, Mis, Octf, LR4, Math, Triangulation; FROM Stdio IMPORT stderr; FROM Octf IMPORT Enext; FROM Triangulation IMPORT Pair, OrgV, Topology, MakeTopology, Coords; FROM Squared IMPORT MakeGon; TYPE Options = RECORD order: CARDINAL; fixed: BOOLEAN; END; PROCEDURE DoIt() = VAR c: REF Coords; flag: TEXT; BEGIN WITH o = GetOptions(), m = MakeGon(o.order), t = MakeTopology(m), name = "gon-" & Fmt.Int(o.order) DO c := NEW(REF Coords, t.NV); IF NOT o.fixed THEN c := Triangulation.GenCoords(t); flag := "-ran"; Triangulation.WriteTopology(name & flag,t,"Created by MakeGon: gon-" & Fmt.Int(o.order) & "-ran.tp on " & Mis.Today() ); Triangulation.WriteState(name&flag,t,c^, "Created by MakeGon: gon-" & Fmt.Int(o.order) & "-ran.st on " & Mis.Today() & "\nRandom Geometry"); Triangulation.WriteMaterials(name & flag,t,"Created by MakeGon: gon-" & Fmt.Int(o.order) & "-ran.ma on " & Mis.Today() ); ELSE c := FixCoordsGon(o.order,m,t); flag := "-fix"; Triangulation.WriteTopology(name & flag,t,"Created by MakeGon: gon-" & Fmt.Int(o.order) & "-fix.tp on " & Mis.Today() ); Triangulation.WriteState(name & flag, t,c^, "Created by MakeGon: gon-" & Fmt.Int(o.order) & "-fix.st on " & Mis.Today() ); Triangulation.WriteMaterials(name & flag,t,"Created by MakeGon: gon-" & Fmt.Int(o.order) & "-fix.ma on " & Mis.Today() ); END END END DoIt; PROCEDURE FixCoordsGon( order: CARDINAL; a: Pair; READONLY top: Topology; ): REF Coords = VAR theta: LONGREAL := 0.0d0; y : LONGREAL; BEGIN (* first, we compute the coordinates on a circle of radius one*) WITH count = 360 DIV order, r = NEW(REF Coords, top.NV), c = r^ DO PROCEDURE SetCoords(e: Pair; cv: LR4.T) = (* set the coordinates of the vertex OrgV(e). *) BEGIN c[OrgV(e).num] := cv; END SetCoords; VAR an: Pair := a; BEGIN FOR i := 0 TO order-1 DO theta := FLOAT(count,LONGREAL) + theta; WITH rad = FLOAT((theta * FLOAT(Math.Pi,LONGREAL))/180.0d0,LONGREAL), x = Math.cos(rad), x2 = FLOAT(x * x,LONGREAL) DO IF rad > FLOAT(Math.Pi,LONGREAL) THEN y := Math.sqrt(1.0d0-x2); ELSE y := -Math.sqrt(1.0d0-x2); END; SetCoords(an, LR4.T{x,y,0.0d0,1.0d0}); an := Enext(an); END END; RETURN r END END END FixCoordsGon; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-order"); o.order := pp.getNextInt(2,40); o.fixed := pp.keywordPresent("-fixed"); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: MakeGon -order <2-40> \\\n"); Wr.PutText(stderr, " [ -fixed ]\n"); Process.Exit(1); END END; RETURN o END GetOptions; BEGIN DoIt(); END MakeGon. (**************************************************************************) (* *) (* Copyright (C) 2001 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/MakeManifold.m3 MODULE MakeManifold EXPORTS Main; (* This program generates ".tp",".tb",".st" and ".ma" files for some sim- ples tridimensional maps with topologies of three-manifolds, such as, the Hypersphere S^{3} and the Hypertorus T^{3}. The vertex coordinates are random numbers in [-1..+1]. The difference with the "MakeComplex" program (that also builds 3D maps homeomorphic to 3D manifolds) is that, "MakeComplex" program uses polyhe- dra gluing scheme as a single polyhedron, conversely, "MakeManifold" uses a subdivision or refinement of the polyhedra gluing scheme. The maps builds through the "MakeComplex" program results in degeneracies conversely, "MakeManifold" produces maps that can be not result in degene- racies, depending on the "order" option. *) IMPORT ParseParams, Text, Octf, Triangulation, Wr, Stdio, Thread, Process, Mis, Squared, Refine, Fmt; FROM Octf IMPORT Spin, Clock, Enext_1, Fnext, Fnext_1, Enext; FROM Stdio IMPORT stderr; FROM Triangulation IMPORT Pair, MakeTetraTopo, Glue, EmphasizeTetrahedron; FROM Squared IMPORT MakeBigCube, GlueBigCube, SetCubeProperties; FROM Refine IMPORT MakeMaximalGlue; TYPE Shape = { (* subdivided polyhedra, such as builds by the: *) Sphere1, (* "libm3triang.Triangualtion.MakeTetraTopo" procedure *) Sphere2, (* "libm3subdi.Refine.MakeTetra" procedure *) Torus, (* "libm3squared.Squared.MakeBigCube" procedure *) TorusNet }; Options = RECORD shape: Shape; shapeName: TEXT; order: CARDINAL; END; PROCEDURE DoIt() = BEGIN WITH o = GetOptions(), m = MakeMap(o.shape,o.order), t = Triangulation.MakeTopology(m), c = Triangulation.GenCoords(t)^ DO (* setting the root elements for edges and faces *) FOR i := 0 TO t.NF-1 DO WITH f = t.face[i] DO f.root := f.num; END END; FOR i := 0 TO t.NE-1 DO WITH e = t.edge[i] DO e.root := e.num; END END; Triangulation.WriteTopology( o.shapeName & "-" & Fmt.Int(o.order), t, "Created by MakeManifold: " & o.shapeName & "-" & Fmt.Int(o.order) & ".tp on " & Mis.Today() ); Triangulation.WriteState( o.shapeName & "-" & Fmt.Int(o.order),t,c,"Created by MakeManifold: " & o.shapeName & "-" & Fmt.Int(o.order) & ".st on " & Mis.Today() & "\nRandom Geometry"); Triangulation.WriteMaterials( o.shapeName & "-" & Fmt.Int(o.order), t, "Created by MakeManifold: " & o.shapeName & "-" & Fmt.Int(o.order) & ".ma on " & Mis.Today() ); END END DoIt; PROCEDURE MakeMap(shape: Shape; order: CARDINAL): Pair = BEGIN CASE shape OF | Shape.Sphere1 => RETURN MakeSphere1(order); | Shape.Sphere2 => RETURN MakeSphere2(order); | Shape.Torus => RETURN MakeTorus(order); | Shape.TorusNet => RETURN MakeTorusNet(order); END END MakeMap; PROCEDURE MakeTorus(order: CARDINAL): Pair = <* FATAL Wr.Failure, Thread.Alerted *> (* A cube (the gluing scheme for the Hypertorus map) is modeled as a tridimensional array of smaller cubes, as returned by the "libm3squared.Squared.MakeBigCube" procedure. *) BEGIN Wr.PutText(stderr, "First, we build the 3D array of cubes\n"); WITH a = MakeBigCube(order), p = a[order-1,0,0], t = Triangulation.MakeTopology(p) DO (* Set all elements (vertices, edges, faces), as non-existing *) FOR i := 0 TO t.NF-1 DO WITH f = t.face[i] DO f.exists := FALSE; END END; FOR i := 0 TO t.NE-1 DO WITH e = t.edge[i] DO e.exists := FALSE; END END; FOR i := 0 TO t.NV-1 DO WITH v = t.vertex[i] DO v.exists := FALSE; END END; (* Now emphasize the original elements (vertices,edges,faces) *) SetCubeProperties(a, order, t); EVAL GlueBigCube(Clock(Spin(Fnext_1(a[order-1,0,0]))), Spin(Fnext_1(Enext_1(Enext_1(a[0,0,0])))), order); EVAL GlueBigCube(Spin(a[order-1,0,1]), Clock(Spin(a[order-1,0,0])),order); EVAL GlueBigCube(Spin(Fnext(Enext_1(a[0,0,1]))), Clock(Spin(Fnext(Enext(a[0,order-1,1])))), order); Wr.PutText(stderr, "Building topology of Torus: \n"); (* Return one pair not kill by the GlueBigCube procedure *) RETURN a[0,0,1]; END; END MakeTorus; PROCEDURE MakeTorusNet(order: CARDINAL): Pair = <* FATAL Wr.Failure, Thread.Alerted *> (* A cube (the gluing scheme for the Hypertorus map) is modeled as a tridimensional array of smaller cubes, as returned by the "libm3squared.Squared.MakeBigCube" procedure. *) BEGIN Wr.PutText(stderr, "First, we build the 3D array of cubes\n"); WITH a = MakeBigCube(order) DO (* Set all elements (vertices, edges, faces), as non-existing *) EVAL GlueBigCube(Clock(Spin(Fnext_1(a[order-1,0,0]))), Spin(Fnext_1(Enext_1(Enext_1(a[0,0,0])))), order); EVAL GlueBigCube(Spin(a[order-1,0,1]), Clock(Spin(a[order-1,0,0])),order); EVAL GlueBigCube(Spin(Fnext(Enext_1(a[0,0,1]))), Clock(Spin(Fnext(Enext(a[0,order-1,1])))), order); Wr.PutText(stderr, "Building topology of Torus: \n"); (* Return one pair not kill by the GlueBigCube procedure *) RETURN a[0,0,1]; END; END MakeTorusNet; PROCEDURE MakeSphere1(order: CARDINAL): Pair = <* FATAL Wr.Failure, Thread.Alerted *> (* A tetrahedron (the gluing scheme for the Hypersphere map) is a bidimensional array of smaller tetrahedra, as returned by the "libm3triang.Triangulation. MakeTetraTopo" procedure. *) BEGIN WITH a = MakeTetraTopo(order,order) DO EmphasizeTetrahedron(a[0], a[3], order); EVAL Glue(Spin(a[1]),a[0],order); EVAL Glue(Spin(a[3]),a[2],order); Wr.PutText(stderr, "Building topology of Sphere1: \n"); (* Return one pair not kill by the Glue Procedure *) RETURN a[1]; END; END MakeSphere1; PROCEDURE MakeSphere2(order: CARDINAL): Pair = <* FATAL Wr.Failure, Thread.Alerted *> (* A tetrahedron (the gluing scheme for the Hypersphere map) is regular refinement of a single tetrahedron, as returned by the "libm3subdi.Refine.MakeTetra" procedure. The number of smaller tetrahedra is computed by the recursion: "5/3 order^{3} - 2/3 order". *) BEGIN WITH a = MakeMaximalGlue(order) DO Wr.PutText(stderr, "Building topology of Sphere2:\n"); (* Return one pair not kill by the Glue Procedure *) RETURN a; END; END MakeSphere2; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-shape"); o.shapeName := pp.getNext(); IF Text.Equal(o.shapeName, "sphere1") THEN o.shape := Shape.Sphere1 ELSIF Text.Equal(o.shapeName,"sphere2") THEN o.shape := Shape.Sphere2 ELSIF Text.Equal(o.shapeName,"torus") THEN o.shape := Shape.Torus ELSIF Text.Equal(o.shapeName,"torusnet") THEN o.shape := Shape.TorusNet ELSE pp.error("Bad shape \"" & pp.getNext() & "\"\n") END; pp.getKeyword("-order"); o.order := pp.getNextInt(1, 9); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr,"Usage: MakeManifold \\\n"); Wr.PutText(stderr," -shape { sphere1 | sphere2 | torus }\\\n"); Wr.PutText(stderr," -order \n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt(); END MakeManifold. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/MakeNOComplex.m3 MODULE MakeNOComplex EXPORTS Main; (* This program generates ".tp",".tb",".st" and ".ma" files for another tridimensional complexes with topologies of pseudo three-manifolds. The vertex coordinates are random numbers in [-1..+1]. Implemented by L. Lozada (see the copyright and authorship futher down). Notice: we need to modify the facet-edge data structure for modeling ------ those non orientable 3D complex, or use another data structure *) IMPORT ParseParams, Text, Octf, Triangulation, Wr, Stdio, Thread, Process, Mis, Squared; FROM Octf IMPORT Clock, Enext, Fnext_1; FROM Stdio IMPORT stderr; FROM Triangulation IMPORT Pair; FROM Squared IMPORT MakeCube, GlueCube; TYPE Shape = {Projective}; Options = RECORD shape: Shape; shapeName: TEXT; END; PROCEDURE DoIt() = BEGIN WITH o = GetOptions(), m = MakeMap(o.shape), t = Triangulation.MakeTopology(m), c = Triangulation.GenCoords(t)^ DO Triangulation.WriteTopology( o.shapeName, t, "Created by MakeNOComplex: " & o.shapeName & ".tp on " & Mis.Today() ); Triangulation.WriteState( o.shapeName, t, c,"Created by MakeNOComplex: " & o.shapeName & ".st on " & Mis.Today() & "\nRandom Geometry" ); Triangulation.WriteMaterials( o.shapeName, t,"Created by MakeNOComplex: " & o.shapeName & ".ma on " & Mis.Today() ); END END DoIt; PROCEDURE MakeMap(shape: Shape): Pair = BEGIN CASE shape OF | Shape.Projective => RETURN MakeProjective(); END END MakeMap; PROCEDURE MakeProjective(): Pair = (* Notice: we need to modify the facet-edge data structure for modeling this non orientable 3D complex. *) <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH co = MakeCube() DO EVAL GlueCube(co[1], Clock(Fnext_1(co[2]))); EVAL GlueCube(co[5], co[0]); EVAL GlueCube(co[4], Enext(Enext(co[2]))); Wr.PutText(stderr, "Building Topology of ProjectiveSpace: \n"); (* Return one pair not kill by the GlueBall Procedure *) RETURN co[0]; END; END MakeProjective; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-shape"); o.shapeName := pp.getNext(); IF Text.Equal(o.shapeName, "projective") THEN o.shape := Shape.Projective ELSE pp.error("Bad shape \"" & pp.getNext() & "\"\n") END; pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr,"Usage: OtherComplex -shape { projective }\n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt(); END MakeNOComplex. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/MakeObjectTriang.m3 MODULE MakeObjectTriang EXPORTS Main; (* Generates ".tp",".tb",".ma" and ".st" files for some simples triangulated and convex objects such as "sausage", bidimensional "torus" with and with out one twist in R^{4}. The vertex coordinates are random numbers in [-1..+1]. Last modification: 19-03-2000 by lozada *) IMPORT Octf, Triangulation, Wr, Thread, ParseParams, Stdio, Process, Fmt, Text, Mis; FROM Triangulation IMPORT Pair, Pneg, Org, SetPneg, Node, SetOrg, MakeTetraTopo, Glue; FROM Octf IMPORT Enext, Clock, Enext_1, Fnext, Spin, Fnext_1,SetEdgeAll, Onext, Onext_1; FROM Stdio IMPORT stderr; CONST order = 1; TYPE PAIRS = ARRAY[0..3] OF Pair; Shape = {Torus2D, Torus2H, Sausage}; Options = RECORD shape: Shape; shapeName: TEXT; gridOrder: CARDINAL; END; PROCEDURE Main() = VAR top : Triangulation.Topology; BEGIN WITH o = GetOptions(), m = MakeObject(o.shape, o.gridOrder), name = o.shapeName & "-" & Fmt.Int(o.gridOrder) DO Octf.EnumFacetEdges(m,SetAllOrgs,FALSE); top := Triangulation.MakeTopology(m,1); IF Text.Equal(o.shapeName, "torus2d") THEN <* ASSERT top.NV = 8 + (o.gridOrder-1) * 4 - 4 *> <* ASSERT top.NE = 19 + (o.gridOrder-1) * 14 - 5 *> <* ASSERT top.NF = 18 + (o.gridOrder-1) * 16 - 2 *> <* ASSERT top.NFE= 54 + (o.gridOrder-1) * 48 - 6 *> <* ASSERT top.NP = 6 * o.gridOrder *> ELSIF Text.Equal(o.shapeName, "sausage") THEN <* ASSERT top.NV = 8 + (o.gridOrder-1) * 4 *> <* ASSERT top.NE = 19 + (o.gridOrder-1) * 14 *> <* ASSERT top.NF = 18 + (o.gridOrder-1) * 16 *> <* ASSERT top.NFE= 54 + (o.gridOrder-1) * 48 *> <* ASSERT top.NP = 6 * o.gridOrder *> END; WITH c = Triangulation.GenCoords(top)^ DO Triangulation.WriteTopology( name, top, "Created by MakeObjectTriang: " & o.shapeName & ".tp on " & Mis.Today() ); Triangulation.WriteTable( name, top, "Created by MakeObjectTriang: " & o.shapeName & ".tb on " & Mis.Today() ); Triangulation.WriteState( name, top, c,"Created by MakeObjectTriang: " & o.shapeName & ".st on " & Mis.Today() & "\nRandom Geometry"); Triangulation.WriteMaterials( name, top,"Created by MakeObject: " & o.shapeName & ".ma on " & Mis.Today() ); END END; END Main; PROCEDURE MakeObject(shape: Shape; order: CARDINAL): Pair = BEGIN CASE shape OF | Shape.Torus2D => RETURN MakeTorus2D(order); | Shape.Torus2H => RETURN MakeTorus2H(order); | Shape.Sausage => RETURN MakeSausage(order); END END MakeObject; (* Shape builders: *) PROCEDURE MakeCubeT() : ARRAY [0..5] OF Pair = VAR co : ARRAY [0..5] OF Pair; BEGIN WITH n = order, ca = MakeTetraTopo(n,n), cb = MakeTetraTopo(n,n), cc = MakeTetraTopo(n,n), cd = MakeTetraTopo(n,n), ce = MakeTetraTopo(n,n), cf = MakeTetraTopo(n,n) DO EVAL Glue(Spin(cb[1]),ca[0],n); EVAL Glue(Spin(cc[1]),cb[0],n); EVAL Glue(Spin(cd[1]),cc[0],n); EVAL Glue(Spin(ce[1]),cd[0],n); EVAL Glue(Spin(cf[1]),ce[0],n); EVAL Glue(Spin(ca[1]),cf[0],n); co[0] := cb[3]; co[1] := cc[3]; co[2] := cd[3]; co[3] := ce[3]; co[4] := cf[3]; co[5] := ca[3]; RETURN co; END; END MakeCubeT; PROCEDURE GlueCubeT(a, b : Pair) : Pair = (* This procedure allows to glue two squared faces that is the union of two triangular faces. *) VAR ta,tb: ARRAY [0..1] OF Pair; BEGIN ta[0] := a; tb[0] := b; ta[1] := Clock(Enext_1(Fnext_1(Enext(ta[0])))); tb[1] := Clock(Enext_1(Fnext(Enext(tb[0])))); <* ASSERT ta[1] # a *> <* ASSERT tb[1] # b *> Octf.Meld(tb[0], ta[0]); (* updating edges relations for i=0 *) SetEdgeAll(ta[0], ta[0].facetedge.edge); SetEdgeAll(Enext(ta[0]), Enext(ta[0]).facetedge.edge); SetEdgeAll(Enext_1(ta[0]), Enext_1(ta[0]).facetedge.edge); (* updating polyhedron relations for i=0 *) SetPneg(ta[0], Pneg(tb[0])); SetPneg(Enext(ta[0]), Pneg(Enext(tb[0]))); SetPneg(Enext(Enext(ta[0])), Pneg(Enext(Enext(tb[0])))); Octf.Meld(tb[1],ta[1]); (* updating edges relations *) SetEdgeAll(ta[1], ta[1].facetedge.edge); SetEdgeAll(Enext(ta[1]), Enext(ta[1]).facetedge.edge); SetEdgeAll(Enext_1(ta[1]), Enext_1(ta[1]).facetedge.edge); (* updating polyhedron relations *) SetPneg(ta[1], Pneg(tb[1])); SetPneg(Enext(ta[1]), Pneg(Enext(tb[1]))); SetPneg(Enext(Enext(ta[1])), Pneg(Enext(Enext(tb[1])))); RETURN a; END GlueCubeT; PROCEDURE MakeRowCube(order: CARDINAL) : REF ARRAY OF PAIRS = (* Builds one row of cubes with order "order". *) VAR ca : REF ARRAY OF ARRAY [0..5] OF Pair; cb : REF ARRAY OF PAIRS; BEGIN ca := NEW(REF ARRAY OF ARRAY [0..5] OF Pair, order); cb := NEW(REF ARRAY OF PAIRS, order); FOR i := 0 TO order-1 DO ca[i] := MakeCubeT(); cb[i,0] := ca[i,2]; cb[i,1] := ca[i,3]; cb[i,2] := ca[i,4]; cb[i,3] := ca[i,5]; END; (* gluing *) FOR j := 0 TO order-2 DO EVAL GlueCubeT(Enext(Fnext_1(ca[j+1,4])),ca[j,0]); END; RETURN cb; END MakeRowCube; PROCEDURE MakeSausage(order: CARDINAL) : Pair = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH s = MakeRowCube(order) DO Wr.PutText(stderr, " Building topology of sausage: \n"); RETURN s[0,0] END END MakeSausage; PROCEDURE MakeTorus2D(order: CARDINAL) : Pair = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH s = MakeRowCube(order), a = Enext(Fnext_1(s[0,2])), b = Clock(Fnext_1(Enext_1(Fnext(Fnext(Enext(Fnext_1(s[order-1,3]))))))) DO EVAL GlueCubeT(a,b); Wr.PutText(stderr, " Building topology of 2D Torus: \n"); RETURN s[0,3] END END MakeTorus2D; PROCEDURE MakeTorus2H(order: CARDINAL) : Pair = <* FATAL Wr.Failure, Thread.Alerted *> (* Builds a solid torus with two holes. This construction is based in the connected sum of two manifolds: a # b *) BEGIN WITH a = MakeTorus2D(order), b = MakeTorus2D(order), c = Fnext(Enext(Fnext(Fnext(Enext(Fnext_1(b)))))) DO EVAL Triangulation.Glue(Clock(a),Clock(c),2); <* ASSERT Octf.DegreeFaceRing(a) = 4 *> <* ASSERT Octf.DegreeFaceRing(Enext(a)) = 7 *> <* ASSERT Octf.DegreeFaceRing(Enext_1(a)) = 4 *> Wr.PutText(stderr, " Building topology of 2D Torus with two holes: \n"); RETURN a END END MakeTorus2H; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-shape"); o.shapeName := pp.getNext(); IF Text.Equal (o.shapeName, "torus2d") THEN o.shape := Shape.Torus2D ELSIF Text.Equal(o.shapeName, "torus2h") THEN o.shape := Shape.Torus2H ELSIF Text.Equal(o.shapeName, "sausage") THEN o.shape := Shape.Sausage ELSE pp.error("Bad shape \"" & pp.getNext() & "\"\n"); END; pp.getKeyword("-gridOrder"); o.gridOrder := pp.getNextInt(3,30); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: MakeObjectTriang \\\n"); Wr.PutText(stderr," -shape { torus2d | torus2h | sausage }\\\n"); Wr.PutText(stderr, " -gridOrder \\\n"); Process.Exit (1); END END; RETURN o END GetOptions; PROCEDURE SetAllOrgs(a: Pair) = (* Set alls pairs facetedges with the same origin that "a" (i.e with the node "n"). *) PROCEDURE Set(a: Pair; n: Node) = VAR t: Pair := a; tn: Pair; BEGIN REPEAT SetOrg(t,n); tn := Clock(Enext_1(t)); REPEAT SetOrg(tn,n); tn := Fnext(tn); UNTIL ( tn = Clock(Enext_1(t)) ); t := Fnext(t); UNTIL (t = a); END Set; VAR an : Pair := a; ap : Pair := Enext(Fnext_1(Fnext_1(Enext_1(a)))); BEGIN WITH n = Org(a) DO REPEAT Set(an,n); an := Onext(an); UNTIL(an = a); REPEAT Set(ap,n); ap := Onext_1(ap); UNTIL(ap = Enext(Fnext_1(Fnext_1(Enext_1(a)))) ); END; END SetAllOrgs; BEGIN Main(); END MakeObjectTriang. (**************************************************************************) (* *) (* Copyright (C) 1999 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/MakePentaOcta.m3 MODULE MakePentaOcta EXPORTS Main; (* This program implements the automatic gluing of cells (tetrahedra, triangulated octahedra) for the 4D non-regular polytope: "Truncated Simplex", also know as: "PentaOcta". The Truncated Simplex has nv=10, ne=30, nf=30, np=10, self-dual. This 3D map is a polytope, but not a regular polytope, since it has 5 tetrahedral volumes and 5 octahedral volumes. *) IMPORT Stdio, Wr, Fmt, Thread, Mis, Triangulation, Octf, Process, ParseParams; FROM Triangulation IMPORT Pair, MakeTetraTopo, Glue, OrgV, MakeTopology, Ppos; FROM Stdio IMPORT stderr; FROM Octf IMPORT Spin, Clock, Enext_1, Enext, SpinBit; TYPE Row2I = ARRAY[0..1] OF CARDINAL; Row4I = ARRAY[0..3] OF CARDINAL; Options = RECORD detail: BOOLEAN; END; CONST IniStackSize = 700; cellnum = 45; VAR cell4 := NEW(REF ARRAY OF Row4I, IniStackSize); tetra : REF ARRAY OF ARRAY [0..3] OF Pair; o : Options; PROCEDURE DoIt() = <* FATAL Thread.Alerted, Wr.Failure *> PROCEDURE Gluing(Ti,Tj,Ci,Cj: CARDINAL) : Pair = (* Gluing the tetrahedra Ti with Tj through the free faces Ci and Cj respectively. *) PROCEDURE PrintInfo(case: CARDINAL;oi,oj,di,dj: CARDINAL) = (* Prints information about the three possible cases in the gluing procedure. *) BEGIN Wr.PutText(stderr, "case " & Fmt.Int(case) & ": "); Wr.PutText(stderr, Fmt.Int(oi) & " " & Fmt.Int(di)&"\n"); Wr.PutText(stderr, " "); Wr.PutText(stderr, Fmt.Int(oj) & " " & Fmt.Int(dj)&"\n\n"); END PrintInfo; PROCEDURE UngluedInfo(ci,cj,ti,tj: CARDINAL) = (* Prints information about unglued case in the gluing procedure. This procedure cause the halt of the program. *) BEGIN Wr.PutText(stderr, "Not glue this case " & Fmt.Int(ci) & " " & Fmt.Int(cj) & "\n"); Wr.PutText(stderr, " Tetrahedra " & Fmt.Int(ti) & " " & Fmt.Int(tj) & "\n"); Process.Exit(1); END UngluedInfo; BEGIN IF o.detail THEN Wr.PutText(stderr,"Ci="&Fmt.Int(Ci)&" Cj="&Fmt.Int(Cj)&", "); END; IF (* 1 *) Ci = 0 AND Cj = 0 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1] DO WITH Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,3] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,0] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext_1(tetra[Tj,Cj])); END; END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 2 *) Ci = 0 AND Cj = 1 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1] DO WITH Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,2] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,2], Dj = cell4[Tj,0] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 3 *) Ci = 0 AND Cj = 2 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1] DO WITH Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,0] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,0], Dj = cell4[Tj,2] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 4 *) Ci = 0 AND Cj = 3 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1] DO WITH Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi = Dj) AND (Di = Oj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,1] DO IF (Oi = Dj) AND (Di = Oj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,2] DO IF (Oi = Dj) AND (Di = Oj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END; ELSIF (* 5 *) Ci = 1 AND Cj = 0 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1] DO WITH Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,3] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,0] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END; ELSIF (* 6 *) Ci = 1 AND Cj = 1 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1] DO WITH Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,2] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,2], Dj = cell4[Tj,0] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END; ELSIF (* 7 *) Ci = 1 AND Cj = 2 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1] DO WITH Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,0] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,0], Dj = cell4[Tj,2] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END; ELSIF (* 8 *) Ci = 1 AND Cj = 3 THEN WITH Oi = cell4[Ti,0], Di = cell4[Ti,1] DO WITH Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,1] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,2] DO IF (Oi = Oj) AND (Di = Dj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END; ELSIF (* 9 *) Ci = 2 AND Cj = 0 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3] DO WITH Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,3] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,0] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 10 *) Ci = 2 AND Cj = 1 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3] DO WITH Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,2] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,2], Dj = cell4[Tj,0] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 11 *) Ci = 2 AND Cj = 2 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3] DO WITH Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,0] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,0], Dj = cell4[Tj,2] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 12 *) Ci = 2 AND Cj = 3 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3] DO WITH Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,1] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,2] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 13 *) Ci = 3 AND Cj = 0 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3] DO WITH Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,3] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,0] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 14 *) Ci = 3 AND Cj = 1 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3] DO WITH Oj = cell4[Tj,0], Dj = cell4[Tj,1] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,2] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,2], Dj = cell4[Tj,0] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 15 *) Ci = 3 AND Cj = 2 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3] DO WITH Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Spin(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,0] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,0], Dj = cell4[Tj,2] DO IF (Oi=Oj) AND (Di=Dj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Spin(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Spin(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END ELSIF (* 16 *) Ci = 3 AND Cj = 3 THEN WITH Oi = cell4[Ti,2], Di = cell4[Ti,3] DO WITH Oj = cell4[Tj,2], Dj = cell4[Tj,3] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(1,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(tetra[Tj,Cj]), tetra[Ti,Ci], 1); RETURN Clock(tetra[Tj,Cj]); END END; WITH Oj = cell4[Tj,3], Dj = cell4[Tj,1] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(2,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext(tetra[Tj,Cj])); END END; WITH Oj = cell4[Tj,1], Dj = cell4[Tj,2] DO IF (Oi=Dj) AND (Di=Oj) THEN IF o.detail THEN PrintInfo(3,Oi,Oj,Di,Dj) END; EVAL Glue(Clock(Enext_1(tetra[Tj,Cj])), tetra[Ti,Ci], 1); RETURN Clock(Enext_1(tetra[Tj,Cj])); END END; UngluedInfo(Ci,Cj,Ti,Tj); END END; RETURN tetra[Ti,0]; END Gluing; PROCEDURE SetCornersTetra(Ti: CARDINAL; row: Row4I) = (* Set the labels "row" in the tetrahedron Ti. *) BEGIN WITH a = OrgV(tetra[Ti,0]), b = OrgV(Clock(tetra[Ti,0])), c = OrgV(Enext_1(tetra[Ti,1])), d = OrgV(Enext_1(tetra[Ti,0])) DO a.num := row[0]; b.num := row[1]; c.num := row[2]; d.num := row[3]; END; END SetCornersTetra; PROCEDURE SetGhostElementsS(Ti: CARDINAL) = (* Set one vertex, three edges and faces, such that the gluing of eigth tetrahedra, resemble an octahedron. This procedure set the upper tetrahedra. *) BEGIN WITH v0 = OrgV(tetra[Ti,0]), e0 = tetra[Ti,0].facetedge.edge, e1 = Enext_1(tetra[Ti,0]).facetedge.edge, e2 = Enext_1(tetra[Ti,1]).facetedge.edge, f0 = tetra[Ti,0].facetedge.face, f1 = tetra[Ti,1].facetedge.face, f2 = tetra[Ti,2].facetedge.face DO v0.exists := FALSE; e0.exists := FALSE; e1.exists := FALSE; e2.exists := FALSE; f0.exists := FALSE; f1.exists := FALSE; f2.exists := FALSE; END; END SetGhostElementsS; PROCEDURE SetGhostElementsI(Ti: CARDINAL) = (* Set one vertex, three edges and faces, such that the gluing of eigth tetrahedra, resemble an octahedron. This procedure set the lower tetrahedra. *) BEGIN WITH v1 = OrgV(Clock(tetra[Ti,0])), e0 = tetra[Ti,0].facetedge.edge, e1 = Enext(tetra[Ti,0]).facetedge.edge, e2 = Enext(tetra[Ti,1]).facetedge.edge, f0 = tetra[Ti,0].facetedge.face, f1 = tetra[Ti,1].facetedge.face, f2 = tetra[Ti,3].facetedge.face DO v1.exists := FALSE; e0.exists := FALSE; e1.exists := FALSE; e2.exists := FALSE; f0.exists := FALSE; f1.exists := FALSE; f2.exists := FALSE; END; END SetGhostElementsI; PROCEDURE MustBeGlue(Ti,Tj: Pair) : BOOLEAN = (* Return TRUE if the faces "Ti.facetedge.face" and "Tj.facetedge.face" have coherent orientations and must be glued. *) BEGIN WITH a = OrgV(Ti).num, ae = OrgV(Enext(Ti)).num, ae_1 = OrgV(Enext_1(Ti)).num, b = OrgV(Tj).num, be = OrgV(Enext(Tj)).num, be_1 = OrgV(Enext_1(Tj)).num DO IF (a = b AND ae = be AND ae_1 = be_1) OR (a = b AND ae = be_1 AND ae_1 = be) THEN RETURN TRUE END; RETURN FALSE END; END MustBeGlue; PROCEDURE BadAttribution(Ti,Tj: Pair) : BOOLEAN = (* Return TRUE if the faces "Ti.facetedge.face" and "Tj.facetedge.face" have incoherent orientations. *) BEGIN WITH i0 = OrgV(Ti).num, i1 = OrgV(Enext(Ti)).num, i2 = OrgV(Enext_1(Ti)).num, j0 = OrgV(Tj).num, j1 = OrgV(Enext(Tj)).num, j2 = OrgV(Enext_1(Tj)).num DO IF SpinBit(Ti) # SpinBit(Tj) THEN IF (i0 = j0 AND i1 = j2 AND i2 = j1) OR (i0 = j2 AND i1 = j1 AND i2 = j0) OR (i0 = j1 AND i1 = j0 AND i2 = j2) THEN RETURN TRUE END; END; IF SpinBit(Ti) = SpinBit(Tj) THEN IF (i0 = j0 AND i1 = j1 AND i2 = j2) OR (i0 = j2 AND i0 = j0 AND i2 = j1) OR (i0 = j1 AND i1 = j2 AND i2 = j0) THEN RETURN TRUE END; END; RETURN FALSE END; END BadAttribution; PROCEDURE EnextK(Ti: Pair; k : CARDINAL) : Pair = (* Given a pair "Ti", this procedure return Enext^{k}(Ti). *) BEGIN IF k = 0 THEN RETURN Ti ELSIF k = 1 THEN RETURN Enext(Ti) ELSIF k = 2 THEN RETURN Enext(Enext(Ti)) END; RETURN Ti; END EnextK; PROCEDURE PrintCorners(Ti: CARDINAL) = (* Print the corners of the triangular face "Ti". *) BEGIN WITH a = OrgV(faces[Ti]).num, ae = OrgV(Enext(faces[Ti])).num, ae_1 = OrgV(Enext_1(faces[Ti])).num DO Wr.PutText(stderr, Fmt.Pad(Fmt.Int(a),3) & " " & Fmt.Pad(Fmt.Int(ae),3) & " " & Fmt.Pad(Fmt.Int(ae_1),3) & " "); END; END PrintCorners; VAR poly : REF ARRAY OF ARRAY [0..7] OF Pair; id : CARDINAL := 0; count : CARDINAL := 1; faces : REF ARRAY OF Pair; glues : REF ARRAY OF Row4I; BEGIN o := GetOptions(); poly := NEW(REF ARRAY OF ARRAY [0..7] OF Pair,cellnum); tetra := NEW(REF ARRAY OF ARRAY [0..3] OF Pair,cellnum); faces := NEW(REF ARRAY OF Pair, 4*cellnum); glues := NEW(REF ARRAY OF Row4I, 2*cellnum); (* creating topological tetrahedra *) FOR i := 0 TO cellnum-1 DO poly[i] := MakeTetraTopo(1,1); END; (* creating the tetrahedra *) FOR i := 0 TO cellnum-1 DO FOR j := 0 TO 3 DO tetra[i,j] := poly[i,j]; <* ASSERT Ppos(tetra[i,j]) = NIL *> END END; (* cells with corners perfectly assigments *) (* the five first tetrahedra *) cell4[0] := Row4I{1,9,4,8}; cell4[1] := Row4I{5,6,0,4}; cell4[2] := Row4I{8,3,7,6}; cell4[3] := Row4I{1,2,3,0}; cell4[4] := Row4I{9,7,2,5}; (* octahedron 1 *) cell4[5] := Row4I{101,9,7,8}; SetGhostElementsS(5); cell4[6] := Row4I{101,9,8,4}; SetGhostElementsS(6); cell4[7] := Row4I{101,9,4,5}; SetGhostElementsS(7); cell4[8] := Row4I{101,9,5,7}; SetGhostElementsS(8); cell4[9] := Row4I{6,101,7,8}; SetGhostElementsI(9); cell4[10] := Row4I{6,101,8,4}; SetGhostElementsI(10); cell4[11] := Row4I{6,101,4,5}; SetGhostElementsI(11); cell4[12] := Row4I{6,101,5,7}; SetGhostElementsI(12); (* octahedron 2 *) cell4[13] := Row4I{102,2,5,0}; SetGhostElementsS(13); cell4[14] := Row4I{102,2,0,3}; SetGhostElementsS(14); cell4[15] := Row4I{102,2,3,7}; SetGhostElementsS(15); cell4[16] := Row4I{102,2,7,5}; SetGhostElementsS(16); cell4[17] := Row4I{6,102,5,0}; SetGhostElementsI(17); cell4[18] := Row4I{6,102,0,3}; SetGhostElementsI(18); cell4[19] := Row4I{6,102,3,7}; SetGhostElementsI(19); cell4[20] := Row4I{6,102,7,5}; SetGhostElementsI(20); (* octahedron 3 *) cell4[21] := Row4I{103,9,2,5}; SetGhostElementsS(21); cell4[22] := Row4I{103,9,5,4}; SetGhostElementsS(22); cell4[23] := Row4I{103,9,4,1}; SetGhostElementsS(23); cell4[24] := Row4I{103,9,1,2}; SetGhostElementsS(24); cell4[25] := Row4I{0,103,2,5}; SetGhostElementsI(25); cell4[26] := Row4I{0,103,5,4}; SetGhostElementsI(26); cell4[27] := Row4I{0,103,4,1}; SetGhostElementsI(27); cell4[28] := Row4I{0,103,1,2}; SetGhostElementsI(28); (* octahedron 4 *) cell4[29] := Row4I{104,9,2,1}; SetGhostElementsS(29); cell4[30] := Row4I{104,9,1,8}; SetGhostElementsS(30); cell4[31] := Row4I{104,9,8,7}; SetGhostElementsS(31); cell4[32] := Row4I{104,9,7,2}; SetGhostElementsS(32); cell4[33] := Row4I{3,104,2,1}; SetGhostElementsI(33); cell4[34] := Row4I{3,104,1,8}; SetGhostElementsI(34); cell4[35] := Row4I{3,104,8,7}; SetGhostElementsI(35); cell4[36] := Row4I{3,104,7,2}; SetGhostElementsI(36); (* octahedron 5 *) cell4[37] := Row4I{105,1,0,4}; SetGhostElementsS(37); cell4[38] := Row4I{105,1,4,8}; SetGhostElementsS(38); cell4[39] := Row4I{105,1,8,3}; SetGhostElementsS(39); cell4[40] := Row4I{105,1,3,0}; SetGhostElementsS(40); cell4[41] := Row4I{6,105,0,4}; SetGhostElementsI(41); cell4[42] := Row4I{6,105,4,8}; SetGhostElementsI(42); cell4[43] := Row4I{6,105,8,3}; SetGhostElementsI(43); cell4[44] := Row4I{6,105,3,0}; SetGhostElementsI(44); (* set the labels for each tetrahedra *) FOR i := 0 TO cellnum-1 DO SetCornersTetra(i,cell4[i]); END; (* builds the table of faces for choose which tetrahedra must be gluing. *) IF o.detail THEN Wr.PutText(stderr, "C id table face\n"); Wr.PutText(stderr, "-------------------------\n"); END; FOR i := 0 TO cellnum-1 DO IF o.detail THEN Wr.PutText(stderr, Fmt.Int(i) & "\n"); END; FOR k := 0 TO 3 DO faces[(4*i)+k] := tetra[i,k]; IF o.detail THEN Wr.PutText(stderr," "& Fmt.Pad(Fmt.Int(id),4)&" "); INC(id); PrintCorners((4*i)+k); Wr.PutText(stderr, " " & Fmt.Int(k) & "\n"); END END END; (* computing which cells must be gluing. *) FOR k := 0 TO LAST(faces^) DO FOR l := k+1 TO LAST(faces^) DO FOR m := 0 TO 2 DO WITH e = EnextK(faces[l],m) DO IF MustBeGlue(faces[k],e) THEN IF o.detail THEN Wr.PutText(stderr, Fmt.Int(count) & "\n"); Wr.PutText(stderr, "must be gluing: faces[" & Fmt.Int(k) & "] with "); Wr.PutText(stderr, "faces[" & Fmt.Int(l) &"]\n"); END; WITH kc = k MOD 4, kt = k DIV 4, lc = l MOD 4, lt = l DIV 4 DO IF o.detail THEN Wr.PutText(stderr, " tetra["&Fmt.Int(kt) & "," & Fmt.Int(kc) & "] and tetra[" & Fmt.Int(lt) & "," & Fmt.Int(lc) & "]\n\n"); END; glues[count-1] := Row4I{kt,lt,kc,lc}; INC(count); IF BadAttribution(faces[k],e) THEN Wr.PutText(stderr, "Bad Attribution " & " tetra["& Fmt.Int(kt) &"and tetra[" & Fmt.Int(lt) & "]\n"); END END END END END END END; (* Do the automatic gluing of tetrahedra *) FOR i := 0 TO 2*cellnum-1 DO WITH c = glues[i] DO EVAL Gluing(c[0],c[1],c[2],c[3]); END END; (* setting the origins. *) FOR i := 0 TO cellnum-1 DO FOR j := 0 TO 3 DO WITH a = tetra[i,j], b = Enext(a), c = Enext_1(a) DO Triangulation.SetAllOrgs(a,OrgV(a)); Triangulation.SetAllOrgs(b,OrgV(b)); Triangulation.SetAllOrgs(c,OrgV(c)); END END END; (* Builds and writes the topology. *) Wr.PutText(stderr, "Building the topology of pentaocta:\n"); WITH a = tetra[44,0], t = MakeTopology(a), c = Triangulation.GenCoords(t)^, shapeName = "pentaocta" DO (* seting the elements root for edges and faces.*) FOR i := 0 TO t.NF-1 DO WITH f = t.face[i] DO f.root := f.num; END END; FOR i := 0 TO t.NE-1 DO WITH e = t.edge[i] DO e.root := e.num; END END; (* test for the original elements *) VAR nve,nee,nfe: CARDINAL := 0; BEGIN FOR i := 0 TO t.NV-1 DO WITH v = t.vertex[i] DO IF v.exists THEN INC(nve) END; END END; FOR i := 0 TO t.NE-1 DO WITH e = t.edge[i] DO IF e.exists THEN INC(nee) END; END END; FOR i := 0 TO t.NF-1 DO WITH f = t.face[i] DO IF f.exists THEN INC(nfe) END; END END; <* ASSERT nve = 10 *> <* ASSERT nee = 30 *> <* ASSERT nfe = 30 *> END; Triangulation.WriteTopology(shapeName, t, "Created by MakePentaOcta: " & shapeName & ".tp on " & Mis.Today() ); Triangulation.WriteMaterials(shapeName, t, "Created by MakePentaOcta: " & shapeName & ".ma on " & Mis.Today()); Triangulation.WriteState(shapeName, t, c, "Created by MakePentaOcta: " & shapeName & ".st on " & Mis.Today() &"\nRandom Geometry"); END END DoIt; <* UNUSED *> PROCEDURE PrintRow4I(m: Row4I) = (* Print an array of four integer values. *) <* FATAL Thread.Alerted, Wr.Failure *> BEGIN Wr.PutText(stderr,Fmt.Int(m[0]) & " " & Fmt.Int(m[1]) & " " & Fmt.Int(m[2]) & " " & Fmt.Int(m[3]) & "\n"); END PrintRow4I; <* UNUSED *> PROCEDURE PrintRow2I(m: Row2I) = (* Print an array of two integer values. *) <* FATAL Thread.Alerted, Wr.Failure *> BEGIN Wr.PutText(stderr,Fmt.Int(m[0]) & " " & Fmt.Int(m[1]) & "\n"); END PrintRow2I; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY o.detail := pp.keywordPresent("-detail"); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: MakePentaOcta [ -detail ] \n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt() END MakePentaOcta. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/MakePlatonic.m3 MODULE MakePlatonic EXPORTS Main; (* Builds the platonic solid icosahedron and dodecahedron as unique cell, i.e. without polyhedra information. *) IMPORT Octf, Triangulation, Squared, Mis, Text, Process, Wr, Thread, ParseParams; FROM Octf IMPORT Enext_1, Clock, Enext, SetFnext, SetEdgeAll, Srot; FROM Triangulation IMPORT Pair, SetAllOrgs, Org, SetNextPneg, DegreeOfVertex; FROM Stdio IMPORT stderr; FROM Squared IMPORT MakeTriangle; TYPE Shape = {Icosahedron, Dodecahedron}; Options = RECORD shape: Shape; shapeName: TEXT; END; PROCEDURE DoIt() = BEGIN WITH o = GetOptions(), m = MakePolyhedron(o.shape), t = Triangulation.MakeTopology(m), c = Triangulation.GenCoords(t)^ DO (* setting the "root" attribute for faces and edges. *) FOR i := 0 TO t.NF-1 DO WITH f = t.face[i] DO f.root := f.num; END END; FOR i := 0 TO t.NE-1 DO WITH e = t.edge[i] DO e.root := e.num; END END; Triangulation.WriteTopology( o.shapeName, t, "Created by MakePlatonic: " & o.shapeName & ".tp on " & Mis.Today() ); Triangulation.WriteState( o.shapeName, t, c,"Created by MakePlatonic: " & o.shapeName & ".st on " & Mis.Today() ); Triangulation.WriteMaterials( o.shapeName, t,"Created by MakePlatonic: " & o.shapeName & ".ma on " & Mis.Today() ); END END DoIt; PROCEDURE MakePolyhedron(shape: Shape): Pair = BEGIN CASE shape OF | Shape.Icosahedron => RETURN MakeIcosahedron(); | Shape.Dodecahedron => RETURN MakeDodecahedron(); END END MakePolyhedron; PROCEDURE MakeHalfOct( ) : ARRAY[0..3] OF Pair = (* Builds half octahedron without polyhedron information. *) VAR p : ARRAY[0..3] OF Pair; BEGIN FOR i := 0 TO 3 DO p[i] := MakeTriangle(); END; FOR i := 0 TO 3 DO WITH a = Enext(p[i]), b = Clock(Enext_1(p[(i+1) MOD 4])) DO SetFnext(a,b); SetEdgeAll(a,a.facetedge.edge); END END; FOR i := 0 TO 3 DO SetAllOrgs(Enext_1(p[i]), Org(Enext_1(p[i]))); END; RETURN p; END MakeHalfOct; <* UNUSED *> PROCEDURE MakeOctahedron( ) : ARRAY[0..7] OF Pair = (* Builds a topological octahedron, and return one pair facetedge "p[i]" for each face of the octahedron. *) VAR p : ARRAY [0..7] OF Pair; s,i : ARRAY [0..3] OF Pair; BEGIN s := MakeHalfOct(); i := MakeHalfOct(); (* builds an octahedron with two half-octahedra "s" (superior) and "i" (inferior). *) FOR j := 0 TO 3 DO p[j] := s[j]; END; FOR j := 4 TO 7 DO p[j] := i[j-4]; END; (* Set the common elements *) FOR j := 0 TO 3 DO SetFnext(p[j],p[j+4]); SetEdgeAll(p[j],p[j].facetedge.edge); SetAllOrgs(p[j], Org(p[j])); SetAllOrgs(Enext(p[j]), Org(Enext(p[j]))); END; (* set the polyhedron attribute, 24 facet-edges have the same polyhedron. *) WITH q = Triangulation.MakePolyhedron() DO FOR i := 0 TO 7 DO SetNextPneg(p[i],q); END END; (* this test is apply for assert that any pair facetedge "p[i]" really underly on a topological octahedron.*) FOR i := 0 TO 7 DO WITH d = DegreeOfVertex(Srot(p[i])) DO <* ASSERT d = 8 *> END; END; RETURN p; END MakeOctahedron; PROCEDURE MakeIcosahedron( ) : Pair = (* Builds an icosahedron as unique cell. *) VAR a: REF ARRAY OF Pair; BEGIN a := NEW(REF ARRAY OF Pair, 20); FOR i := 0 TO 19 DO a[i] := Squared.MakeTriangle( ); END; (* first level *) FOR i := 0 TO 4 DO SetFnext(Enext_1(a[i]), Clock(Enext(a[(i+1) MOD 5]))); SetFnext(a[i+5], Clock(a[i])); END; (* second level *) FOR i := 5 TO 9 DO IF i = 9 THEN SetFnext(Enext(a[i]), Clock(Enext(a[10]))); ELSE SetFnext(Enext(a[i]), Clock(Enext(a[i+6]))); END END; FOR i := 5 TO 9 DO SetFnext(Enext_1(a[i]), Clock(Enext_1(a[i+5]))); END; (* third level *) FOR i := 10 TO 14 DO SetFnext(a[i+5], Clock(a[i])); END; FOR i := 15 TO 18 DO SetFnext(Enext(a[i]), Clock(Enext_1(a[i+1]))); END; SetFnext(Enext(a[19]), Clock(Enext_1(a[15]))); FOR i := 0 TO 19 DO SetAllOrgs(a[i], Org(a[i])); SetAllOrgs(Enext(a[i]), Org(Enext(a[i]))); SetAllOrgs(Enext_1(a[i]), Org(Enext_1(a[i]))); END; RETURN a[0]; END MakeIcosahedron; PROCEDURE Enext2(a: Pair) : Pair = BEGIN RETURN Enext(Enext(a)); END Enext2; PROCEDURE Enext_2(a: Pair) : Pair = BEGIN RETURN Enext_1(Enext_1(a)); END Enext_2; PROCEDURE HalfDodecahedron() : ARRAY [0..5] OF Pair = (* Builds half dodecahedron *) VAR a : ARRAY [0..5] OF Pair; BEGIN FOR i := 0 TO 5 DO a[i] := Squared.MakeGon(5); END; SetFnext(a[0], Clock(Enext_1(a[3]))); SetFnext(Enext(a[0]), Clock(Enext_1(a[2]))); SetFnext(Enext2(a[0]), Clock(Enext_1(a[1]))); SetFnext(Enext_1(a[0]), Clock(Enext_1(a[4]))); SetFnext(Enext_2(a[0]), Clock(Enext_1(a[5]))); SetFnext(a[5], Clock(Enext_2(a[1]))); SetFnext(a[1], Clock(Enext_2(a[2]))); SetFnext(a[2], Clock(Enext_2(a[3]))); SetFnext(a[3], Clock(Enext_2(a[4]))); SetFnext(a[4], Clock(Enext_2(a[5]))); FOR i := 0 TO 5 DO SetAllOrgs(a[i], Org(a[i])); SetAllOrgs(Enext(a[i]), Org(Enext(a[i]))); SetAllOrgs(Enext2(a[i]), Org(Enext2(a[i]))); SetAllOrgs(Enext_1(a[i]), Org(Enext_1(a[i]))); SetAllOrgs(Enext_2(a[i]), Org(Enext_2(a[i]))); END; RETURN a; END HalfDodecahedron; PROCEDURE MakeDodecahedron() : Pair = (* Builds a dodecahedron as unique cell. *) BEGIN WITH a = HalfDodecahedron( ), b = HalfDodecahedron( ) DO SetFnext(Enext(b[8-6]), Clock(Enext(a[4]))); SetFnext(Enext2(b[8-6]), Clock(Enext2(a[5]))); SetFnext(Enext2(b[9-6]), Clock(Enext2(a[4]))); SetFnext(Enext(b[9-6]), Clock(Enext(a[3]))); SetFnext(Enext2(b[10-6]), Clock(Enext2(a[3]))); SetFnext(Enext(a[2]), Clock(Enext(b[10-6]))); SetFnext(Enext2(a[2]), Clock(Enext2(b[11-6]))); SetFnext(Enext(a[1]), Clock(Enext(b[11-6]))); SetFnext(Enext(a[5]), Clock(Enext(b[7-6]))); SetFnext(Enext2(a[1]), Clock(Enext2(b[7-6]))); FOR i := 0 TO 5 DO SetAllOrgs(a[i], Org(a[i])); SetAllOrgs(Enext(a[i]), Org(Enext(a[i]))); SetAllOrgs(Enext2(a[i]), Org(Enext2(a[i]))); SetAllOrgs(Enext_1(a[i]), Org(Enext_1(a[i]))); SetAllOrgs(Enext_2(a[i]), Org(Enext_2(a[i]))); END; FOR i := 0 TO 5 DO SetAllOrgs(b[i], Org(b[i])); SetAllOrgs(Enext(b[i]), Org(Enext(b[i]))); SetAllOrgs(Enext2(b[i]), Org(Enext2(b[i]))); SetAllOrgs(Enext_1(b[i]), Org(Enext_1(b[i]))); SetAllOrgs(Enext_2(b[i]), Org(Enext_2(b[i]))); END; RETURN a[0] END; (* See the unglued in the end of file *) END MakeDodecahedron; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-shape"); o.shapeName := pp.getNext(); IF Text.Equal(o.shapeName, "icosahedron") THEN o.shape := Shape.Icosahedron ELSIF Text.Equal(o.shapeName, "dodecahedron") THEN o.shape := Shape.Dodecahedron ELSE pp.error("Bad shape \"" & pp.getNext() & "\"\n") END; pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: MakePlatonic \\\n"); Wr.PutText(stderr, " -shape { icosahedron | dodecahedron }\n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt(); END MakePlatonic. (**************************************************************************) (* *) (* Copyright (C) 1999 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/MakePolytope.m3 MODULE MakePolytope EXPORTS Main; (* This program generates the topology of 4D regular and convex polytopes (".tp" files) with fixed ("-fix") or random ("-ran") geometry. Implemented by lozada. Last Modification: 10-02-2000 *) IMPORT ParseParams, Text, LR4, Octf, Triangulation, Wr, Stdio, Thread, Process, Squared, Mis; FROM Octf IMPORT Spin, Enext_1, Clock, Fnext_1, Enext, Fnext; FROM Triangulation IMPORT Pair, Coords, OrgV, Glue, MakeTetraTopo, Topology; FROM Stdio IMPORT stderr; FROM Squared IMPORT MakeCube, GlueCube; FROM Wr IMPORT PutText; TYPE Shape = {cell5, cell8, cell16}; Options = RECORD shape: Shape; shapeName: TEXT; random: BOOLEAN; (* TRUE if it geometry is random. *) polyroot: BOOLEAN; (* includes the polyhedron root information *) END; CONST order = 1; PROCEDURE DoIt() = VAR c : REF Coords; flag: TEXT; BEGIN WITH o = GetOptions(), ran = o.random, m = MakePolytope(o.shape), t = Triangulation.MakeTopology(m) DO c := NEW(REF Coords, t.NV); (* seting the elements root for edges and faces.*) FOR i := 0 TO t.NF-1 DO WITH f = t.face[i] DO f.root := f.num; END END; FOR i := 0 TO t.NE-1 DO WITH e = t.edge[i] DO e.root := e.num; END END; IF NOT ran THEN c := FixCoords(t, o.shape, m); flag :="-fix"; Triangulation.WriteTopology( o.shapeName & flag, t, "Created by MakePolytope: " & o.shapeName & "-fix.tp on " & Mis.Today() ); Triangulation.WriteState( o.shapeName & flag,t, c^, "Created by MakePolytope: " & o.shapeName & "-fix.st on " & Mis.Today() ); Triangulation.WriteMaterials( o.shapeName & flag, t, "Created by MakePolytope: " & o.shapeName & "-fix.ma on " & Mis.Today() ); ELSE c := Triangulation.GenCoords(t); flag :="-r"; Triangulation.WriteTopology( o.shapeName & flag, t, "Created by MakePolytope: " & o.shapeName & "-r.tp on " & Mis.Today() ); Triangulation.WriteState( o.shapeName & flag,t, c^, "Created by MakePolytope: " & o.shapeName & "-r.st on " & Mis.Today() & "\nRandom Geometry" ); IF NOT o.polyroot THEN Triangulation.WriteMaterials( o.shapeName & flag, t, "Created by MakePolytope: " & o.shapeName & "-r.ma on " & Mis.Today(), FALSE); ELSIF o.polyroot THEN FOR i := 0 TO t.NP-1 DO WITH p = t.polyhedron[i] DO p.root := p.num; END END; Triangulation.WriteMaterials( o.shapeName & flag, t, "Created by MakePolytope: " & o.shapeName & "-r.ma on " & Mis.Today(), TRUE); END END END END DoIt; PROCEDURE MakePolytope(shape: Shape): Pair = BEGIN CASE shape OF | Shape.cell5 => RETURN MakeHypertetrahedron(); | Shape.cell8 => RETURN MakeHypercube(); | Shape.cell16 => RETURN MakeHyperoctahedron(); END END MakePolytope; (* Shape builders: *) PROCEDURE MakeHypertetrahedron() : Pair = (* Glue five tetrahedra. The Hypertetrahedron is one polytope that corresponding to analogus 4-D of one 3-simplex. This 4-simplex have C5,0 vertices, C5,1 edegs, C5,2 faces and C5,3 polyhedra. *) <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH o = order, a = MakeTetraTopo(o,o), b = MakeTetraTopo(o,o), c = MakeTetraTopo(o,o), d = MakeTetraTopo(o,o), e = MakeTetraTopo(o,o) DO EVAL Glue(Spin(b[1]), a[0],o); (* a-b, 0-1 *) EVAL Glue(Spin(a[1]), c[0],o); (* a-c, 0-2 *) EVAL Glue(Spin(c[1]), b[0],o); (* b-c, 1-2 *) EVAL Glue(Spin(a[3]), e[2],o); (* a-e, *) EVAL Glue(Clock(a[2]),d[2],o); (* a-d *) EVAL Glue(Clock(d[3]),e[3],o); (* d-e *) EVAL Glue(Spin(Enext_1(d[0])),Enext(c[2]),o); (* c-d *) EVAL Glue(Clock(Enext_1(b[2])),Enext_1(d[1]),o); (* d-b *) EVAL Glue(Spin(Enext_1(e[1])),Enext(c[3]),o); (* e-c *) EVAL Glue(Clock(Enext_1(b[3])),Enext_1(e[0]),o); (* e-b *) PutText(stderr,"Building topology of 5-cell:\n"); RETURN b[1]; END; END MakeHypertetrahedron; PROCEDURE MakeHyperoctahedron() : Pair = (* Glue 16 tetrahedra. The Hyperoctahedron is one polytope that corresponding to analogus 4-D of one octahedron. This politope is the dual of the hipercube, so has 8 vertices, 24 edges, 32 faces and 16 tetraedra. *) <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH o = 4, a = MakeTetraTopo(o,o) DO EVAL Glue(Spin(a[1]),a[0],o); EVAL Glue(Spin(a[3]),a[2],o); PutText(stderr,"Building topology of Hyperoctahedron:\n"); RETURN a[1]; END; END MakeHyperoctahedron; PROCEDURE MakeHypercube() : Pair = (* Glue eight cubes. The Hypercube is one polytope that corresponding to analogus 4-D of one cube. This polytope have "16" vertices, "32" edges, "24" faces, "96" facetedges and "8" polyhedrons. *) <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH ca = MakeCube(), cb = MakeCube(), cc = MakeCube(), cd = MakeCube(), ce = MakeCube(), cf = MakeCube(), cg = MakeCube(), ch = MakeCube() DO (* step one *) EVAL GlueCube(ca[1], Fnext_1(cb[2])); (* 1, a-b *) EVAL GlueCube(ca[2], Fnext_1(cc[3])); (* 2, a-c *) EVAL GlueCube(ca[3], Fnext_1(cd[4])); (* 3, a-d *) EVAL GlueCube(ca[4], Fnext_1(ce[1])); (* 4, a-e *) EVAL GlueCube(ca[5], Clock(cf[0])); (* 5, a-f *) EVAL GlueCube(ca[0], Clock(cg[5])); (* 6, a-g *) EVAL GlueCube(cg[0], Clock(ch[5])); (* 7, g-h *) (* step two *) EVAL GlueCube(cb[2], Fnext_1(cc[4])); (* 8, b-c *) EVAL GlueCube(cc[3], Fnext_1(cd[1])); (* 9, c-d *) EVAL GlueCube(cd[4], Fnext_1(ce[2])); (* 10, d-e *) EVAL GlueCube(ce[1], Fnext_1(cb[3])); (* 11, e-b *) EVAL GlueCube(Enext(cb[5]), Clock(Enext_1(cf[1]))); (* 12, f-b *) EVAL GlueCube(ce[5], Clock(Enext_1(cf[4]))); (* 13, f-e *) EVAL GlueCube(Enext(Enext(cc[5])), Fnext_1(cf[0])); (* 14, f-c *) EVAL GlueCube(Enext_1(cf[3]), Clock(Enext_1(cd[5]))); (* 15, f-d *) EVAL GlueCube(Enext_1(cb[0]), Clock(Enext(cg[1]))); (* 16, b-g *) EVAL GlueCube(ce[0], Clock(Enext(cg[4]))); (* 17, e-g *) EVAL GlueCube(Enext(cg[3]), Clock(Enext(cd[0]))); (* 18, d-g *) EVAL GlueCube(Enext(cg[2]),Clock(Enext_1(Enext_1(cc[0]))));(* 19, c-g *) (* step three *) EVAL GlueCube(cb[1], Clock(ch[1])); (* 20, b-h *) EVAL GlueCube(ch[2], Clock(cc[2])); (* 21, c-h *) EVAL GlueCube(Enext_1(cd[3]), Clock(Enext(ch[3]))); (* 22, d-h *) EVAL GlueCube(Enext_1(ce[4]), Clock(Enext(ch[4]))); (* 23, e-h *) EVAL GlueCube(cf[5],Clock(ch[0])); (* 24, f-h *) PutText(stderr,"Building topology of 8-cell:\n"); RETURN ch[0] END END MakeHypercube; <* UNUSED *> PROCEDURE Make24tetra() : Pair = <* FATAL Wr.Failure, Thread.Alerted *> VAR a : ARRAY[0..23] OF ARRAY[0..7] OF Pair; BEGIN FOR i := 0 TO 23 DO a[i] := MakeTetraTopo(order,order); END; (* first level *) EVAL Glue(Spin(a[1][1]),a[0][0],order); EVAL Glue(Spin(a[2][1]),a[1][0],order); EVAL Glue(Spin(a[3][1]),a[2][0],order); EVAL Glue(Spin(a[4][1]),a[3][0],order); EVAL Glue(Spin(a[5][1]),a[4][0],order); EVAL Glue(Spin(a[0][1]),a[5][0],order); (* next level *) EVAL Glue(Spin(a[0][3]),a[6][2],order); EVAL Glue(Spin(a[1][3]),a[7][2],order); EVAL Glue(Spin(a[2][3]),a[8][2],order); EVAL Glue(Spin(a[3][3]),a[9][2],order); EVAL Glue(Spin(a[4][3]),a[10][2],order); EVAL Glue(Spin(a[5][3]),a[11][2],order); EVAL Glue(Spin(a[12][1]),a[6][0],order); EVAL Glue(Spin(a[7][1]),Enext_1(a[12][7]),order); EVAL Glue(Spin(a[13][1]),a[7][0],order); EVAL Glue(Spin(a[8][1]),Enext_1(a[13][7]),order); EVAL Glue(Spin(a[14][1]),a[8][0],order); EVAL Glue(Spin(a[9][1]),Enext_1(a[14][7]),order); EVAL Glue(Spin(a[15][1]),a[9][0],order); EVAL Glue(Spin(a[10][1]),Enext_1(a[15][7]),order); EVAL Glue(Spin(a[16][1]),a[10][0],order); EVAL Glue(Spin(a[11][1]),Enext_1(a[16][7]),order); EVAL Glue(Spin(a[17][1]),a[11][0],order); EVAL Glue(Spin(a[6][1]),Enext_1(a[17][7]),order); (* Last level *) EVAL Glue(Spin(Enext(a[12][0])),a[18][2],order); EVAL Glue(Spin(Enext(a[13][0])),a[19][2],order); EVAL Glue(Spin(Enext(a[14][0])),a[20][2],order); EVAL Glue(Spin(Enext(a[15][0])),a[21][2],order); EVAL Glue(Spin(Enext(a[16][0])),a[22][2],order); EVAL Glue(Spin(Enext(a[17][0])),a[23][2],order); EVAL Glue(Spin(a[19][1]),a[18][0],order); EVAL Glue(Spin(a[20][1]),a[19][0],order); EVAL Glue(Spin(a[21][1]),a[20][0],order); EVAL Glue(Spin(a[22][1]),a[21][0],order); EVAL Glue(Spin(a[23][1]),a[22][0],order); EVAL Glue(Spin(a[18][1]),a[23][0],order); Wr.PutText(stderr, "Building topology of Icosahedron: \n"); RETURN a[0][1]; END Make24tetra; PROCEDURE FixCoordsHypercube( READONLY h: Pair; READONLY top: Topology; ): REF Coords = BEGIN WITH r = NEW(REF Coords, top.NV), c = r^, o1 = LR4.T{ 1.0d0, 1.0d0, 1.0d0,1.0d0}, o2 = LR4.T{ 1.0d0, 1.0d0,-1.0d0,1.0d0}, o3 = LR4.T{ 1.0d0,-1.0d0, 1.0d0,1.0d0}, o4 = LR4.T{ 1.0d0,-1.0d0,-1.0d0,1.0d0}, o5 = LR4.T{-1.0d0, 1.0d0, 1.0d0,1.0d0}, o6 = LR4.T{-1.0d0, 1.0d0,-1.0d0,1.0d0}, o7 = LR4.T{-1.0d0,-1.0d0, 1.0d0,1.0d0}, o8 = LR4.T{-1.0d0,-1.0d0,-1.0d0,1.0d0}, o9 = LR4.T{ 1.0d0, 1.0d0, 1.0d0,-1.0d0}, o10= LR4.T{ 1.0d0, 1.0d0,-1.0d0,-1.0d0}, o11= LR4.T{ 1.0d0,-1.0d0, 1.0d0,-1.0d0}, o12= LR4.T{ 1.0d0,-1.0d0,-1.0d0,-1.0d0}, o13= LR4.T{-1.0d0, 1.0d0, 1.0d0,-1.0d0}, o14= LR4.T{-1.0d0, 1.0d0,-1.0d0,-1.0d0}, o15= LR4.T{-1.0d0,-1.0d0, 1.0d0,-1.0d0}, o16= LR4.T{-1.0d0,-1.0d0,-1.0d0,-1.0d0} DO PROCEDURE SetCoCoords(e: Pair; cv: LR4.T) = BEGIN c[OrgV(e).num] := cv; END SetCoCoords; BEGIN (* Set the corners *) SetCoCoords(h,o13); SetCoCoords(Enext_1(h),o15); SetCoCoords(Enext_1(Enext_1(h)),o11); SetCoCoords(Clock(h),o9); SetCoCoords(Enext_1(Fnext_1(h)),o14); SetCoCoords(Enext_1(Enext_1(Fnext_1(h))),o10); SetCoCoords(Enext_1(Fnext_1(Enext_1(Enext_1(h)))),o12); SetCoCoords(Enext_1(Enext_1(Fnext_1(Enext_1(Enext_1(h))))),o16); SetCoCoords(Enext_1(Fnext(h)),o5); SetCoCoords(Enext(Enext(Fnext(h))),o1); SetCoCoords(Enext_1(Fnext(Enext_1(Enext_1(h)))),o3); SetCoCoords(Enext_1(Enext_1(Fnext(Enext_1(Enext_1(h))))),o7); SetCoCoords(Enext_1(Fnext_1(Enext_1(Enext_1(Fnext_1(h))))),o2); SetCoCoords(Enext_1(Enext_1(Fnext_1(Enext_1(Enext_1(Fnext_1(h)))))), o6); SetCoCoords(Enext_1(Fnext_1(Enext_1(Enext_1(Fnext_1(Enext_1(Enext_1 (h))))))),o8); SetCoCoords(Enext_1(Enext_1(Fnext_1(Enext_1(Enext_1(Fnext_1(Enext_1 (Enext_1(h)))))))),o4); END; RETURN r END END FixCoordsHypercube; PROCEDURE FixCoordsHypertetrahedron( <* UNUSED *> READONLY h: Pair; READONLY top: Topology; ): REF Coords = BEGIN WITH r = NEW(REF Coords, top.NV), c = r^, c0 = LR4.T{0.0d0, 0.0d0, 0.0d0, 2.0d0}, c1 = LR4.T{-1.118030d0, 1.118030d0, 1.118030d0, -0.50d0}, c2 = LR4.T{ 1.118030d0, -1.118030d0, 1.118030d0, -0.50d0}, c3 = LR4.T{ 1.118030d0, 1.118030d0, -1.118030d0, -0.50d0}, c4 = LR4.T{-1.118030d0, -1.118030d0, -1.118030d0, -0.50d0} DO c[0] := c0; c[1] := c1; c[2] := c2; c[3] := c3; c[4] := c4; RETURN r END END FixCoordsHypertetrahedron; PROCEDURE FixCoordsHyperoctahedron( <* UNUSED *> READONLY h: Pair; READONLY top: Topology; ): REF Coords = BEGIN WITH r = NEW(REF Coords, top.NV), c = r^, c0 = LR4.T{ 0.0d0, -2.0d0, 0.0d0, 0.0d0}, c1 = LR4.T{ 0.0d0, 0.0d0, -2.0d0, 0.0d0}, c2 = LR4.T{ 2.0d0, 0.0d0, 0.0d0, 0.0d0}, c3 = LR4.T{ 0.0d0, 0.0d0, 0.0d0,-2.0d0}, c4 = LR4.T{ 0.0d0, 0.0d0, 2.0d0, 0.0d0}, c5 = LR4.T{ 0.0d0, 0.0d0, 0.0d0, 2.0d0}, c6 = LR4.T{-2.0d0, 0.0d0, 0.0d0, 0.0d0}, c7 = LR4.T{ 0.0d0, 2.0d0, 0.0d0, 0.0d0} DO c[0] := c0; c[1] := c1; c[2] := c2; c[3] := c3; c[4] := c4; c[5] := c5; c[6] := c6; c[7] := c7; RETURN r END END FixCoordsHyperoctahedron; PROCEDURE FixCoords(READONLY top: Topology; shape:Shape; READONLY m : Pair): REF Coords = BEGIN WITH r = NEW(REF Coords, top.NV), c = r^ DO IF shape = Shape.cell5 THEN (* Atribui coordenadas fixas no R4, t. q. o comprimento de toda aresta \'e 1.5811. *) c := FixCoordsHypertetrahedron(m,top)^; ELSIF shape = Shape.cell8 THEN (* Atribui coordenadas fixas no R4, t. q. o comprimento de toda aresta \'e 2.00. *) c := FixCoordsHypercube(m,top)^; ELSIF shape = Shape.cell16 THEN (* Atribui coordenadas fixas no R4. *) c := FixCoordsHyperoctahedron(m,top)^; END; RETURN r END END FixCoords; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-shape"); o.shapeName := pp.getNext(); IF Text.Equal(o.shapeName, "5cell") THEN o.shape := Shape.cell5 ELSIF Text.Equal(o.shapeName, "8cell") THEN o.shape := Shape.cell8 ELSIF Text.Equal(o.shapeName, "16cell") THEN o.shape := Shape.cell16 ELSE pp.error("Bad shape \"" & pp.getNext() & "\"\n") END; o.random := pp.keywordPresent("-random"); o.polyroot := pp.keywordPresent("-polyroot"); pp.finish(); EXCEPT | ParseParams.Error => PutText(stderr, "Usage: MakePolytope \\\n"); PutText(stderr, " -shape { 5cell | 8cell | 16cell ... } \\\n"); PutText(stderr, " [ -random ] [-polyroot]\n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt(); END MakePolytope. (**************************************************************************) (* *) (* Copyright (C) 2001 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/MakeRawTetra.m3 MODULE MakeRawTetra EXPORTS Main; (* Creates ".tp",".tb",".st" and ".ma" files for one topological tetrahedron of order "gridOrder" with fixed geometry. The vertices of a individually tetra- hedron ("gridOrder = 1") of side length Sqrt(2) be given by a particulary form when the vertices are taken as corners of a cube. One such tetrahedron for a cube of side length 1 gives the tetrahedron of side length Sqrt(2) having vertices: (0,0,0,0), (0,1,1,0), (1,0,1,0), (1,1,0.0). Every topological tetraedron have eight pairs facetedges "corners" associa- ted to hin. Let "a" one pair of Interface "Triangulation", so we associate the vertex (0,0,0,0) to "ca[0]"; (1,0,1,0) to "ca[2]"; (0,1,1,0) to "ca[4]" and the vertex (1,1,0,0) to "ca[6]". *) IMPORT Octf, LR4, Triangulation, Fmt, ParseParams, Process, Wr, Stdio, Thread, Mis; FROM Triangulation IMPORT Coords, OrgV, Pair, Topology, EmphasizeTetrahedron; FROM Octf IMPORT Enext, Clock, Enext_1, Fnext; FROM Stdio IMPORT stderr; TYPE Options = RECORD gridOrder: CARDINAL; END; PROCEDURE Main() = BEGIN WITH o = GetOptions(), ca = Triangulation.MakeTetraTopo(o.gridOrder, o.gridOrder), t = Triangulation.MakeTopology(ca[1]), c = ComputeCoordinates(ca, t, o.gridOrder)^, co = "\nIndividual topological tetrahedron with fixed geometry\n" & "Created by MakeRawTetra: tetraf-" & Fmt.Int(o.gridOrder), name = "tetra-fixed" DO EmphasizeTetrahedron(ca[0], ca[3], o.gridOrder); (* setting the root elements *) FOR i := 0 TO t.NF-1 DO WITH f = t.face[i] DO f.root := f.num; END END; FOR i := 0 TO t.NE-1 DO WITH e = t.edge[i] DO e.root := e.num; END END; Triangulation.WriteTopology( name & "-" & Fmt.Int(o.gridOrder), t, co & ".tp on " & Mis.Today()); (* Triangulation.WriteTable( name & "-" & Fmt.Int(o.gridOrder), t, co & ".tb on " & Mis.Today()); *) Triangulation.WriteState( name & "-" & Fmt.Int(o.gridOrder), t, c, co & ".st on "& Mis.Today()); Triangulation.WriteMaterials( name & "-" & Fmt.Int(o.gridOrder), t, co & ".ma on " & Mis.Today()); END; END Main; PROCEDURE ComputeCoordinates( READONLY ca: ARRAY[0..7] OF Pair; READONLY top: Topology; order: CARDINAL; ): REF Coords = BEGIN WITH r = NEW(REF Coords, top.NV), c = r^, o1 = LR4.T{0.0d0,0.0d0,0.0d0,0.0d0}, (* the vertex (0,0,0,0) *) o2 = LR4.T{1.0d0,0.0d0,1.0d0,0.0d0}, (* the vertex (1,0,1,0) *) o3 = LR4.T{0.0d0,1.0d0,1.0d0,0.0d0}, (* the vertex (0,1,1,0) *) o4 = LR4.T{1.0d0,1.0d0,0.0d0,0.0d0} (* the vertex (1,1,0,0) *) DO PROCEDURE SetCornerCoords(e: Pair; cv: LR4.T) = BEGIN c[OrgV(e).num] := cv; END SetCornerCoords; PROCEDURE SetCoordinatesPrimal(a: Pair; READONLY o: LR4.T) = (* Set the vertex coordinates along the primal edge of topological tetrahedron. *) PROCEDURE SetVertexCoords(e: Pair; x: LONGREAL) = BEGIN c[OrgV(e).num] := LR4.T{o[0], o[1]+x, o[2]+x, o[3]}; END SetVertexCoords; BEGIN FOR i := 1 TO order-1 DO a := Clock(Enext_1(Fnext(Enext(a)))); SetVertexCoords(a,FLOAT(i,LONGREAL)*1.0d0/FLOAT(order,LONGREAL)); END; END SetCoordinatesPrimal; PROCEDURE SetCoordinatesDual(a: Pair; READONLY o: LR4.T) = (* Set the vertex coordinates along the dual edge of topological tetrahedron. *) PROCEDURE SetVertexCoords(e: Pair; x: LONGREAL) = BEGIN c[OrgV(e).num] := LR4.T{o[0], o[1]+x, o[2]-x, o[3]}; END SetVertexCoords; BEGIN FOR i := 1 TO order-1 DO a := Clock(Enext_1(Fnext(Enext(a)))); SetVertexCoords(a,FLOAT(i,LONGREAL)*1.0d0/FLOAT(order,LONGREAL)); END; END SetCoordinatesDual; BEGIN (* Set the corners *) SetCornerCoords(ca[0],o1); SetCornerCoords(ca[3],o2); SetCornerCoords(ca[4],o3); SetCornerCoords(ca[6],o4); SetCoordinatesPrimal(ca[0], o1); SetCoordinatesDual(ca[3], o2); END; RETURN r END END ComputeCoordinates; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-gridOrder"); o.gridOrder := pp.getNextInt(1, 20); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: MakeRawTetra -gridOrder \n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN Main(); END MakeRawTetra. (**************************************************************************) (* *) (* Copyright (C) 1999 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/MakeVStar.m3 MODULE MakeVStar EXPORTS Main; (* Generates ".tp",".tb",".ma" and ".st" files for some simples, triangulated and regular Polyhedrons in R^{4}. The vertex coordinates are random numbers in [-1..+1]. *) IMPORT ParseParams, Text, Octf, Triangulation, Wr, Stdio, Thread, Process, Mis, VStar, R3; FROM Octf IMPORT Enext_1, Enext, Fnext, Clock; FROM Stdio IMPORT stderr; FROM Triangulation IMPORT Pair, Topology, Ppos, Pneg, OrgV; TYPE Shape = { sh_4_vstar, sh_8_vstar, sh_20_vstar, sh_60_vstar }; Options = RECORD shape: Shape; shapeName: TEXT; END; PROCEDURE DoIt() = BEGIN WITH o = GetOptions(), m = MakePoly(o.shape), t = Triangulation.MakeTopology(m), c = Triangulation.GenCoords(t)^ DO (* setting the "root" attribute for faces and edges. *) FOR i := 0 TO t.NF-1 DO WITH f = t.face[i] DO f.root := f.num; END END; FOR i := 0 TO t.NE-1 DO WITH e = t.edge[i] DO e.root := e.num; END END; SetElemProperties(t); Triangulation.WriteTopology( o.shapeName, t, "Created by MakeVStar: " & o.shapeName & ".tp on " & Mis.Today() ); Triangulation.WriteState( o.shapeName, t, c,"Created by MakeVStar: " & o.shapeName & ".st on " & Mis.Today() & "\nRandom Geometry" ); Triangulation.WriteMaterials( o.shapeName, t,"Created by MakeVStar: " & o.shapeName & ".ma on " & Mis.Today() ); END END DoIt; PROCEDURE MakePoly(shape: Shape): Pair = BEGIN CASE shape OF | Shape.sh_4_vstar => RETURN Make_4_vstar(); | Shape.sh_8_vstar => RETURN Make_8_vstar(); | Shape.sh_20_vstar => RETURN Make_20_vstar(); | Shape.sh_60_vstar => RETURN Make_60_vstar(); END END MakePoly; (* Shape builders: *) PROCEDURE Make_4_vstar(): Pair = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(stderr, "Building topology of 4_vstar" & "\n"); RETURN VStar.MakeTetrahedronTriang()[0]; END Make_4_vstar; PROCEDURE Make_20_vstar() : Pair = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(stderr, "Building Topology of an 20_vstar: \n"); WITH ico = VStar.MakeIcosahedronTriang() DO RETURN ico[10]; END END Make_20_vstar; PROCEDURE Make_8_vstar() : Pair = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(stderr, "Building Topology of an 8_vstar: \n"); WITH oct = VStar.MakeOctahedronTriang() (* true for emphasize the origial elements *) DO RETURN oct[0]; END END Make_8_vstar; PROCEDURE Make_60_vstar() : Pair = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH dode = VStar.MakeDodecahedronTriang() (* true for emphasize the origial elements *) DO (* safety tests *) FOR i := 0 TO 11 DO WITH a = dode[i,0] DO IF Octf.SpinBit(a) = 0 THEN FOR j := 1 TO 4 DO <* ASSERT dode[i,j] = Clock(Enext(Fnext(Enext_1(dode[i,j-1])))) *> END; <* ASSERT dode[i,0] = Clock(Enext(Fnext(Enext_1(dode[i,4])))) *> ELSIF Octf.SpinBit(a) = 1 THEN FOR j := 1 TO 4 DO <* ASSERT dode[i,j] = Clock(Enext_1(Fnext(Enext(dode[i,j-1])))) *> END; <* ASSERT dode[i,0] = Clock(Enext_1(Fnext(Enext(dode[i,4])))) *> END END END; (* end safety tests *) Wr.PutText(stderr, "Building topology of an 60_vstar (version 1): \n"); RETURN dode[11,0]; END END Make_60_vstar; (* Procedures to set element properties *) PROCEDURE SetElemProperties(READONLY top: Topology) = VAR b: Pair; BEGIN FOR i := 0 TO top.NV-1 DO SetVertexProperties(top.out[i], border := FALSE) END; FOR i := 0 TO top.NE-1 DO SetEdgeProperties(top.edge[i].pa, border := FALSE) END; FOR i := 0 TO top.NF-1 DO SetFaceProperties(top.face[i].pa, border := FALSE); WITH a = top.face[i].pa DO IF (Ppos(a) = NIL) OR (Pneg(a) = NIL) THEN SetFaceProperties(a, TRUE); SetVertexProperties(a, border := TRUE); SetEdgeProperties(a, border := TRUE); b := a; REPEAT SetVertexProperties(b, border := TRUE); SetEdgeProperties(b, border := TRUE); b := Enext(b) UNTIL b = a; END; END; END END SetElemProperties; PROCEDURE SetFaceProperties(b: Pair; border: BOOLEAN) = (* Set face properties according to internal/border. *) BEGIN WITH t = NARROW(b.facetedge.face, Triangulation.Face) DO IF border THEN t.color := R3.T{1.00, 0.75, 0.20}; t.transp := R3.T{0.90, 0.90, 0.90}; ELSE t.color := R3.T{0.90, 1.00, 0.20}; t.transp := R3.T{0.95, 0.95, 0.95}; END; END END SetFaceProperties; PROCEDURE SetEdgeProperties(a: Pair; border: BOOLEAN) = (* Set the material proeprties for an edge according to internal/border. *) BEGIN WITH e = NARROW(a.facetedge.edge, Triangulation.Edge) DO IF border THEN e.color := R3.T{0.000, 0.000, 0.000}; e.transp := R3.T{0.000, 0.000, 0.000}; e.radius := 0.0075 ELSE e.color := R3.T{0.333, 0.333, 0.333}; e.transp := R3.T{0.000, 0.000, 0.000}; e.radius := 0.0050; END END END SetEdgeProperties; PROCEDURE SetVertexProperties(a: Pair; border: BOOLEAN) = (* Set the vertex material properties. *) BEGIN WITH v = OrgV(a) DO IF border THEN v.radius := 0.015; v.color := R3.T{0.000, 0.000, 0.000} ELSE v.radius := 0.025; v.color := R3.T{0.333, 0.333, 0.333} END END END SetVertexProperties; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-shape"); o.shapeName := pp.getNext(); IF Text.Equal(o.shapeName, "4-vstar") THEN o.shape := Shape.sh_4_vstar ELSIF Text.Equal(o.shapeName, "8-vstar") THEN o.shape := Shape.sh_8_vstar ELSIF Text.Equal(o.shapeName, "20-vstar") THEN o.shape := Shape.sh_20_vstar ELSIF Text.Equal(o.shapeName, "60-vstar") THEN o.shape := Shape.sh_60_vstar ELSE pp.error("Bad shape \"" & pp.getNext() & "\"\n") END; pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: MakeVStar \\\n"); Wr.PutText(stderr, " -shape { 4-vstar | 8-vstar | 20-vstar | 60-vstar }\n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt(); END MakeVStar. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/MatrixRotation.m3 MODULE MatrixRotation EXPORTS Main; IMPORT Stdio, Thread, Scan, Rd, FloatMode, Lex, Fmt, LR4x4, LR3Extras, LR4, LR3, Wr; FROM Stdio IMPORT stderr; <* FATAL Wr.Failure, Thread.Alerted, Rd.Failure, FloatMode.Trap, Lex.Error, Rd.EndOfFile *> TYPE Row = ARRAY[0..3] OF LONGREAL; VAR U,V : LR3.T; CONST Identity = LR4x4.T{ Row{1.0d0, 0.0d0, 0.0d0, 0.0d0}, Row{0.0d0, 1.0d0, 0.0d0, 0.0d0}, Row{0.0d0, 0.0d0, 1.0d0, 0.0d0}, Row{0.0d0, 0.0d0, 0.0d0, 1.0d0} }; IdentityN = LR4x4.T{ Row{-1.0d0, 0.0d0, 0.0d0, 0.0d0}, Row{ 0.0d0,-1.0d0, 0.0d0, 0.0d0}, Row{ 0.0d0, 0.0d0,-1.0d0, 0.0d0}, Row{ 0.0d0, 0.0d0, 0.0d0, 1.0d0} }; PROCEDURE WriteLong(wr: Wr.T; x: LONGREAL) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(wr, Fmt.Pad(Fmt.LongReal(x, Fmt.Style.Fix, prec := 4), 8)); END WriteLong; PROCEDURE ReadLong() : LONGREAL = BEGIN RETURN Scan.LongReal(Rd.GetLine(Stdio.stdin)); END ReadLong; PROCEDURE ComputeMatrixRotation(READONLY u,v: LR3.T) : LR4x4.T = BEGIN WITH x = LR3.T{1.0d0,0.0d0,0.0d0}, uu = LR3.Dir(LR3.Sub(v,u)) DO IF LR3.Dist(uu,x) <= 0.0d00001 THEN RETURN Identity; ELSE WITH vv = LR3.Dir(LR3Extras.Cross(x,uu)), ww = LR3.Dir(LR3Extras.Cross(uu,vv)) DO RETURN LR4x4.T{ LR4.T{ uu[0], uu[1], uu[2], 0.0d0}, LR4.T{ vv[0], vv[1], vv[2], 0.0d0}, LR4.T{ ww[0], ww[1], ww[2], 0.0d0}, LR4.T{ 0.0d0, 0.0d0, 0.0d0, 1.0d0} }; END END END END ComputeMatrixRotation; <* UNUSED *> PROCEDURE ComputeInverse(READONLY m: LR4x4.T) : LR4x4.T = BEGIN RETURN LR4x4.Inv(m); END ComputeInverse; BEGIN Wr.PutText(stderr,"Input the U point (one component by line)\n\n"); Wr.PutText(stderr,"U\n"); FOR i := 0 TO 2 DO U[i] := ReadLong(); END; Wr.PutText(stderr, "Input the V point\n\n"); Wr.PutText(stderr, "V\n"); FOR i := 0 TO 2 DO V[i] := ReadLong(); END; WITH matrix = ComputeMatrixRotation(U,V) DO Wr.PutText(stderr, "Matrix\n"); FOR i := 0 TO 3 DO FOR j := 0 TO 3 DO WriteLong(stderr, matrix[i,j]); END; Wr.PutText(stderr,"\n"); END; Wr.PutText(stderr,"\n"); END END MatrixRotation. (* Input the U point (one component by line) U 1 1 0 Input the V point V 2 2 0 Matrix 0.7071 -0.7071 -0.0000 0.0000 0.7071 0.7071 0.0000 0.0000 0.0000 -0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 1.0000 Input the U point (one component by line) U 0 1 1 Input the V point V 0 2 2 Matrix 1.0000 -0.0000 -0.0000 0.0000 0.0000 0.7071 0.7071 0.0000 0.0000 -0.7071 0.7071 0.0000 0.0000 0.0000 0.0000 1.0000 Input the U point (one component by line) U 1 0 1 Input the V point V 2 0 2 Matrix 0.7071 -0.0000 -0.7071 0.0000 0.7071 0.0000 0.7071 0.0000 0.0000 -1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 *) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/NewExplode.m3 MODULE NewExplode EXPORTS Main; (* This program recieves as input a triangulated tetrahedron of order $k$ (produced by the BuildRefinement program) and drawing it in explode way. Created on 26-12-2000 by lozada *) IMPORT Thread, Wr, Process, Triangulation, ParseParams, R3, FileWr, LR3, Tridimensional, OSError; FROM Stdio IMPORT stderr; FROM Pov IMPORT WritePOVCylinder, WritePOVTriangle, WritePOVSphere; FROM Wr IMPORT PutText; FROM Octf IMPORT Tors; FROM Triangulation IMPORT TetraNegVertices; TYPE Options = RECORD inFileTp: TEXT; (* Input file name (minus ".tp" extension) *) inFileSt3: TEXT; (* Input file name (minus ".st3" extension) *) outFile: TEXT; (* Output file name prefix *) opacity : REAL; (* opacity factor *) radius : REAL; (* radius drawing *) factor : LONGREAL; END; PROCEDURE DoIt() = <* FATAL OSError.E *> BEGIN WITH o = GetOptions(), inc = FileWr.Open(o.outFile & "-Ex.inc"), tc = Triangulation.ReadToMa(o.inFileTp), top = tc.top, rc = Tridimensional.ReadState3D(o.inFileSt3), c = rc^ DO FOR i := 0 TO top.NP-1 DO WITH r = top.region[i], a = Tors(r), pi = TetraNegVertices(a), (* vertices *) c0 = c[pi[0].num], c1 = c[pi[1].num], c2 = c[pi[2].num], c3 = c[pi[3].num], inv = o.factor/10.0d0, bar = LR3.Scale(1.0d0/inv, LR3.Add(LR3.Add(LR3.Add(c0,c1),c2),c3) ), (* adjusting to the barycenter tetrahedron *) ue3 = LR3.Add(c0,bar), ve3 = LR3.Add(c1,bar), we3 = LR3.Add(c2,bar), xe3 = LR3.Add(c3,bar), ra = o.radius, cf = R3.T{1.000, 1.000, 1.000}, ce = R3.T{0.0,0.0,0.0}, tr = o.opacity DO (* Drawing cylinders *) WritePOVCylinder(inc,ue3,ve3,ra,ce,0.0,TRUE); WritePOVCylinder(inc,ve3,we3,ra,ce,0.0,TRUE); WritePOVCylinder(inc,ue3,we3,ra,ce,0.0,TRUE); WritePOVCylinder(inc,ue3,xe3,ra,ce,0.0,TRUE); WritePOVCylinder(inc,ve3,xe3,ra,ce,0.0,TRUE); WritePOVCylinder(inc,we3,xe3,ra,ce,0.0,TRUE); (* Drawing triangles *) WritePOVTriangle(inc,ue3,ve3,we3,cf,tr,TRUE); WritePOVTriangle(inc,ue3,ve3,xe3,cf,tr,TRUE); WritePOVTriangle(inc,ve3,we3,xe3,cf,tr,TRUE); WritePOVTriangle(inc,ue3,we3,xe3,cf,tr,TRUE); (* Drawing spheres *) WritePOVSphere(inc,ue3,ra,ce,0.0,TRUE); WritePOVSphere(inc,ve3,ra,ce,0.0,TRUE); WritePOVSphere(inc,we3,ra,ce,0.0,TRUE); WritePOVSphere(inc,xe3,ra,ce,0.0,TRUE); END END END END DoIt; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFileTp"); o.inFileTp := pp.getNext(); pp.getKeyword("-inFileSt3"); o.inFileSt3 := pp.getNext(); pp.getKeyword("-outFile"); o.outFile := pp.getNext(); IF pp.keywordPresent("-opacity") THEN o.opacity := pp.getNextReal(0.0, 1.0); ELSE o.opacity := 0.65; END; IF pp.keywordPresent("-radius") THEN o.radius := pp.getNextReal(0.0, 0.1); ELSE o.radius := 0.005; END; IF pp.keywordPresent("-factor") THEN o.factor := pp.getNextLongReal(0.0d0, 100.0d0); END; pp.finish(); EXCEPT | ParseParams.Error => PutText(stderr, "Usage: NewExplode \\\n"); PutText(stderr, " -inFileTp \\\n"); PutText(stderr, " -inFileSt3 \\\n"); PutText(stderr, " -outFile \\\n"); PutText(stderr, " [-opacity ] [-radius \n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt() END NewExplode. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/OptShape.m3 MODULE OptShape EXPORTS Main; (* Adjusts the vertex coordinates of a triangulation so as to minimize some energy function. Created 1994 by Rober Marcone Rosi and J.Stolfi. *) IMPORT Wr, FileWr, Text, TextWr, OSError, Fmt, Process, Thread, ParseParams, Stdio, LR3, LR4, LR4Extras, Octf; IMPORT LRN, Math, CPUTime; IMPORT ParseEnergyParams, ParseMinimizerParams; IMPORT Energy, MixedEnergy, Triangulation; IMPORT Minimizer; IMPORT ScreenPlot; FROM Tridimensional IMPORT Coords3D; FROM Triangulation IMPORT Coords, Topology, OrgV; FROM Energy IMPORT Gradient; FROM Stdio IMPORT stderr; FROM Wr IMPORT PutText; FROM Octf IMPORT Clock; IMPORT Debug; CONST Epsilon = 0.0000000001d0; (* aditional constants for 4D *) From4 = LR4.T{0.0d0,0.0d0,0.0d0,-3.0d0}; (* 4D viewing parameter as *) To4 = LR4.T{0.0d0,0.0d0,0.0d0,0.0d0}; (* expected by the "Wire4" *) Up4 = LR4.T{0.0d0,1.0d0,0.0d0,0.0d0}; (* Interactive 4D Wireframe *) Over4 = LR4.T{0.0d0,0.0d0,1.0d0,0.0d0}; (* Display Program. *) VAR Wa,Wb,Wc,Wd: LR4.T; (* the 4 basis vectors for the 4D viewing matrix *) Data4Radius := 0.0d0; (* radius of the 4D data *) improvements,writestep: CARDINAL := 1; writetime: LONGREAL := 0.0d0; TYPE Options = RECORD inFileTp: TEXT; (* Initial guess file name (minus ".tp") *) inFileSt: TEXT; (* Initial guess file name (minus ".st") *) outFile: TEXT; (* Output file name prefix *) eFunction: MixedEnergy.T; (* Energy Mixed function to minimize *) minimizer: Minimizer.T; (* Algorithm Minimization method to use *) nPasses: CARD; (* Number Of minimization passes *) maxEvals: CARD; (* Max energy evaluations per pass *) verticesPerPass: CARD; (* Max vertices top optimize in each pass *) only3D : BOOLEAN; (* TRUE=constrains the model to R^{3} *) writeEvery: CARD; (* When to write ".std" file *) printEvery: CARD; (* Print energies every this many steps. *) showAll: BOOL; (* TRUE to display after each pass. *) showBest: BOOL; (* TRUE to display only the best conf so far.*) wait: BOOL; (* TRUE to wait for mouse click af each pass *) scale: LONG; (* set the scale for the visualization proc. *) complete: BOOLEAN; (* for compute overall files *) END; EvalRec = RECORD (* A Record of energy data: *) c: REF Coords; (* Pointer to Vertex coordinates *) e: LONGREAL; (* Total energy *) termValue: REF LONGS; (* Pointer to Unweighted energy terms *) eDc: REF Gradient (* Pointer to Gradient of total energy "e" r.to "c"*) END; LONG = LONGREAL; LONGS = ARRAY OF LONGREAL; BOOL = BOOLEAN; BOOLS = ARRAY OF BOOLEAN; CARD = CARDINAL; CARDS = ARRAY OF CARDINAL; PROCEDURE DoIt() = <* FATAL OSError.E, Thread.Alerted, Wr.Failure *> BEGIN (* compute the 4D viewing matrix *) CalcV4Matrix(); WITH o = GetOptions(), tc = Triangulation.ReadToMa(o.inFileTp), rc = Triangulation.ReadState(o.inFileSt) DO PutText(stderr, "Optimizing from: " & o.inFileTp & ".tp\n"); IF o.complete THEN WITH gnuWr = FileWr.Open(o.outFile & ".gnu") DO WriteGNUPlotCommands(gnuWr, o.outFile, o.eFunction.term^); Wr.Close(gnuWr) END END; IF o.only3D THEN FOR v := 0 TO LAST(rc^) DO rc[v,3] := 0.0d0; END END; WITH plotWr = FileWr.Open(o.outFile & ".plot") DO IF o.complete THEN WritePlotComments(plotWr, o.eFunction, o.minimizer); WritePlotHeader(plotWr, o.eFunction.term^); END; IF o.printEvery < LAST(CARD) THEN WritePlotHeader(stderr, o.eFunction.term^); END; Minimize( tc, rc, o.minimizer, o.eFunction, nPasses := o.nPasses, maxEvals := o.maxEvals, verticesPerPass := o.verticesPerPass, only3D := o.only3D, writeEvery := o.writeEvery, printEvery := o.printEvery, inFile := o.inFileTp, outFile := o.outFile, plotWr := plotWr, showAll := o.showAll, showBest := o.showBest, wait := o.wait, scale := o.scale, complete := o.complete ); Wr.Close(plotWr) END END END DoIt; PROCEDURE Minimize( READONLY tc: Triangulation.TopCom; READONLY rc: REF Coords; m: Minimizer.T; (* Minimization method *) e: MixedEnergy.T; (* Mixed Energy function *) nPasses: CARD; (* number of passes *) maxEvals: CARD; (* Evaluation budget per vertex minimization *) verticesPerPass:CARD; (* Min. this at most this many vertices per pass *) only3D: BOOLEAN; (* TRUE=constrains the model to R^{3} *) writeEvery: CARDINAL; (* When to write ".top" file *) printEvery: CARDINAL; (* Print energies every thsi many steps. *) outFile: TEXT; (* output file name prefix *) inFile:TEXT; (* input file name prefix *) plotWr: Wr.T; (* Energy plots *) showAll: BOOL; (* TRUE to display after each eval. *) showBest: BOOL; (* TRUE to display only the best config so far. *) wait: BOOL; (* TRUE to wait for user clicks at each pass *) scale: LONG; (* set the scale for the visualization proc. *) complete: BOOL; (* TRUE to wait for user clicks at each pass *) ) = (* Minimization consists of "nPasses" passes, each starting at the best configuration found in the the previous pass, and budgeted for "maxEvals" energy evaluations. At each pass, up to "verticesPerPass" vertices are selected (in a round-robin fashion) to be optimized, while the rest is held fixed. *) VAR totEvals: CARD := 0; (* Count calls to "e.eval". *) cpuTime: LONG := 0.0d0; (* Accum minimization CPU time, seconds.*) cpuWhen: LONG := 0.0d0; (* When minimization was (re)started. *) passCt: CARD; (* Counts optimization passes. *) window: ScreenPlot.T; (* The optimization movie. *) nextVertex: CARD := 0; (* Next vertex to optimize *) BEGIN WITH top = tc.top, NV = top.NV, NT = NUMBER(e.term^), rMin = NewEvalRec(NV, NT)^, (* Best configuration found so far. Minimun Configuration *) variable = VariableVertices(top)^, (* Oficially variable vertices *) NB = CountTrue(variable), (* Number of variable vertices *) NS = MIN(NB, verticesPerPass), (* Num of vert.to opt. per pass. *) NC = 4*NS, (* Num of variables to optimize. *) selected = NEW(REF BOOLS, NV)^, (* Vertices being minimized *) (* The following are work areas for "DoMinimizeStep": *) rWork = NewEvalRec(NV, NT)^, (* Probe configuration *) cIndex = NEW(REF CARDS, NC)^, (* Maps minimizer vars to coords *) xm = NEW(REF Minimizer.Point, 4*NV)^,(* Argument vector for min. *) fm = NEW(REF Minimizer.Value)^, (* Function value for minimizer *) gm = NEW(REF Minimizer.Gradient, 4*NV)^, (* Gradient for minimizer *) (* Used by "ReportEval: *) minComment = "energy function: " & e.name() & "\n" & "minimizer: " & m.name() & "\n" & "minimization passes = " & Fmt.Int(nPasses) & "\n" & "vertices per pass = " & Fmt.Int(verticesPerPass) & "\n" & "max evals per pass = " & Fmt.Int(totEvals) & "\n" & "---------------------------------------" & "---------------------------------------\n" & "\nOptimized from: " & inFile & ".tp\n" & "\nCreated by OptShape: " & outFile & "\n" DO (* Create the plot window: *) IF showAll OR showBest THEN WITH c3D = ProjectTo3D(top,rc^,scale) DO window := MakeWindow(top,c3D^); END END; (* Start the clock: *) cpuWhen := CPUTime.Now(); (* Tell the energy function what topology we are evaluationg: *) e.defTop(tc.top); (* Tell the minimizer how many variables are we going to minimize over; *) EVAL m.setSize(NC); (* Initialize the minimum configuration: *) rMin.c^ := rc^; passCt := 0; LOOP (* Do a full evaluation once in a while, to get the total energy right. Ideally, a full evaluation should be necessary only once at the beginning, but doing it at every pass reduces the effect of rounding errors, and and provides a good check against programming errors. *) VAR eOld: LONG := rMin.e; BEGIN FOR v := 0 TO NV-1 DO selected[v] := TRUE END; e.defVar(variable); e.eval(rMin.c^, rMin.e, FALSE, rMin.eDc^); INC(totEvals); rMin.termValue^ := e.termValue^; (* Stop the clock: *) cpuTime := cpuTime + (CPUTime.Now() - cpuWhen); IF passCt # 0 AND rMin.e - eOld > 1.0d-6 * MAX(ABS(rMin.e), ABS(eOld)) THEN Debug.Line("pass = " & Fmt.Int(passCt DIV NV)); Debug.LongReal("energy discrepancy = ", LRN.T{rMin.e - eOld}); Debug.Line("") END; ReportConfiguration(outFile, top,plotWr, window, showAll, showBest, wait, cpuTime, totEvals, passCt, nPasses, writeEvery, printEvery, selected, rMin, rMin, e, minComment,scale,complete ); IF passCt = 0 OR passCt = nPasses THEN (* Write configuration as ".tp": *) WITH name = outFile & ARRAY BOOL OF TEXT{"-initial", "-final"}[passCt >= nPasses] DO WriteConfiguration( name, top, e, rMin, cpuTime := cpuTime, totEvals := totEvals, passCt := passCt, comment := minComment ) END END; (* Restart the clock: *) cpuWhen := CPUTime.Now(); END; IF passCt >= nPasses THEN EXIT END; (* Select the vertices to optimize: *) <* ASSERT NS <= NB *> IF NS = NB THEN <* ASSERT nextVertex = 0 *> END; FOR v := 0 TO NV-1 DO selected[v] := FALSE END; VAR k: CARD := 0; BEGIN WHILE k < NS DO WITH v = nextVertex DO IF variable[v] THEN selected[v] := TRUE; cIndex[4*k+0] := 4*v+0; cIndex[4*k+1] := 4*v+1; cIndex[4*k+2] := 4*v+2; cIndex[4*k+3] := 4*v+3; INC(k) END; nextVertex := (v + 1) MOD NV END END; <* ASSERT k=NS *> END; <* ASSERT CountTrue(selected) = NS *> PROCEDURE ReportEval(READONLY rWork, rMin: EvalRec) = BEGIN (* Stop the clock: *) cpuTime := cpuTime + (CPUTime.Now() - cpuWhen); INC (totEvals); ReportConfiguration(outFile, top,plotWr, window, showAll, showBest, wait, cpuTime, totEvals, passCt, nPasses, writeEvery, printEvery, selected, rWork, rMin, e, minComment,scale,complete ); (* Restart the clock: *) cpuWhen := CPUTime.Now(); END ReportEval; BEGIN (* Start the clock: *) cpuWhen := CPUTime.Now(); e.defVar(selected); DoMinimizeStep( m, e, rMin, cIndex := SUBARRAY(cIndex, 0, NC), maxEvals := maxEvals, only3D := only3D, reportEval := ReportEval, rWork := rWork, xm := SUBARRAY(xm, 0, NC), fm := fm, gm := SUBARRAY(gm, 0, NC) ) END; INC(passCt) END (*LOOP*); (* Stop the clock: *) cpuTime := cpuTime + (CPUTime.Now() - cpuWhen); (* Return minimum: *) rc^ := rMin.c^ END END Minimize; PROCEDURE ReportConfiguration( outFile: TEXT; (* output file name prefix *) READONLY top: Topology; plotWr: Wr.T; (* Energy plot file *) window: ScreenPlot.T; (* Dynamic display window *) showAll: BOOL; (* TRUE to show all on "window" *) showBest: BOOL; (* T. to show only best config so far on screen*) wait: BOOL; (* TRUE to wait for user click *) cpuTime: LONGREAL; (* Accumulated minimization CPU time so far *) totEvals: CARD; (* Accumulated energy evaluations so far *) passCt: CARD; (* Passes completed so far *) <*UNUSED*>nPasses: CARD; (* Max passes to perform *) <*UNUSED*>writeEvery:CARD;(* When to write the ".st" file. *) printEvery: CARDINAL; (* Print energies every this many steps. *) READONLY selected: BOOLS; (* Vertices that are or were selected for opt. *) READONLY rWork: EvalRec; (* Last evaluated configuration *) READONLY rMin: EvalRec; (* Best configuration found so far *) e: MixedEnergy.T; (* The energy function *) minComment: TEXT; (* Comment for ".top" and ".st" files *) scale: LONG; (* set the scale for the visualization proc. *) complete: BOOLEAN; ) = BEGIN IF complete THEN PlotEnergy(plotWr, cpuTime, totEvals, passCt, rWork, e.weight^); END; IF totEvals MOD printEvery = 0 THEN PlotEnergy(stderr, cpuTime, totEvals, passCt, rMin, e.weight^) END; (* improvements for iterations *) IF improvements >= 10 * writestep THEN writestep := 10 * writestep END; IF (improvements MOD writestep) = 0 AND complete THEN WITH name = outFile & "-" & Fmt.Int(improvements) & "-e" DO WriteConfiguration( name, top, e, rMin, cpuTime := cpuTime, totEvals := totEvals, passCt := passCt, comment := ARRAY BOOL OF TEXT{"", minComment}[passCt = 0] ); END END; INC(improvements); IF(writetime-2.0d0 * FLOAT(ROUND(writetime) DIV 2,LONG) <= 0.005d0) AND complete THEN (* improvements for cpu time *) WITH name = outFile & "-" & Fmt.Pad(Fmt.LongReal(cpuTime,Fmt.Style.Fix,prec:=2),5,'0') & "-t" DO WriteConfiguration( name, top, e, rMin, cpuTime := cpuTime, totEvals := totEvals, passCt := passCt, comment := ARRAY BOOL OF TEXT{"", minComment}[passCt = 0] ); END END; writetime := cpuTime; IF showAll OR (showBest AND rWork.e = rMin.e) THEN WITH c3D = ProjectTo3D(top,rWork.c^,scale) (*, name = outFile & "-" & Fmt.Int(improvements) *) DO DisplayConfiguration(window, c3D^, selected, wait); (*WriteConfigurationToOpenGL(top, c3D^);*) (* here display the 3D configuration with OpenGL routines *) (* testing IF improvements >= 10 * writestep THEN writestep := 10 * writestep END; IF (improvements MOD writestep) = 0 THEN WriteConfigurationToOpenGL(top, c3D^, name); END *) END END; END ReportConfiguration; PROCEDURE VariableVertices(READONLY top: Topology): REF BOOLS = (* Basically, set "vVar[v.num]:=TRUE" iff vertex "v" exists and aren't fixed. I can set this boolean vector. *) BEGIN WITH r = NEW(REF BOOLS, top.NV) DO Triangulation.GetVariableVertices(top, r^); RETURN r END END VariableVertices; PROCEDURE NewEvalRec(NV, NT: CARDINAL): REF EvalRec = BEGIN WITH r = NEW(REF EvalRec) DO r^ := EvalRec{ c := NEW(REF Coords, NV), e := 0.0d0, termValue := NEW(REF LONGS, NT), eDc := NEW(REF Gradient, NV) }; RETURN r END END NewEvalRec; TYPE ReportEvalProc = PROCEDURE (READONLY rWork, rMin: EvalRec); PROCEDURE DoMinimizeStep( m: Minimizer.T; (* Minimization method *) e: MixedEnergy.T; (* Energy function *) VAR rMin: EvalRec; (* In: initial guess, Out: minimum *) READONLY cIndex: CARDS; (* Maps minimizer args to vertex coords *) maxEvals: CARDINAL; (* Evaluation budget *) only3D : BOOLEAN; (* TRUE=constrains the model to R^{3} *) reportEval: ReportEvalProc; (* Called after every energy evaluation *) (* Work areas: *) VAR rWork: EvalRec; (* Probe configuration *) VAR xm: Minimizer.Point; (* Argument vector for minimizer *) VAR fm: Minimizer.Value; (* Function value for minimizer *) VAR gm: Minimizer.Gradient; (* Gradient vector for minimizer *) ) = (* Performs an energy minimization for the vertices defined by the "cIndex" vector. Assumes that "m.setSize", "e.setTop", "e.setVar" have already been called. *) BEGIN WITH NT = NUMBER(e.term^), NC = NUMBER(cIndex), grad = m.needsGradient(), (* TRUE to compute gradients *) eOffset = NEW(REF LONGREAL)^, (* "eval(variable)-eval(selected)" *) termOffset = NEW(REF LONGS, NT)^, (* Unweigthed terms of "eOffset" *) cMin = rMin.c^, eMin = rMin.e, eDcMin = rMin.eDc^, termMin = rMin.termValue^, cWork = rWork.c^, eWork = rWork.e, eDcWork = rWork.eDc^, termWork = rWork.termValue^ DO PROCEDURE Initialize( VAR x: Minimizer.Point; VAR f: Minimizer.Value; VAR g: Minimizer.Gradient ) = BEGIN cWork := cMin; e.eval(cWork, eWork, grad, eDcWork); termWork := e.termValue^; (* Save offsets between full and partial evaluations: *) eOffset := eMin - eWork; eWork := eMin; FOR t := 0 TO NT-1 DO termOffset[t] := termMin[t] - termWork[t]; END; termWork := termMin; reportEval(rWork, rMin); (* Set function and gradient: *) f := eWork + eOffset; FOR i := 0 TO LAST(x) DO WITH vk = cIndex[i], v = vk DIV 4, k = vk MOD 4 DO x[i] := cWork[v][k]; IF k = 3 AND only3D THEN g[i] := 0.0d0; <* ASSERT x[i] = 0.0d0 *> ELSE g[i] := eDcWork[v][k] END; END END; END Initialize; PROCEDURE Eval( READONLY x: Minimizer.Point; VAR f: Minimizer.Value; VAR g: Minimizer.Gradient ) = BEGIN (* Stuff the argument into the "cWork" vector: *) FOR i := 0 TO LAST(x) DO WITH vk = cIndex[i], v = vk DIV 4, k = vk MOD 4 DO cWork[v][k] := x[i]; END END; (* Evaluate the partial energy for "cWork": *) e.eval(cWork, eWork, grad, eDcWork); termWork := e.termValue^; (* Correct to full energy: *) eWork := eWork + eOffset; FOR t := 0 TO NT-1 DO termWork[t] := termWork[t] + termOffset[t] END; (* See if we got something good: *) IF eWork < eMin THEN eMin := eWork; cMin := cWork; eDcMin := eDcWork; termMin := termWork; END; reportEval(rWork, rMin); (* Return energy and gradient to optimizer: *) f := eWork; IF grad THEN FOR i := 0 TO LAST(g) DO WITH vk = cIndex[i], v = vk DIV 4, k = vk MOD 4 DO IF k = 3 AND only3D THEN g[i] := 0.0d0 ELSE g[i] := eDcWork[v][k] END; END END END; END Eval; (* Now do a partial one to get us started: *) BEGIN Initialize(xm, fm, gm); m.minimize( eval := Eval, x := xm, f := fm, g := gm, dist := Math.pow(FLOAT(NC,LONGREAL),1.0d0/3.0d0), (* dist=rough guess between the starting point and the optimun set *) tol := 0.05d0, (* upper bound tolerance for the size of the optimun set *) flat := 0.0d0, maxEvals := maxEvals ); (* Sanity check: *) IF fm # eMin THEN Debug.LongReal("** bug: fm, eMin = ", LRN.T{fm, eMin}) END; END END END DoMinimizeStep; PROCEDURE CountTrue(READONLY b: BOOLS): CARDINAL = VAR n: CARDINAL := 0; BEGIN FOR i := 0 TO LAST(b) DO IF b[i] THEN INC(n) END END; RETURN n END CountTrue; PROCEDURE MakeWindow( READONLY top: Topology; READONLY c3: Coords3D; ): ScreenPlot.T = BEGIN (* Allocate window for "2*NV+1" points: "[0..NV-1]" are the mesh vertices, "[NV..2*NV-1]" are the marks, "[2*NV]" is the origin. *) WITH NV = top.NV, NE = top.NE, NP = 2*NV + 1, w = NEW(ScreenPlot.T).init(NP), org = NP-1 DO w.pause(); w.setCoords(0, c3); (* Edges* *) FOR i := 0 TO NE-1 DO WITH e = top.edge[i], a = e.pa, u = OrgV(a).num, v = OrgV(Clock(a)).num DO w.segment(u, v, width := 0.0) END END; (* Vertex marks: *) FOR i := 0 TO NV-1 DO WITH p = NV+i DO w.setCoord(p, LR3.T{0.0d0, ..}); (* For the time being *) w.point(p, size := 5.0) END END; (* Origin: *) w.setCoord(org, LR3.T{0.0d0, ..}); (* For the time being *) w.point(org, size := 7.0); w.resume(); EVAL w.waitKey(); RETURN w END END MakeWindow; PROCEDURE DisplayConfiguration( w: ScreenPlot.T; READONLY c3: Coords3D; READONLY marked: BOOLS; wait: BOOL; ) = BEGIN WITH NV = NUMBER(c3), org = 2*NV DO w.pause(); w.setCoords(0, c3); (* Marked vertices: *) VAR p: CARD := NV; BEGIN FOR v := 0 TO NV-1 DO IF marked[v] THEN w.setCoord(p, c3[v]); INC(p) END END; WHILE p < org DO w.setCoord(p, LR3.T{0.0d0, ..}); INC(p) END; END; w.resume(); IF wait THEN EVAL w.waitKey() ELSE w.waitDone() END; END; END DisplayConfiguration; PROCEDURE WriteConfiguration( name: TEXT; READONLY top: Topology; e: MixedEnergy.T; READONLY r: EvalRec; cpuTime: CPUTime.T; totEvals: CARD; passCt: CARD; comment: TEXT; ) = BEGIN Triangulation.WriteState(name,top, r.c^, comments := comment & IterationComments(cpuTime, totEvals, passCt, r, e) & "\n"); END WriteConfiguration; PROCEDURE IterationComments( cpuTime: LONGREAL; READONLY totEvals: CARDINAL; READONLY step: CARDINAL; READONLY r: EvalRec; READONLY e: MixedEnergy.T; ): TEXT = BEGIN WITH wr = NEW(TextWr.T).init() DO WritePlotHeader(wr, e.term^); PlotEnergy(wr, cpuTime, totEvals, step, r, e.weight^); RETURN TextWr.ToText(wr) END END IterationComments; PROCEDURE PlotEnergy( wr: Wr.T; READONLY cpuTime: LONGREAL; READONLY totEvals: CARDINAL; READONLY step: CARDINAL; READONLY r: EvalRec; READONLY weight: ARRAY OF REAL; ) = <* FATAL Thread.Alerted, Wr.Failure *> BEGIN PutText(wr, " "); PutText(wr, Fmt.Pad(Fmt.LongReal(cpuTime,Fmt.Style.Fix, prec := 2), 8)); PutText(wr, " "); PutText(wr, Fmt.Pad(Fmt.Int(totEvals), 8)); PutText(wr, " "); PutText(wr, Fmt.Pad(Fmt.LongReal(r.e, Fmt.Style.Fix, 5), 12)); PutText(wr, " "); PutText(wr, Fmt.Pad(Fmt.Int(step), 8)); FOR i := 0 TO LAST(r.termValue^) DO PutText(wr, " "); WITH t = r.termValue[i] * FLOAT(weight[i], LONGREAL) DO PutText(wr, Fmt.Pad(Fmt.LongReal(t, Fmt.Style.Fix, 5), 12)) END; END; PutText(wr, "\n"); Wr.Flush(wr); END PlotEnergy; PROCEDURE WritePlotComments(wr: Wr.T; e: MixedEnergy.T; m: Minimizer.T) = <* FATAL Thread.Alerted, Wr.Failure *> BEGIN PutText(wr, "#"); PutText(wr, " energy function: " & e.name()); PutText(wr, "\n"); PutText(wr, "#"); PutText(wr, " minimizer: " & m.name()); PutText(wr, "\n"); Wr.Flush(wr); END WritePlotComments; PROCEDURE WritePlotHeader(wr: Wr.T; READONLY term: ARRAY OF Energy.T) = <* FATAL Thread.Alerted, Wr.Failure *> BEGIN PutText(wr, "#"); PutText(wr, Fmt.Pad("cpuTime", 8)); PutText(wr, " "); PutText(wr, Fmt.Pad("evals", 8)); PutText(wr, " "); PutText(wr, Fmt.Pad("energy", 12)); PutText(wr, " "); PutText(wr, Fmt.Pad("step", 8)); FOR i := 0 TO LAST(term) DO PutText(wr, " "); PutText(wr, Fmt.Pad(EnergyTag(term[i].name()), 12)); END; PutText(wr, "\n"); Wr.Flush(wr); END WritePlotHeader; PROCEDURE WriteGNUPlotCommands(wr: Wr.T; outFile: TEXT; READONLY term: ARRAY OF Energy.T ) = <* FATAL Thread.Alerted, Wr.Failure *> BEGIN PutText(wr, "set terminal X11\n"); (*PutText(wr, "set output \"" & outFile & ".tex\"\n");*) PutText(wr, "set xlabel \"Cpu-Time\"\n"); PutText(wr, "set ylabel \"Energy\"\n"); PutText(wr, "set title \"" & outFile & "\"\n"); PutText(wr, "plot \"" & outFile & ".plot\" using 1:3 title \"TotalE\" with lines, \\\n"); FOR i := 0 TO LAST(term) DO WITH col = i + 5 DO PutText(wr, " \"" & outFile & ".plot\" using 1:" & Fmt.Int(col) & " title \"" &EnergyTag(term[i].name()) & "\" with linespoints"); IF i < LAST(term) THEN PutText(wr, ", \\") END; PutText(wr, "\n"); END END; PutText(wr, "pause 30\n"); PutText(wr, "quit\n"); Wr.Flush(wr); END WriteGNUPlotCommands; PROCEDURE EnergyTag(name: TEXT): TEXT = BEGIN WITH n = Text.FindChar(name, '(') DO IF n = -1 THEN RETURN Text.Sub(name, 0, 8) ELSE RETURN Text.Sub(name, 0, MIN(n, 8)) END END END EnergyTag; PROCEDURE CalcV4Matrix() = (* This procedure computes the four basis vectors for the 4D viewing matrix, Wa,Wb,Wc, and Wd. Note that the Up vector transforms to Wb, the Over vector transforms to Wc, and the line of sight transforms to Wd. The Wa vector is then computed from Wb,Wc and Wd. *) <* FATAL Wr.Failure, Thread.Alerted *> BEGIN (* Calculate Wd, the 4th coordinate basis vector and line-of-sight. *) Wd := LR4.Sub(To4,From4); IF LR4.Norm(Wd) < Epsilon THEN PutText(stderr,"4D To Point and From Point are the same\n"); Process.Exit(1); END; Wd := LR4.Scale(1.0d0/LR4.Norm(Wd), Wd); (* Calculate Wa, the X-axis basis vector. *) Wa := LR4Extras.Cross(Up4,Over4,Wd); IF LR4.Norm(Wa) < Epsilon THEN PutText(stderr, "4D up, over and view vectors are not perpendicular\n"); Process.Exit(1); END; Wa := LR4.Scale(1.0d0/LR4.Norm(Wa), Wa); (* Calculate Wb, the perpendicularized Up vector. *) Wb := LR4Extras.Cross(Over4,Wd,Wa); IF LR4.Norm(Wb) < Epsilon THEN PutText(stderr,"Invalid 4D over vector\n"); Process.Exit(1); END; Wb := LR4.Scale(1.0d0/LR4.Norm(Wb), Wb); (* Calculate Wc, the perpendicularized Over vector. Note that the resulting vector is already normalized, since Wa, Wb and Wd are all unit vectors. *) Wc := LR4Extras.Cross(Wd,Wa,Wb); END CalcV4Matrix; PROCEDURE ProjectTo3D( READONLY top: Topology; READONLY c: Coords; scale: LONGREAL; ) : REF Coords3D = (* This procedure project all vertices of a configuration from R4 to R3, such that permit to create 3D coordinate needs for the "DisplayConfigura- tion" procedure. *) PROCEDURE ProjectVertexTo3D(co: LR4.T) : LR3.T = (* Project one 4D vertex to 3D. This projection is simples in the sense that only permit 4D parallel projection and not perspective. *) VAR c3 : LR3.T; BEGIN WITH TempV = LR4.Sub(co,From4), rtemp = 1.0d0/Data4Radius DO c3[0] := scale * rtemp * LR4.Dot(TempV, Wa); c3[1] := scale * rtemp * LR4.Dot(TempV, Wb); c3[2] := scale * rtemp * LR4.Dot(TempV, Wc); RETURN c3; END END ProjectVertexTo3D; PROCEDURE MaxRadius( READONLY top: Topology; READONLY c: Coords; READONLY ctr: LR4.T; ) = BEGIN FOR i := 0 TO top.NV-1 DO <* ASSERT OrgV(top.out[i]).num = i *> WITH v = OrgV(top.out[i]), Temp4 = LR4.Sub(c[v.num],ctr), dist = LR4.Dot(Temp4, Temp4) DO IF dist > Data4Radius THEN Data4Radius := dist END END END; END MaxRadius; VAR c3D : REF Coords3D; nc : CARDINAL := NUMBER(c); BEGIN MaxRadius(top,c,To4); c3D := NEW(REF Coords3D, nc); FOR i := 0 TO nc-1 DO c3D^[i] := ProjectVertexTo3D(c[i]); END; RETURN c3D END ProjectTo3D; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFileTp"); o.inFileTp := pp.getNext(); pp.getKeyword("-inFileSt"); o.inFileSt := pp.getNext(); pp.getKeyword("-outFile"); o.outFile := pp.getNext(); IF pp.keywordPresent("-nPasses") THEN o.nPasses := pp.getNextInt(1, 99999); ELSE o.nPasses := 1 END; pp.getKeyword("-maxEvals"); o.maxEvals := pp.getNextInt(1, 999999); IF o.nPasses > 1 THEN IF pp.keywordPresent("-verticesPerPass") THEN o.verticesPerPass := pp.getNextInt(1, LAST(CARD)); ELSE o.verticesPerPass := LAST(CARD) END ELSE o.verticesPerPass := LAST(CARD) END; IF pp.keywordPresent("-writeEvery") THEN o.writeEvery := pp.getNextInt(0, 1000000) ELSIF pp.keywordPresent("-writeAll") THEN o.writeEvery := 1 ELSE o.writeEvery := LAST(CARD) END; IF pp.keywordPresent("-printEvery") THEN o.printEvery := pp.getNextInt(0, 1000000) ELSE o.printEvery := LAST(CARD) END; o.showAll := pp.keywordPresent("-showAll"); o.showBest := (NOT o.showAll) AND pp.keywordPresent("-showBest"); IF o.showAll OR o.showBest THEN o.wait := pp.keywordPresent("-wait"); IF pp.keywordPresent("-scale") THEN o.scale := pp.getNextLongReal(0.10d0, 100.00d0); ELSE o.scale := 1.0d0; END; o.wait := FALSE; END; o.only3D := pp.keywordPresent("-only3D"); o.complete := pp.keywordPresent("-complete"); o.eFunction := ParseEnergyParams.Parse(pp); IF o.eFunction = NIL THEN pp.error("no energy specified") END; o.minimizer := ParseMinimizerParams.Parse(pp); IF o.minimizer = NIL THEN pp.error("no minimizer specified") END; pp.finish(); EXCEPT | ParseParams.Error => PutText(stderr,"Usage: \\\n"); PutText(stderr," OptShape -inFileTp \\\n"); PutText(stderr," -inFileSt -outFile \\\n"); PutText(stderr," -maxEvals \\\n"); PutText(stderr," [-nPasses [ -verticesPerPass ] ] [-only3D]\\\n"); PutText(stderr," [-writeEvery | -writeAll ] \\\n"); PutText(stderr," [-printEvery ] \\\n"); PutText(stderr," [ [ -showAll | -showBest ] [-wait] [-scale]\\\n"); PutText(stderr," [-complete ]\\\n"); PutText(stderr,ParseMinimizerParams.Help); PutText(stderr," \\\n"); PutText(stderr,ParseEnergyParams.Help); PutText(stderr,"\n"); Process.Exit(1); END END; RETURN o END GetOptions; BEGIN DoIt() END OptShape. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/ProjectTo3D.m3 MODULE ProjectTo3D EXPORTS Main; (* This program project one configuration 4D to 3D way the 4D viewing parameters as expected by the "Wire4" - Interactive 4D Wireframe Display Program. See the copyright and authorship futher down. Last modification: 25-02-2000 *) IMPORT Triangulation, ParseParams, Process, Wr, Thread, Text, Mis, LR4, LR4Extras, Math, Tridimensional, Fmt, Stat; FROM Stdio IMPORT stderr; FROM Octf IMPORT Tors, Clock, Enext, Enext_1, Fnext_1; FROM Triangulation IMPORT Topology, Org, OrgV, Ppos, Pneg, PnegP, Pair, TetraNegPosVertices; FROM Tridimensional IMPORT WriteState3D; CONST Epsilon = 0.0000000001d0; TYPE Coords4D = Triangulation.Coords; Coords3D = Tridimensional.Coords3D; Options = RECORD inFileTp: TEXT; inFileSt: TEXT; outFile: TEXT; oblique: BOOLEAN; (* TRUE = sets From4 at specified angle from mean normal. *) obliqueAngle: LONGREAL; (* (if "oblique") Angle between From4 and mean normal, or . *) adjustCenter: BOOLEAN; (* TRUE = translates the model to the origin before projection. *) adjustScale: BOOLEAN; (* TRUE = scales model so that it fits in a sphere of radius 1. *) perspective: BOOLEAN; (* TRUE = uses perspective projection. *) statistics: BOOLEAN; (* TRUE = shows model statistics. *) printDepth: BOOLEAN; (* TRUE = prints 4D depth of every vertex. *) (* 4D viewing parameters *) From4: LR4.T; (* Observer position in R^4. *) To4: LR4.T; (* Center of attention in R^4. *) Up4: LR4.T; (* Z coordinate of projection space. *) Over4: LR4.T; (* Y coordinate of projection space. *) Vangle4: LONGREAL; (* Viewing angle. *) END; <* FATAL Thread.Alerted, Wr.Failure *> PROCEDURE WL(x: LONGREAL) : TEXT = BEGIN RETURN(Fmt.Pad(Fmt.LongReal(x, Fmt.Style.Fix, prec := 4), 8)); END WL; PROCEDURE WL4(READONLY x: LR4.T) : TEXT = BEGIN RETURN WL(x[0]) & " " & WL(x[1]) & " " & WL(x[2]) & " " & WL(x[3]) END WL4; PROCEDURE DoIt() = VAR o: Options := GetOptions(); newcomments: TEXT; BEGIN Wr.PutText(stderr, "--------------------------------------------------\n"); WITH tc = Triangulation.ReadToMa(o.inFileTp), top = tc.top, rc = Triangulation.ReadState(o.inFileSt), c = rc^, rc3 = NEW(REF Tridimensional.Coords3D, top.NV), c3 = rc3^, comments = tc.comments & "\nProjectTo3D on " & Mis.Today() & "\noptions: " & "\n -outFile " & o.outFile & "\n -projection " & ARRAY BOOLEAN OF TEXT{"parallel", "perspective"}[o.perspective], bar = Triangulation.Barycenter(top, c, all := FALSE), norm = MeanNorm(top, c), meanRadius = MeanRadius(top, c, bar), meanThickness = MeanThickness(top, c, bar, norm) DO Wr.PutText(stderr, "Model shape parameters (before normalization and projection):\n"); Wr.PutText(stderr, " normal = ( " & WL4(norm) & " )\n"); Wr.PutText(stderr, " mean radius = " & WL(meanRadius) & "\n"); Wr.PutText(stderr, " mean thickness = " & WL(meanThickness) & "\n"); Wr.PutText(stderr, " rel. thickness = " & WL(meanThickness/meanRadius) & "\n"); IF o.oblique THEN (* Places "From4" so that "From4-To4" is oblique to the mean normal *) SelectObliqueProjection(o, norm, o.obliqueAngle); newcomments := comments & "\n -oblique " & WL(o.obliqueAngle); END; IF o.adjustCenter THEN (* Move figure so that barycenter is at origin *) FOR i := 0 TO LAST(c) DO c[i] := LR4.Sub(c[i], bar) END; newcomments := comments & "\n -adjustCenter"; END; IF o.adjustScale THEN (* Adjust scale of figure so that it fits in a sphere of radius 1 centered at To4 *) WITH maxRadius = MaxRadius(top, c, o.To4) DO FOR i := 0 TO LAST(c) DO c[i] := LR4.Scale(1.0d0/maxRadius, c[i]) END END; newcomments := comments & "\n -adjustScale"; END; newcomments := comments & "\nparameters: " & "\n -From4 " & WL4(o.From4) & "\n -To4 " & WL4(o.To4) & "\n -Up4 " & WL4(o.Up4) & "\n -Over4 " & WL4(o.Over4) & "\n -Vangle4 " & WL(o.Vangle4); ProjectTo3D(o, c, c3, top); IF o.statistics THEN ShowStatistics(top, c, c3) END; WriteState3D(o.outFile, top, c3, newcomments) END; Wr.PutText(stderr, "--------------------------------------------------\n") END DoIt; PROCEDURE MaxRadius(READONLY top: Topology; READONLY c: Coords4D; READONLY ctr: LR4.T): LONGREAL = VAR radius := 0.0d0; BEGIN FOR i := 0 TO top.NV-1 DO <* ASSERT OrgV(top.out[i]).num = i *> WITH d = LR4.Dist(ctr, c[i]) DO IF d > radius THEN radius := d END END END; RETURN radius END MaxRadius; PROCEDURE MeanRadius(READONLY top: Topology; READONLY c: Coords4D; READONLY bar: LR4.T): LONGREAL = VAR sum2 : LONGREAL := 0.0d0; BEGIN FOR i := 0 TO top.NV-1 DO WITH di = LR4.Dist(c[i],bar) DO sum2 := sum2 + di*di; END END; RETURN Math.sqrt(sum2/FLOAT(top.NV-1,LONGREAL)) END MeanRadius; PROCEDURE MeanThickness(READONLY top: Topology; READONLY c: Coords4D; READONLY bar, norm: LR4.T): LONGREAL = VAR sum2 : LONGREAL := 0.0d0; BEGIN FOR i := 0 TO top.NV-1 DO WITH di = LR4.Dot(LR4.Sub(c[i],bar),norm) DO sum2 := sum2 + di*di; END END; RETURN Math.sqrt(sum2/FLOAT(top.NV-1,LONGREAL)) END MeanThickness; PROCEDURE MeanNorm(READONLY top: Topology; READONLY c: Coords4D): LR4.T = VAR norm: LR4.T := LR4.T{0.0d0, ..}; BEGIN FOR i := 0 TO top.NP-1 DO WITH f = top.region[i], k = TetrahedronVertices(f), p = c[k[0]], q = c[k[1]], r = c[k[2]], s = c[k[3]], pq = LR4.Sub(q, p), pr = LR4.Sub(r, p), ps = LR4.Sub(s, p), v = LR4Extras.Cross(pq, pr, ps), n = LR4.Dir(v) DO norm := LR4.Add(norm, n) END END; WITH m = LR4.Norm(norm) DO IF m < 1.0d-20 THEN RETURN LR4.T{1.0d0, 0.0d0, ..} ELSE RETURN LR4.Scale(1.0d0/m, norm) END END; END MeanNorm; PROCEDURE ProjectTo3D( READONLY o: Options; READONLY c: Coords4D; VAR c3: Tridimensional.Coords3D; READONLY top: Topology; ) = <* FATAL Wr.Failure, Thread.Alerted *> PROCEDURE CalcV4Matrix() = (* This procedure computes the four basis vectors for the 4D viewing matrix, Wa,Wb,Wc, and Wd. Note that the Up vector transforms to Wb, the Over vector transforms to Wc, and the line of sight transforms to Wd. The Wa vector is then computed from Wb,Wc and Wd. *) VAR norm: LONGREAL; BEGIN (* Calculate Wd, the 4th coordinate basis vector and line-of-sight. *) Wd := LR4.Sub(o.To4,o.From4); norm := LR4.Norm(Wd); IF norm < Epsilon THEN Wr.PutText(stderr,"4D To Point and From Point are the same\n"); Process.Exit(1); END; Wd := LR4.Scale(1.0d0/norm, Wd); (* Calculate Wa, the X-axis basis vector. *) Wa := LR4Extras.Cross(o.Up4,o.Over4,Wd); norm := LR4.Norm(Wa); IF norm < Epsilon THEN Wr.PutText(stderr, "4D up,over and view vectors are not perpendicular\n"); Process.Exit(1); END; Wa := LR4.Scale(1.0d0/norm, Wa); (* Calculate Wb, the perpendicularized Up vector. *) Wb := LR4Extras.Cross(o.Over4,Wd,Wa); norm := LR4.Norm(Wb); IF norm < Epsilon THEN Wr.PutText(stderr,"Invalid 4D over vector\n"); Process.Exit(1); END; Wb := LR4.Scale(1.0d0/norm, Wb); (* Calculate Wc, the perpendicularized Over vector. Note that the resulting vector is already normalized, since Wa, Wb and Wd are all unit vectors. *) Wc := LR4Extras.Cross(Wd,Wa,Wb); END CalcV4Matrix; VAR rtemp: LONGREAL; Wa,Wb,Wc,Wd : LR4.T; BEGIN WITH angle = o.Vangle4/2.0d0, angler = (FLOAT(Math.Pi,LONGREAL)*angle)/180.0d0, tan2vangle4 = Math.tan(angler), pconst = 1.0d0 / tan2vangle4 DO CalcV4Matrix(); FOR i := 0 TO top.NV-1 DO (* Transform the vertices from 4d World coordinates to 4D eye coordinates. *) WITH v = OrgV(top.out[i]), t = LR4.Sub(c[v.num], o.From4), depth = LR4.Dot(t,Wd) DO IF o.printDepth THEN Wr.PutText(stderr, "v[" & Fmt.Pad(Fmt.Int(v.num),4) & "] depth = " & Fmt.Pad(Fmt.LongReal(depth, Fmt.Style.Fix, prec := 4),8) & "\n" ) END; IF o.perspective THEN rtemp := pconst / depth ELSE rtemp := 1.0d0 END; c3[v.num][0] := rtemp * LR4.Dot(t, Wa); c3[v.num][1] := rtemp * LR4.Dot(t, Wb); c3[v.num][2] := rtemp * LR4.Dot(t, Wc); END END END; END ProjectTo3D; PROCEDURE SelectObliqueProjection( VAR o: Options; READONLY norm: LR4.T; angle: LONGREAL; ) = CONST Pi = 3.14159265358979323844d0; BEGIN WITH rad = Pi/180.0d0 * angle, c = Math.cos(rad), s = Math.sin(rad), dir = LR4.Dir(LR4.Mix(c, norm, s, Perp(norm))) DO o.From4 := LR4.Add(o.To4, LR4.Scale(6.0d0, dir)) END; SelectTwoIndepDirs(norm, o.Up4, o.Over4); END SelectObliqueProjection; PROCEDURE Perp(v: LR4.T): LR4.T = (* Returns a vector perpendicular to "v" *) VAR r: CARDINAL; VAR s: LONGREAL := 0.0d0; BEGIN (* Find largest coordinate *) r := 0; FOR i := 1 TO 3 DO IF ABS(v[i]) > ABS(v[r]) THEN r := i END END; IF ABS(v[r]) > 0.0d0 THEN (* Compute new value for it *) FOR i := 0 TO 3 DO IF i # r THEN s := s + v[i]*v[i] END END; v[r] := - s / v[r]; END; RETURN v END Perp; PROCEDURE SelectTwoIndepDirs( READONLY u: LR4.T; VAR v, w: LR4.T; ) = (* Selects two vectors "v", "w", independent of each other and of the given vector "u". *) VAR m: CARDINAL := 0; BEGIN (* Find the largest coordinate of "u": *) FOR i := 1 TO 3 DO IF ABS(u[i]) > ABS(u[m]) THEN m := i END END; FOR i := 0 TO 3 DO v[i] := 0.0d0; w[i] := 0.0d0 END; v[(m+1) MOD 4] := 1.0d0; w[(m+2) MOD 4] := 1.0d0; END SelectTwoIndepDirs; PROCEDURE ShowStatistics(READONLY tp: Topology; READONLY c: Coords4D; READONLY c3: Coords3D) = BEGIN AnalyzeEdges(tp, c); AnalyzeFaces(tp, c, c3); AnalyzeCells(tp, c, c3); END ShowStatistics; PROCEDURE AnalyzeEdges(READONLY top: Topology; READONLY c: Coords4D) = <* FATAL Thread.Alerted, Wr.Failure *> VAR stl: Stat.T; BEGIN Wr.PutText(stderr, "Statistics for existing edges:\n"); Stat.Init(stl); FOR i := 0 TO top.NE-1 DO WITH e = top.edge[i] DO IF e.exists THEN WITH p = e.pa, un = OrgV(p).num, vn = OrgV(Clock(p)).num, l = LR4.Dist(c[un],c[vn]), ll = FLOAT(l, REAL) DO Stat.Accum(stl, ll) END END END END; Wr.PutText(stderr, " lengths in R^4: "); Stat.Print(stderr, stl); Wr.PutText(stderr, "\n"); END AnalyzeEdges; PROCEDURE AnalyzeFaces(READONLY top: Topology; READONLY c: Coords4D; READONLY c3: Coords3D) = <* FATAL Thread.Alerted, Wr.Failure *> VAR sta: Stat.T; BEGIN Wr.PutText(stderr, "Statistics for existing faces:\n"); Stat.Init(sta); FOR i := 0 TO top.NF-1 DO WITH f = top.face[i] DO IF f.exists THEN WITH p = f.pa, un = OrgV(p).num, vn = OrgV(Enext(p)).num, wn = OrgV(Enext_1(p)).num, a = LR4.Dist(c[vn],c[un]), b = LR4.Dist(c[wn],c[un]), c = LR4.Dist(c[vn],c[wn]), p = (a+b+c), s = 0.5d0 * p, sa = s - a, sb = s - b, sc = s - c, ar = Math.sqrt(MAX(s*sa*sb*sc, 0.0d0)), arr = FLOAT(ar, REAL) DO Stat.Accum(sta, arr) END END END END; Wr.PutText(stderr, " areas in R^4: "); Stat.Print(stderr, sta); Wr.PutText(stderr, "\n"); WITH ns = CountSilhouetteFaces(top,c3), nb = CountBorderFaces(top), nn = top.NF-ns-nb DO Wr.PutText(stderr, " projection to R^3:" & " silhouette = " & Fmt.Int(ns) & " border = " & Fmt.Int(nb) & " normal = " & Fmt.Int(nn) & "\n"); END; END AnalyzeFaces; PROCEDURE AnalyzeCells(READONLY top: Topology; READONLY c: Coords4D; READONLY c3: Coords3D) = VAR stv: Stat.T; <* FATAL Thread.Alerted, Wr.Failure *> BEGIN Wr.PutText(stderr, "Statistics for existing tetrahedra:\n"); Stat.Init(stv); FOR i := 0 TO top.NP-1 DO WITH r = top.region[i], t = PnegP(Tors(r)) DO IF t.exists THEN WITH vt = TetrahedronVertices(r), un = vt[0], vn = vt[1], wn = vt[2], xn = vt[3], uv = LR4.Sub(c[vn],c[un]), uw = LR4.Sub(c[wn],c[un]), ux = LR4.Sub(c[xn],c[un]), n = LR4Extras.Cross(uv, uw, ux), v = 1.0d0/6.0d0 * LR4.Norm(n), vv = FLOAT(v, REAL) DO Stat.Accum(stv, vv) END END END END; Wr.PutText(stderr, " volume in R^4: "); Stat.Print(stderr, stv); Wr.PutText(stderr, "\n"); WITH nn = CountNegativeTetrahedra(top,c3), np = top.NP - nn DO Wr.PutText(stderr, " projection to R^3:" & " negative = " & Fmt.Int(nn) & " positive = " & Fmt.Int(np) & "\n"); END; END AnalyzeCells; (* PROCEDURE CountBorderEdges(READONLY tp: Topology) : CARDINAL = VAR count : CARDINAL := 0; BEGIN FOR i := 0 TO tp.NE-1 DO IF Triangulation.EdgeIsBorder(tp.edge[i].pa) THEN INC(count) END; END; RETURN count; END CountBorderEdges; PROCEDURE CountMiswoundEdges(READONLY tp: Topology; READONLY c3: Coords3D) : CARDINAL = VAR count: CARDINAL := 0; BEGIN FOR i := 0 TO tp.NE-1 DO WITH a = tp.edge[i].pa DO IF NOT Triangulation.EdgeIsBorder(a) THEN WITH wnd = Tridimensional.EdgeWindingNumber(a, c3) DO IF ABS(wnd) # 1 THEN Wr.PutText(stderr, " edge " & Fmt.Int(i)); Wr.PutText(stderr, " winding number = " & Fmt.Int(wnd) & "\n"); INC(count) END END END END END; RETURN count; END CountMiswoundEdges; *) PROCEDURE CountSilhouetteFaces(READONLY tp: Topology; READONLY c3: Coords3D) : CARDINAL = PROCEDURE FaceIsSilhouette(a: Pair) : BOOLEAN = (* Return TRUE iff the face associated to the pair "a" is a silhouette face *) BEGIN IF Ppos(a) = NIL OR Pneg(a) = NIL THEN RETURN FALSE END; WITH t = TetraNegPosVertices(a), un = t[0].num, vn = t[1].num, wn = t[2].num, xn = t[3].num, yn = t[4].num, d1 = TetraDet3D(un,vn,wn,xn, c3), d2 = TetraDet3D(un,vn,wn,yn, c3) DO RETURN d1*d2 >= 0.0d0; END END FaceIsSilhouette; VAR count : CARDINAL := 0; BEGIN FOR i := 0 TO tp.NF-1 DO IF FaceIsSilhouette(tp.face[i].pa) THEN INC(count) END; END; RETURN count; END CountSilhouetteFaces; PROCEDURE CountBorderFaces(READONLY tp: Topology) : CARDINAL = PROCEDURE FaceIsBorder(a: Pair) : BOOLEAN = (* Return TRUE iff the face associated to the pair "a" is a border face, FALSE c.c. *) BEGIN RETURN Ppos(a) = NIL OR Pneg(a) = NIL; END FaceIsBorder; VAR count : CARDINAL := 0; BEGIN FOR i := 0 TO tp.NF-1 DO IF FaceIsBorder(tp.face[i].pa) THEN INC(count) END; END; RETURN count; END CountBorderFaces; PROCEDURE CountNegativeTetrahedra(READONLY tp: Topology; READONLY c3: Coords3D) : CARDINAL = VAR count : CARDINAL := 0; BEGIN WITH t = Triangulation.CollectTetrahedra(tp)^ DO FOR i := 0 TO tp.NP-1 DO WITH a = t[i], un = OrgV(a).num, vn = OrgV(Enext(a)).num, wn = OrgV(Enext_1(a)).num, xn = OrgV(Enext_1(Fnext_1(a))).num DO IF TetraDet3D(un,vn,wn,xn, c3) <= 0.0d0 THEN INC(count) END; END END; END; RETURN count; END CountNegativeTetrahedra; PROCEDURE TetrahedronVertices(f:Triangulation.Pair): ARRAY [0..3] OF CARDINAL = (* Returns the vertices of a cell, given a dual facetedge "f" with origin at the cell's center. Assumes that the cell is a tetrahedron. *) BEGIN WITH g = Tors(f), h = Tors(Clock(Enext_1(f))), p = Org(g).num, q = Org(Enext(g)).num, r = Org(Enext_1(g)).num, s = Org(Enext_1(h)).num DO RETURN ARRAY [0..3] OF CARDINAL{p, q, r, s} END END TetrahedronVertices; PROCEDURE TetraDet3D(u,v,w,x: CARDINAL; READONLY c3: Coords3D) : LONGREAL = (* For each tetrahedron with vertices numbers u,v,w,x computes its orientation in R^{3} through the 4x4 determinant: _ _ | c3[u][0] c3[u][1] c3[u][2] 1.0d0 | B = | c3[v][0] c3[v][1] c3[v][2] 1.0d0 | | c3[w][0] c3[w][1] c3[w][2] 1.0d0 | | c3[x][0] c3[x][1] c3[x][2] 1.0d0 | - - *) BEGIN WITH a = LR4.T{c3[u][0], c3[u][1], c3[u][2], 1.0d0}, b = LR4.T{c3[v][0], c3[v][1], c3[v][2], 1.0d0}, c = LR4.T{c3[w][0], c3[w][1], c3[w][2], 1.0d0}, d = LR4.T{c3[x][0], c3[x][1], c3[x][2], 1.0d0} DO RETURN LR4Extras.Det(a,b,c,d); END END TetraDet3D; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFileTp"); o.inFileTp := pp.getNext(); pp.getKeyword("-inFileSt"); o.inFileSt := pp.getNext(); IF pp.keywordPresent("-outFile") THEN o.outFile := pp.getNext() ELSE o.outFile := o.inFileTp END; pp.getKeyword("-projection"); WITH pname = pp.getNext() DO IF Text.Equal(pname, "Parallel") THEN o.perspective := FALSE ELSIF Text.Equal(pname, "Perspective") THEN o.perspective := TRUE ELSE pp.error("Bad projection \"" & pp.getNext() & "\"\n") END END; o.adjustCenter := pp.keywordPresent("-adjustCenter"); o.adjustScale := pp.keywordPresent("-adjustScale"); IF pp.keywordPresent("-oblique") THEN o.oblique := TRUE; o.obliqueAngle := pp.getNextLongReal(-180.0d0, +180.0d0); ELSE o.oblique := FALSE; IF pp.keywordPresent("-From4") THEN FOR j := 0 TO 3 DO o.From4[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END ELSE o.From4 := LR4.T{0.0d0,0.0d0,0.0d0,-3.0d0}; END; END; IF pp.keywordPresent("-To4") THEN FOR j := 0 TO 3 DO o.To4[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END ELSE o.To4 := LR4.T{0.0d0,0.0d0,0.0d0,0.0d0}; END; IF pp.keywordPresent("-Up4") THEN FOR j := 0 TO 3 DO o.Up4[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END ELSE o.Up4 := LR4.T{0.0d0,1.0d0,0.0d0,0.0d0}; END; IF pp.keywordPresent("-Over4") THEN FOR j := 0 TO 3 DO o.Over4[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END ELSE o.Over4 := LR4.T{0.0d0,0.0d0,1.0d0,0.0d0}; END; IF pp.keywordPresent("-Vangle4") THEN o.Vangle4 := pp.getNextLongReal(1.0d0, 179.0d0); ELSE o.Vangle4 := 25.0d0; END; o.statistics := pp.keywordPresent("-statistics"); o.printDepth := pp.keywordPresent("-printDepth"); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage:\n"); Wr.PutText(stderr, " ProjectTo3D -inFileTp \\\n"); Wr.PutText(stderr, " -inFileSt [ -outFile ] \\\n"); Wr.PutText(stderr, " -projection [ Perspective | Parallel ]\\\n"); Wr.PutText(stderr, " [ -adjustCenter ] [ -adjustScale ] \\\n"); Wr.PutText(stderr, " [ -oblique ANGLE | -From4 ] \\\n"); Wr.PutText(stderr, " [ -To4 ] \\\n"); Wr.PutText(stderr, " [ -Up4 ] \\\n"); Wr.PutText(stderr, " [ -Over4 ] \\\n"); Wr.PutText(stderr, " [ -Vangle4 ] \\\n"); Wr.PutText(stderr, " [ -statistics ] \\\n"); Wr.PutText(stderr, " [ -printDepth ] \n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt(); END ProjectTo3D. (**************************************************************************) (* *) (* Copyright (C) 2001 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (* Last edited on 2001-05-03 12:58:59 by stolfi *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/RandomShape.m3 MODULE RandomShape EXPORTS Main; (* Last edited on 1999-12-02 17:06:26 by lplozada *) (* This module generates N random variations (trials) of a given ".tp" file. Reused without extensive modifications, created originally by J. Stolfi and R. Marcone. See the copyright and authorship futher down. *) IMPORT Triangulation, LR4, Random, Thread, Wr, Stdio, Fmt, ParseParams, Process; FROM Triangulation IMPORT Topology, Coords; FROM Stdio IMPORT stderr; TYPE Options = RECORD input: TEXT; (* Input file name (minus ".tp" extension) *) output: TEXT; (* Output file name prefix *) trialMin: CARDINAL; (* Number of first configuration to generate *) trialMax: CARDINAL; (* Number of last configuration to generate *) jitter: REAL; (* Magnitude of random perturbation *) normalize: BOOLEAN; (* TRUE to normalize the vertex coordinates *) END; PROCEDURE DoIt() = VAR comments : TEXT; BEGIN WITH o = GetOptions(), coins = NEW(Random.Default).init(TRUE), tc = Triangulation.ReadToMa(o.input), top = tc.top, rc = Triangulation.ReadState(o.input), cOld = rc^, cNew = NEW(REF Coords, top.NV)^ DO IF o.normalize THEN Triangulation.NormalizeVertexDistances(top, cOld, TRUE) END; FOR k := o.trialMin TO o.trialMax DO cNew := cOld; PerturbCoords(top, cNew, coins, FLOAT(o.jitter, LONGREAL)); IF o.normalize THEN Triangulation.NormalizeVertexDistances(top, cNew, TRUE) END; comments := " Random variation Number: " & Fmt.Int(k) & "\n" & " Randomizing from: " & o.input & ".top\n" & " Created by RandomShape: " & o.output & "-" & Fmt.Pad(Fmt.Int(k), 2, '0') & ".tp\n"; Triangulation.WriteState(o.output & "-" & Fmt.Pad(Fmt.Int(k),2,'0'), top,cNew,comments & "\nRandom Geometry") END END END DoIt; PROCEDURE PerturbCoords( READONLY top: Topology; VAR c: Coords; coins: Random.T; jitter: LONGREAL; ) = BEGIN FOR i := 0 TO LAST(c) DO IF top.vertex[i].exists AND NOT top.vertex[i].fixed THEN WITH ci = c[i], p = LR4.T{ jitter * coins.longreal(-1.0d0, +1.0d0), jitter * coins.longreal(-1.0d0, +1.0d0), jitter * coins.longreal(-1.0d0, +1.0d0), jitter * coins.longreal(-1.0d0, +1.0d0) } DO ci := LR4.Add(ci, p); END END END END PerturbCoords; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-input"); o.input := pp.getNext(); pp.getKeyword("-output"); o.output := pp.getNext(); pp.getKeyword("-trials"); o.trialMin := pp.getNextInt(0); o.trialMax := pp.getNextInt(o.trialMin); o.normalize := pp.keywordPresent("-normalize"); IF pp.keywordPresent("-jitter") THEN o.jitter := pp.getNextReal(0.0); ELSE o.jitter := 1.0 END; pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: RandomShape \\\n"); Wr.PutText(stderr, " -input -output \\\n"); Wr.PutText(stderr, " -trials \\\n"); Wr.PutText(stderr, " [ -normalize ] [ -jitter ]\n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt() END RandomShape. (* Comments -------- The procedure "Triangulation.NormalizeVertexDistance", normalizes the distances such that the average distance to origin is ever "one". If the attribute NORMALIZE = FALSE (i.e. absent), then the coordinates may to change between [-10,+10], according to the "jitter" value chose. If the attribute NORMALIZE = TRUE (i.e. present), then the coordinates are independent of the "jitter" value chose and may change between [-1,+1], may be occur that some coordinates to make off from this limits, but in geral, the majority are on this limits. ***************** START OF COPYRIGHT AND AUTHORSHIP NOTICE ********** All files in this directory tree are Copyright 1996 by Jorge Stolfi, Rober Marcone Rosi, and Universidade Estadual de Campinas, Brazil--- unless stated otherwise in the files themselves. THESE FILES ARE DISTRIBUTED WITH NO GUARANTEE OF ANY KIND. Neither the authors nor their employers may be held responsible for any losses or damages attributed to their use. These files may be freely copied, distributed, modified, and used for any purpose; provided that any subtantial excerpt of these files that is redistributed or incorporated in other software packages is accompanied by this copyright and authorship notice, and is made freely available under these same terms. ***************** END OF COPYRIGHT AND AUTHORSHIP NOTICE ************ *) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/RawCubeTriang.m3 MODULE RawCubeTriang EXPORTS Main; (* Creates ".tp",".tb",".st" and ".ma" files for one triangulated cube of order "gridOrder" with fixed geometry. The cube have six pairs facetedges saved. Implemented by L. Lozada (see the copyright and authorship futher down). *) IMPORT Octf, LR4, Triangulation, Fmt, ParseParams, Process, Wr, Stdio, Thread, Mis; FROM Triangulation IMPORT Coords, OrgV, Pair, Org, SetAllOrgs, Topology; FROM Octf IMPORT Enext, Clock, Enext_1, Fnext, Spin, Fnext_1, SetEdgeAll, SpinBit; FROM Stdio IMPORT stderr; TYPE Options = RECORD gridOrder: CARDINAL; END; PROCEDURE Main() = BEGIN WITH o = GetOptions(), co = MakeCubeTriang(o.gridOrder), ct = Triangulation.MakeTopology(co[0],1), c = ComputeCoordinates(co, ct, o.gridOrder)^, comments = " Individual triangulated cube with fixed geometry\n" & " Created by MakeRawCubeTriang: cubetriang-" & Fmt.Int(o.gridOrder) & ".ct\n" DO Triangulation.WriteTopology( "cubetriang-" & Fmt.Int(o.gridOrder), ct, comments & Mis.Today() ); Triangulation.MakeTopologyTable( "cubetriang-" & Fmt.Int(o.gridOrder), ct, comments & Mis.Today() ); Triangulation.WriteState( "cubetriang-"&Fmt.Int(o.gridOrder),0.0d0,ct,c,comments & Mis.Today() ); Triangulation.WriteMaterials( "cubetriang-" & Fmt.Int(o.gridOrder), ct,comments& Mis.Today() ); END; END Main; PROCEDURE ComputeCoordinates( READONLY co: ARRAY [0..5] OF Pair; READONLY ct: Topology; order: CARDINAL; ): REF Coords = BEGIN WITH r = NEW(REF Coords, ct.NV), c = r^, o0 = LR4.T{-1.0d0,-1.0d0,-1.0d0,0.0d0}, o1 = LR4.T{ 1.0d0,-1.0d0,-1.0d0,0.0d0}, o2 = LR4.T{-1.0d0, 1.0d0,-1.0d0,0.0d0}, o3 = LR4.T{ 1.0d0, 1.0d0,-1.0d0,0.0d0}, o4 = LR4.T{-1.0d0,-1.0d0, 1.0d0,0.0d0}, o5 = LR4.T{ 1.0d0,-1.0d0, 1.0d0,0.0d0}, o6 = LR4.T{-1.0d0, 1.0d0, 1.0d0,0.0d0}, o7 = LR4.T{ 1.0d0, 1.0d0, 1.0d0,0.0d0} DO PROCEDURE SetCornerCoords(e: Pair; cv: LR4.T) = BEGIN c[OrgV(e).num] := cv; END SetCornerCoords; PROCEDURE SetCoordEdgev1v3(a: Pair; READONLY o: LR4.T) = (* Set the vertex coordinates along the edge with vertices v1v3. *) PROCEDURE SetVertexCoords(e: Pair; x: LONGREAL) = BEGIN c[OrgV(e).num] := LR4.T{o[0], o[1]+x, o[2], o[3]}; END SetVertexCoords; BEGIN FOR i := 1 TO order-1 DO a := Clock(Enext_1(Fnext(Enext(a)))); SetVertexCoords(a, FLOAT(i,LONGREAL) *2.0d0/FLOAT(order,LONGREAL)); END; END SetCoordEdgev1v3; PROCEDURE SetCoordEdgev3v2(a: Pair; READONLY o: LR4.T) = (* Set the vertex coordinates along the edge with vertices v3v2. *) PROCEDURE SetVertexCoords(e: Pair; x: LONGREAL) = BEGIN c[OrgV(e).num] := LR4.T{o[0]-x, o[1], o[2], o[3]}; END SetVertexCoords; BEGIN FOR i := 1 TO order-1 DO a := Clock(Enext_1(Fnext(Enext(a)))); SetVertexCoords(a, FLOAT(i,LONGREAL) *2.0d0/FLOAT(order,LONGREAL)); END; END SetCoordEdgev3v2; PROCEDURE SetCoordEdgev2v6(a: Pair; READONLY o: LR4.T) = (* Set the vertex coordinates along the edge with vertices v2v6. *) PROCEDURE SetVertexCoords(e: Pair; x: LONGREAL) = BEGIN c[OrgV(e).num] := LR4.T{o[0], o[1], o[2]+x, o[3]}; END SetVertexCoords; BEGIN FOR i := 1 TO order-1 DO a := Clock(Enext_1(Fnext(Enext(a)))); SetVertexCoords(a, FLOAT(i,LONGREAL) *2.0d0/FLOAT(order,LONGREAL)); END; END SetCoordEdgev2v6; PROCEDURE SetCoordEdgev6v4(a: Pair; READONLY o: LR4.T) = (* Set the vertex coordinates along the edge with vertices v6v4. *) PROCEDURE SetVertexCoords(e: Pair; x: LONGREAL) = BEGIN c[OrgV(e).num] := LR4.T{o[0], o[1]-x, o[2], o[3]}; END SetVertexCoords; BEGIN FOR i := 1 TO order-1 DO a := Clock(Enext_1(Fnext(Enext(a)))); SetVertexCoords(a, FLOAT(i,LONGREAL) *2.0d0/FLOAT(order,LONGREAL)); END; END SetCoordEdgev6v4; PROCEDURE SetCoordEdgev4v5(a: Pair; READONLY o: LR4.T) = (* Set the vertex coordinates along the edge with vertices v4v5. *) PROCEDURE SetVertexCoords(e: Pair; x: LONGREAL) = BEGIN c[OrgV(e).num] := LR4.T{o[0]+x, o[1], o[2], o[3]}; END SetVertexCoords; BEGIN FOR i := 1 TO order-1 DO a := Clock(Enext_1(Fnext(Enext(a)))); SetVertexCoords(a, FLOAT(i,LONGREAL) *2.0d0/FLOAT(order,LONGREAL)); END; END SetCoordEdgev4v5; PROCEDURE SetCoordEdgev5v1(a: Pair; READONLY o: LR4.T) = (* Set the vertex coordinates along the edge with vertices v5v1. *) PROCEDURE SetVertexCoords(e: Pair; x: LONGREAL) = BEGIN c[OrgV(e).num] := LR4.T{o[0], o[1], o[2]-x, o[3]}; END SetVertexCoords; BEGIN FOR i := 1 TO order-1 DO a := Clock(Enext_1(Fnext(Enext(a)))); SetVertexCoords(a, FLOAT(i,LONGREAL) *2.0d0/FLOAT(order,LONGREAL)); END; END SetCoordEdgev5v1; PROCEDURE SetCoordDiagonal(a: Pair; READONLY o: LR4.T) = (* Set the vertex coordinates along the diagonal edge. *) PROCEDURE SetVertexCoords(e: Pair; x: LONGREAL) = BEGIN c[OrgV(e).num] := LR4.T{o[0]+x, o[1]+x, o[2]+x, o[3]}; END SetVertexCoords; BEGIN FOR i := 1 TO order-1 DO a := Clock(Enext_1(Fnext(Fnext(Enext(a))))); SetVertexCoords(a, FLOAT(i,LONGREAL) *2.0d0/FLOAT(order,LONGREAL)); END; SetCornerCoords(Clock(a),o7); END SetCoordDiagonal; PROCEDURE Move(a: Pair) : Pair = BEGIN RETURN Clock(Enext_1(Fnext_1(Enext_1(a)))); END Move; BEGIN (* Set the corners *) SetCornerCoords(co[0],o0); SetCornerCoords(Enext_1(co[5]),o1); SetCornerCoords(Enext_1(co[0]),o3); SetCornerCoords(Enext_1(co[1]),o2); SetCornerCoords(Enext_1(co[2]),o6); SetCornerCoords(Enext_1(co[3]),o4); SetCornerCoords(Enext_1(co[4]),o5); SetCoordEdgev1v3(Move(co[5]), o1); SetCoordEdgev3v2(Move(co[0]), o3); SetCoordEdgev2v6(Move(co[1]), o2); SetCoordEdgev6v4(Move(co[2]), o6); SetCoordEdgev4v5(Move(co[3]), o4); SetCoordEdgev5v1(Move(co[4]), o5); SetCoordDiagonal(co[0],o0); END; RETURN r END END ComputeCoordinates; PROCEDURE MakeCubeTriang(gridOrder: CARDINAL) : ARRAY [0..5] OF Pair = VAR co : ARRAY [0..5] OF Pair; <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH ca = Triangulation.MakeTetraTopo(gridOrder,gridOrder), cb = Triangulation.MakeTetraTopo(gridOrder,gridOrder), cc = Triangulation.MakeTetraTopo(gridOrder,gridOrder), cd = Triangulation.MakeTetraTopo(gridOrder,gridOrder), ce = Triangulation.MakeTetraTopo(gridOrder,gridOrder), cf = Triangulation.MakeTetraTopo(gridOrder,gridOrder), bc1 = ca[0], ac1 = Spin(cb[1]), bc2 = cb[0], ac2 = Spin(cc[1]), bc3 = cc[0], ac3 = Spin(cd[1]), bc4 = cd[0], ac4 = Spin(ce[1]), bc5 = ce[0], ac5 = Spin(cf[1]), bc6 = cf[0], ac6 = Spin(ca[1]) DO EVAL Triangulation.Glue(ac1,bc1,gridOrder); EVAL Triangulation.Glue(ac2,bc2,gridOrder); EVAL Triangulation.Glue(ac3,bc3,gridOrder); EVAL Triangulation.Glue(ac4,bc4,gridOrder); EVAL Triangulation.Glue(ac5,bc5,gridOrder); EVAL Triangulation.Glue(ac6,bc6,gridOrder); co[0] := cb[1]; co[1] := cc[1]; co[2] := cd[1]; co[3] := ce[1]; co[4] := cf[1]; co[5] := ca[1]; Wr.PutText(stderr, "Exit MakeCubeTriang: \n"); RETURN co; END; END MakeCubeTriang; <* UNUSED *> PROCEDURE GlueCubeTriang(a, b : Pair; n: CARDINAL) : Pair = VAR ta,tb: ARRAY [0..100] OF Pair; BEGIN <* ASSERT SpinBit(a) = SpinBit(b) *> (* sanity check *) <* ASSERT n >= 1 *> ta[0] := a; tb[0] := b; FOR i := 1 TO 2*n-1 DO ta[i] := Clock(Enext_1(Fnext(Enext(ta[i-1])))); tb[i] := Clock(Enext_1(Fnext_1(Enext(tb[i-1])))); <* ASSERT ta[i] # a *> <* ASSERT tb[i] # b *> END; Octf.Meld(b, a); (* updating edges relations for i=0 *) SetEdgeAll(a, a.facetedge.edge); SetEdgeAll(Enext(a), Enext(a).facetedge.edge); SetEdgeAll(Enext_1(a), Enext_1(a).facetedge.edge); (* updating vertices relations for i=0 *) SetAllOrgs(a, Org(a)); SetAllOrgs(Clock(a), Org(Clock(a))); SetAllOrgs(Enext(a), Org(Enext(a))); SetAllOrgs(Clock(Enext(a)), Org(Clock(Enext(a)))); SetAllOrgs(Enext_1(a), Org(Enext_1(a))); SetAllOrgs(Clock(Enext_1(a)), Org(Clock(Enext_1(a)))); FOR i := 1 TO 2*n-1 DO Octf.Meld(tb[i],ta[i]); (* updating edges relations *) SetEdgeAll(ta[i], ta[i].facetedge.edge); SetEdgeAll(Enext(ta[i]), Enext(ta[i]).facetedge.edge); SetEdgeAll(Enext_1(ta[i]), Enext_1(ta[i]).facetedge.edge); (* updating vertices relations *) SetAllOrgs(ta[i], Org(ta[i])); SetAllOrgs(Clock(ta[i]), Org(Clock(ta[i]))); SetAllOrgs(Enext(ta[i]), Org(Enext(ta[i]))); SetAllOrgs(Clock(Enext(ta[i])), Org(Clock(Enext(ta[i])))); SetAllOrgs(Enext_1(ta[i]), Org(Enext_1(ta[i]))); SetAllOrgs(Clock(Enext_1(ta[i])), Org(Clock(Enext_1(ta[i])))); END; SetAllOrgs(Clock(Enext_1(Fnext_1(Enext_1(ta[n-1])))), Org(Enext_1(a))); RETURN ta[n-1]; END GlueCubeTriang; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-gridOrder"); o.gridOrder := pp.getNextInt(1, 20); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: MakeRawCubeTriang -gridOrder \n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN Main(); END RawCubeTriang. (**************************************************************************) (* *) (* Copyright (C) 1999 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/RefineTriang.m3 MODULE RefineTriang EXPORTS Main; (* Refines (or duplicate) a given triangulation (".tp" file). See notice of copyright at the end of this file. Revisions: 21-05-2000: Fixed and removed a bug that increases the number of original vertices of type "VV". 31-05-2000: Added the heredity of the "root" attributes for edges and faces. 11-06-2000: Hidden the new elements insert in the refiment process: edges and vertices are set with the attibute "exists= FALSE" 25-11-2000: Added the option "net" for simulate textures on existing faces with thin cylinders and small spheres. *) IMPORT Thread, Wr, Process, LR4, Triangulation, Octf, ParseParams, R3; FROM Triangulation IMPORT Coords, Vertex, OrgV, MakeFacetEdge, MakeVertex, SetOrg, Org, Pneg, Ppos, MakePolyhedron, FacetEdge, Node, SetAllOrgs, SetNextPneg; FROM Octf IMPORT Pair, Tors, Spin, Clock, Fnext, SpinBit, OrientationBit, SpliceEdges, Enext, SetFnext, SetEnext, SetFace, Enext_1, SetEdge, Fnext_1, SetEdgeAll, Srot, SetFaceAll; FROM Stdio IMPORT stderr; VAR x: REF ARRAY OF Vertex; NNV: CARDINAL := 0; TYPE Options = RECORD inFileTp: TEXT; (* Input file name (minus ".tp" extension) *) inFileSt: TEXT; (* Input file name (minus ".st" extension) *) outFile : TEXT; (* Output file name prefix *) fixOri : BOOLEAN; (* TRUE to fix original vertices *) assert : BOOLEAN; (* make some strong assertions *) net : BOOLEAN; (* simulate a net as small spheres and thin cylinders. *) END; RowT = ARRAY [0..3] OF Pair; CONST ThinEdgeExists = FALSE; PROCEDURE DoIt() = <* FATAL Wr.Failure, Thread.Alerted *> VAR gi : REF ARRAY OF ARRAY OF Pair; ntop : Triangulation.Topology; BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToMa(o.inFileTp,FALSE), (* TRUE for indicate root of tetrahedra *) top = tc.top, rc = Triangulation.ReadState(o.inFileSt), c = rc^, half = NEW(REF ARRAY OF Pair, 2*top.NFE)^, vnew = NEW(REF ARRAY OF Vertex, top.NV)^ DO FOR i := 0 TO top.NF-1 DO IF Octf.DegreeEdgeRing(top.face[i].pa) # 3 THEN Wr.PutText(stderr,"This topology isn't a triangulation\n"); Process.Exit(1); END; END; Wr.PutText(stderr, "Refining from: " & o.inFileTp & ".tp\n"); gi := NEW(REF ARRAY OF ARRAY OF Pair, top.NP, 4); x := NEW(REF ARRAY OF Vertex, top.NP); PROCEDURE Half(a: Pair): Pair = BEGIN WITH na = a.facetedge.num, oa = OrientationBit(a), sa = SpinBit(a), h = half[2*na + oa] DO IF sa = 0 THEN RETURN h ELSE RETURN Spin(h) END END END Half; (* ==== Refine the Tetrahedral Cell ==== *) PROCEDURE RefineCell(g: RowT; in: CARDINAL) = BEGIN (* To insert four faces obliques "i", "j", "k", "l" *) WITH i = MakeTriangle(FALSE), j = MakeTriangle(FALSE), k = MakeTriangle(FALSE), l = MakeTriangle(FALSE) DO (* the facet "i" will be splice with g[1], g[2], g[3] *) SetFnext(i,Clock(g[1])); SetFnext(Enext(i),Enext(g[3])); SetFnext(Enext_1(i),Clock(g[2])); (* updating component edge *) SetEdgeAll(i, g[1].facetedge.edge); SetEdgeAll(Enext(i), Enext(g[3]).facetedge.edge); SetEdgeAll(Enext_1(i), g[2].facetedge.edge); (* updating origins *) SetOrg(i, Org(g[2])); SetOrg(Clock(i), Org(g[1])); SetOrg(Enext(i), Org(Clock(i))); SetOrg(Clock(Enext(i)), Org(Enext(g[2]))); SetOrg(Enext_1(i), Org(Clock(Enext(i)))); SetOrg(Clock(Enext_1(i)), Org(i)); (* the facet "j" will be splice with: g[0], g[1], g[2] *) SetFnext(j,Enext(g[0])); SetFnext(Enext(j),Clock(Enext(g[1]))); SetFnext(Enext_1(j),Clock(Enext_1(g[2]))); (* updating component edge *) SetEdgeAll(j, Enext(g[0]).facetedge.edge); SetEdgeAll(Enext(j), Enext(g[1]).facetedge.edge); SetEdgeAll(Enext_1(j), Enext_1(g[2]).facetedge.edge); (* updating origins *) SetOrg(j, Org(Enext(g[0]))); SetOrg(Clock(j), Org(Enext_1(g[0]))); SetOrg(Enext(j), Org(Clock(j))); SetOrg(Clock(Enext(j)), Org(g[2])); SetOrg(Enext_1(j), Org(Clock(Enext(j)))); SetOrg(Clock(Enext_1(j)), Org(j)); (* the facet "k" will be splice with: g[0], g[1], g[3]) *) SetFnext(k,Clock(Fnext_1(Enext_1(g[0])))); SetFnext(Enext(k),Fnext(Enext_1(g[1]))); SetFnext(Enext_1(k),Clock(Fnext_1(g[3]))); (* updating component edge *) SetEdgeAll(k,Enext_1(g[0]).facetedge.edge); SetEdgeAll(Enext(k),Enext_1(g[1]).facetedge.edge); SetEdgeAll(Enext_1(k),g[3].facetedge.edge); (* updating origins *) SetOrg(k, Org(g[0])); SetOrg(Clock(k), Org(Enext_1(g[0]))); SetOrg(Enext(k), Org(Clock(k))); SetOrg(Clock(Enext(k)), Org(g[1])); SetOrg(Enext_1(k), Org(Clock(Enext(k)))); SetOrg(Clock(Enext_1(k)), Org(k)); (* the facet "l" will be splice with: g[0], g[2], g[3] *) SetFnext(l, Clock(Fnext_1(g[0]))); SetFnext(Enext(l), Clock(Fnext_1(Enext_1(g[3])))); SetFnext(Enext_1(l), Fnext(Enext(g[2]))); (* updating component edge *) SetEdgeAll(l, g[0].facetedge.edge); SetEdgeAll(Enext(l), Enext_1(g[3]).facetedge.edge); SetEdgeAll(Enext_1(l), Enext(g[2]).facetedge.edge); (* updating origins *) SetOrg(l, Org(Clock(g[0]))); SetOrg(Clock(l), Org(g[0])); SetOrg(Enext(l), Org(Clock(l))); SetOrg(Clock(Enext(l)), Org(Enext(g[2]))); SetOrg(Enext_1(l), Org(Clock(Enext(l)))); SetOrg(Clock(Enext_1(l)), Org(l)); (* Subdivision of the Octahedron (in four tetrahedron) delimitate by the medial vertices *) WITH o1 = MakeTriangle(FALSE), o2 = MakeTriangle(FALSE), o3 = MakeTriangle(FALSE), o4 = MakeTriangle(FALSE) DO <* ASSERT i = Fnext_1(Clock(g[1])) *> <* ASSERT i = Clock(Fnext(g[1])) *> <* ASSERT i = Clock(Enext_1(Fnext(g[2]))) *> <* ASSERT j = Fnext_1(Enext(g[0])) *> <* ASSERT k = Clock(Fnext_1(Enext_1(g[0]))) *> <* ASSERT k = Clock(Enext_1(Fnext_1(g[3]))) *> <* ASSERT l = Clock(Fnext_1(g[0])) *> (* triangle o1 *) SetFnext(o1, Enext(k)); SetFnext(Enext_1(g[1]), o1); SetFnext(Enext_1(o1), Enext(g[0])); SetFnext(j, Enext_1(o1)); (* updating component edge *) SetEdgeAll(o1, Enext(k).facetedge.edge); SetEdgeAll(Enext_1(o1), j.facetedge.edge); (* updating origins *) SetOrg(o1, Org(Enext_1(g[1]))); SetOrg(Clock(o1), Org(Clock(Enext_1(g[1])))); SetOrg(Enext_1(o1), Org(Enext(g[0]))); SetOrg(Clock(Enext_1(o1)), Org(Clock(Enext(g[0])))); SetOrg(Enext(o1), Org(Enext_1(k))); SetOrg(Clock(Enext(o1)), Org(j)); (* triangle o2 *) SetFnext(Enext(o2), Enext(g[3])); SetFnext(Enext(i), Enext(o2)); SetFnext(Enext_1(o2), Enext_1(l)); SetFnext(Enext(g[2]), Enext_1(o2)); (* updating component edge *) SetEdgeAll(Enext(o2), Enext(g[3]).facetedge.edge); SetEdgeAll(Enext_1(o2), Enext(g[2]).facetedge.edge); (* updating origins *) SetOrg(o2, Org(j)); SetOrg(Clock(o2), Org(Enext_1(k))); SetOrg(Enext(o2), Org(Enext(g[3]))); SetOrg(Clock(Enext(o2)), Org(Clock(Enext(g[3])))); SetOrg(Enext_1(o2), Org(Enext(g[2]))); SetOrg(Clock(Enext_1(o2)), Org(Clock(Enext(g[2])))); (* triangle o3 *) SetFnext(o3, l); SetFnext(Clock(g[0]), o3); SetFnext(Enext(o3), g[3]); SetFnext(Clock(Enext_1(k)), Enext(o3)); (* updating component edge *) SetEdgeAll(o3, l.facetedge.edge); SetEdgeAll(Enext(o3), g[3].facetedge.edge); (* updating origins *) SetOrg(o3, Org(Clock(g[0]))); SetOrg(Clock(o3), Org(g[0])); SetOrg(Enext(o3), Org(g[3])); SetOrg(Clock(Enext(o3)), Org(Clock(g[3]))); SetOrg(Enext_1(o3), Org(Enext_1(k))); SetOrg(Clock(Enext_1(o3)), Org(j)); (* triangle o4 *) SetFnext(g[1], Enext(o4)); SetFnext(Enext(o4), Clock(i)); SetFnext(Enext_1(j), Enext_1(o4)); SetFnext(Enext_1(o4), Clock(Enext_1(g[2]))); SetFnext(o4, o2); SetFnext(o2, Clock(Enext_1(o3))); SetFnext(Clock(Enext_1(o3)), Clock(Enext(o1))); (* updating component edge *) SetEdgeAll(Enext(o4), Clock(i).facetedge.edge); SetEdgeAll(Enext_1(o4), Enext_1(j).facetedge.edge); SetEdgeAll(o2, o2.facetedge.edge); (* updating origins *) SetOrg(Enext(o4), Org(g[1])); SetOrg(Clock(Enext(o4)), Org(Clock(g[1]))); SetOrg(Enext_1(o4), Org(Clock(Enext_1(g[2])))); SetOrg(Clock(Enext_1(o4)), Org(Enext_1(g[2]))); SetOrg(o4, Org(o2)); SetOrg(Clock(o4), Org(Clock(o2))); (* making eigth tetrahedral cells *) SetAllPneg(j); SetAllPneg(Clock(Fnext_1(Enext_1(Fnext(k))))); SetAllPneg(Clock(Fnext_1(Enext(i)))); SetAllPneg(Clock(Fnext_1(Enext(Fnext(l))))); SetAllPneg(Enext_1(Fnext(o1))); SetAllPneg(o2); SetAllPneg(Fnext(o3)); SetAllPneg(o4); IF o.assert THEN (* Some strong assertions *) <* ASSERT Org(Srot(j)) = Pneg(j) *> <* ASSERT Org(Srot(Clock(Fnext_1(Enext_1(Fnext(k)))))) = Pneg(Clock(Fnext_1(Enext_1(Fnext(k))))) *> <* ASSERT Org(Srot(Clock(Fnext_1(Enext(i))))) = Pneg(Clock(Fnext_1(Enext(i)))) *> <* ASSERT Org(Srot(Clock(Fnext_1(Enext(Fnext(l)))))) = Pneg(Clock(Fnext_1(Enext(Fnext(l))))) *> <* ASSERT Org(Srot(Fnext(o3))) = Pneg(Fnext(o3)) *> <* ASSERT Org(Srot(Enext_1(Fnext(o1)))) = Pneg(Enext_1(Fnext(o1))) *> <* ASSERT Org(Srot(o4)) = Pneg(o4) *> <* ASSERT Org(Srot(o2)) = Pneg(o2) *> WITH v = Srot(j), v1 = Clock(Enext_1(Srot(j))) DO <* ASSERT Pneg(Tors(v)) = Pneg(Tors(v1)) *> END; WITH v = Srot(Fnext(o3)), v1 = Clock(Enext_1(Srot(Fnext(o3)))) DO <* ASSERT Pneg(Tors(v)) = Pneg(Tors(v1)) *> END; WITH v = Srot(o2), v1 = Clock(Enext_1(Srot(o2))) DO <* ASSERT Pneg(Tors(v)) = Pneg(Tors(v1)) *> END; WITH v = Srot(o4), v1 = Clock(Enext_1(Srot(o4))) DO <* ASSERT Pneg(Tors(v)) = Pneg(Tors(v1)) *> END; WITH v = Srot(Enext_1(Fnext(o1))), v1 = Clock(Enext_1(Srot(Enext_1(Fnext(o1))))) DO <* ASSERT Pneg(Tors(v)) = Pneg(Tors(v1)) *> END; WITH v = Srot(Clock(Fnext_1(Enext_1(Fnext(k))))), v1 = Clock(Enext_1(Srot(Clock(Fnext_1(Enext_1(Fnext(k))))))) DO <* ASSERT Pneg(Tors(v)) = Pneg(Tors(v1)) *> END; WITH v = Srot(Clock(Fnext_1(Enext(i)))), v1 = Clock(Enext_1(Srot(Clock(Fnext_1(Enext(i)))))) DO <* ASSERT Pneg(Tors(v)) = Pneg(Tors(v1)) *> END; WITH v = Srot(Clock(Fnext_1(Enext(Fnext(l))))), v1 = Clock(Enext_1(Srot(Clock(Fnext_1(Enext(Fnext(l))))))) DO <* ASSERT Pneg(Tors(v)) = Pneg(Tors(v1)) *> END END; (* Now, refine the subdivision of the octahedron in more four tetrahedra, through the subdivision of the diagonal edge of the octahedron. *) SubdivideEdge(o2,in,o.net); END END; END RefineCell; PROCEDURE CreateVertex(a: Pair): BOOLEAN = VAR t: Pair := a; BEGIN WITH fe = NARROW(a.facetedge,FacetEdge) DO IF NOT fe.mark THEN fe.mark := TRUE; REPEAT WITH fe = NARROW(t.facetedge,FacetEdge) DO fe.mark := TRUE; END; t := Fnext(t) UNTIL t = a; RETURN TRUE; END; RETURN FALSE; END; END CreateVertex; PROCEDURE SetAllVh(a: Pair; v: Vertex) = (* Set all adjacents pairs to "a" with the same medial vertex "v" *) PROCEDURE SetVh(b: Pair) = (* Set the pair "b" with the medial vertex "v". *) BEGIN WITH fe = NARROW(b.facetedge, FacetEdge) DO fe.vh := v; END; END SetVh; VAR t: Pair := a; BEGIN REPEAT SetVh(t); t := Fnext(t); UNTIL t = a; END SetAllVh; PROCEDURE SetAllPneg(a : Pair) = (* set the (12) pairs facetedges belonging to same 3-cell *) VAR t: Pair := a; BEGIN WITH p = MakePolyhedron() DO SetNextPneg(t,p); REPEAT SetNextPneg(Clock(Fnext_1(t)),p); t := Enext_1(t); UNTIL t = a; END END SetAllPneg; PROCEDURE Vhnum(a: Pair): CARDINAL = (* given the pair "a", this procedure return the number of its medial vertex "vh". *) BEGIN WITH fe = NARROW(a.facetedge, FacetEdge) DO RETURN fe.vh.num; END; END Vhnum; BEGIN (* Copy the original vertices, save icorrespondence in "vnew" array: *) FOR iu := 0 TO top.NV-1 DO WITH u = top.vertex[iu], v = MakeVertex() DO v.num := u.num; v.exists := u.exists; v.fixed := u.fixed OR o.fixOri; v.color := u.color; v.radius := u.radius; v.label := u.label; vnew[iu] := v END END; (* Create two new facetedges for each original facetedge "fe". The new facetedge corresponding to the origin half of "fe", with same spin and orientation, will be | Half(a) = Spin^s(half[2*a.facetedge.num + o]) where s = SpinBit(a), o = OrientationBit(a) *) VAR ve: REF ARRAY OF Vertex := NEW(REF ARRAY OF Vertex, top.NE); i: CARDINAL := 0; BEGIN FOR ie := 0 TO top.NFE-1 DO WITH a = top.facetedge[ie], oa = OrientationBit(a), sa = SpinBit(a), ho = half[2*ie + oa], hd = half[2*ie + 1 - oa], fe = NARROW(a.facetedge, FacetEdge), fn = fe.face.num, en = fe.edge.num DO IF CreateVertex(a) THEN ve[i] := MakeVertex(); ve[i].num := top.NV + NNV; INC(NNV); ve[i].exists := top.edge[en].exists; ve[i].fixed := FALSE; ve[i].color := top.edge[en].color; ve[i].transp := top.edge[en].transp; ve[i].radius := top.edge[en].radius; ve[i].label := "VE"; SetAllVh(a, ve[i]); INC(i); END; ho := MakeFacetEdge(); WITH hoe = NARROW(ho.facetedge, FacetEdge) DO hoe.edge.exists := top.edge[en].exists; hoe.edge.color := top.edge[en].color; hoe.edge.transp := top.edge[en].transp; hoe.edge.radius := top.edge[en].radius; (* set the "root" edge *) hoe.edge.root := top.edge[en].root; hoe.face.exists := top.face[fn].exists; hoe.face.color := top.face[fn].color; hoe.face.transp := top.face[fn].transp; END; IF sa = 1 THEN ho := Spin(ho) END; hd := MakeFacetEdge(); WITH hde = NARROW(hd.facetedge, FacetEdge) DO hde.edge.exists := top.edge[en].exists; hde.edge.color := top.edge[en].color; hde.edge.transp := top.edge[en].transp; hde.edge.radius := top.edge[en].radius; (* set the "root" edge *) hde.edge.root := top.edge[en].root; hde.face.exists := top.face[fn].exists; hde.face.color := top.face[fn].color; hde.face.transp := top.face[fn].transp; END; IF sa = 1 THEN hd := Spin(hd) END; SpliceEdges(ho, Clock(hd)); WITH m = Vhnum(a) DO SetOrg(Clock(ho),ve[m-top.NV]); SetOrg(Clock(hd),ve[m-top.NV]); END; SetOrg(ho, vnew[OrgV(a).num]); SetOrg(hd, vnew[OrgV(Clock(a)).num]); END END END; (* Connect the half-facetedges as in the original triangulation *) FOR ie := 0 TO top.NFE-1 DO WITH a = top.facetedge[ie], b = Fnext(a), c = Enext(a), ha = Half(a), hac = Half(Clock(a)), hb = Half(b), hc = Half(c) DO IF b # a AND Fnext(ha) # hb THEN SetFnext(ha, hb); (* so, Fnext(ha) = hb *) SetEdge(hb, ha.facetedge.edge); END; IF c # a AND Enext(Clock(hac)) # hc THEN SetEnext(Clock(hac), hc); (* so, Enext(Clock(hac) = hc *) END; END; WITH a = Clock(top.facetedge[ie]), b = Fnext(a), c = Enext(a), ha = Half(a), hac= Half(Clock(a)), hb = Half(b), hc = Half(c) DO IF b # a AND Fnext(ha) # hb THEN SetFnext(ha, hb); (* so, Fnext(ha) = hb *) SetEdge(hb, ha.facetedge.edge); END; IF Enext(Clock(hac)) # hc THEN SetEnext(Clock(hac), hc); (* so, Enext(Clock(hac) = hc *) END; END END; FOR j := 0 TO top.NF-1 DO VAR d,e,f,g : Pair; BEGIN WITH fa = top.face[j], fr = fa.root, a = fa.pa, b = Enext(a), c = Enext_1(a), ha = Half(a), hac = Half(Clock(a)), hb = Half(b), hbc = Half(Clock(b)), hc = Half(c), hcc = Half(Clock(c)) DO d := MakeFacetEdge(); d.facetedge.edge.exists := ThinEdgeExists; e := MakeFacetEdge(); e.facetedge.edge.exists := ThinEdgeExists; f := MakeFacetEdge(); f.facetedge.edge.exists := ThinEdgeExists; IF fa.exists AND o.net THEN WITH co = R3.T{1.00,1.00,0.50}, (* color and radius for the thin *) ra = 0.0025, (* edge on the net *) de = d.facetedge.edge, ee = e.facetedge.edge, fe = f.facetedge.edge DO de.exists := TRUE; ee.exists := TRUE; fe.exists := TRUE; de.color := co; de.radius := ra; ee.color := co; ee.radius := ra; fe.color := co; fe.radius := ra; END END; (* Make the first link facetedge *) SetEnext(hc, d); SetEnext(d, Clock(hbc)); SetEnext(Clock(hc), hbc); (* updating origins *) SetOrg(d, Org(Clock(hc))); SetOrg(Clock(d), Org(Clock(hbc))); (* updating component face *) SetFace(hc, d.facetedge.face); SetFace(hbc, d.facetedge.face); d.facetedge.face.exists := top.face[j].exists; d.facetedge.face.color := top.face[j].color; d.facetedge.face.transp := top.face[j].transp; (* Make the second link facetedge *) SetEnext(ha, e); SetEnext(e, Clock(hcc)); SetEnext(Clock(ha), hcc); (* updating origins *) SetOrg(e, Org(Clock(ha))); SetOrg(Clock(e), Org(Clock(hcc))); (* updating component face *) SetFace(ha, e.facetedge.face); SetFace(hcc, e.facetedge.face); e.facetedge.face.exists := top.face[j].exists; e.facetedge.face.color := top.face[j].color; e.facetedge.face.transp := top.face[j].transp; (* Make the third link facetedge *) SetEnext(hac, f); SetEnext(f, Clock(hb)); SetEnext(Clock(hac), hb); (* updating origins *) SetOrg(f, Org(Clock(hac))); SetOrg(Clock(f), Org(Clock(hb))); (* updating component facet *) SetFace(hac, f.facetedge.face); SetFace(hb, f.facetedge.face); f.facetedge.face.exists := top.face[j].exists; f.facetedge.face.color := top.face[j].color; f.facetedge.face.transp := top.face[j].transp; (* Creating Triangular face to insert *) IF top.face[j].exists THEN g := MakeTriangle(TRUE); ELSE g := MakeTriangle(FALSE); END; (* making the connections *) SetFnext(Enext(hc), Clock(g)); SetFnext(Enext(hbc), g); SetFnext(Enext(g), Enext(hcc)); SetFnext(Clock(Enext(g)), Clock(Enext(hcc))); SetFnext(Clock(Enext(hb)), Enext_1(g)); SetFnext(Clock(Enext(hac)),Clock(Enext_1(g))); (* updating the edge component *) SetEdgeAll(g ,d.facetedge.edge); SetEdgeAll(Enext(g) ,e.facetedge.edge); SetEdgeAll(Enext_1(g) ,f.facetedge.edge); (* updating origins *) SetOrg(g, Org(Clock(d))); SetOrg(Clock(g), Org(d)); SetOrg(Enext(g), Org(Clock(e))); SetOrg(Clock(Enext(g)), Org(e)); SetOrg(Enext_1(g), Org(f)); SetOrg(Clock(Enext_1(g)), Org(Clock(f))); g.facetedge.face.color := top.face[j].color; g.facetedge.face.transp := top.face[j].transp; (* set the "root" face *) d.facetedge.face.root := fr; e.facetedge.face.root := fr; f.facetedge.face.root := fr; g.facetedge.face.root := fr; (* end of the setting *) END END END; FOR i := 0 TO top.NFE-1 DO WITH a = top.facetedge[i], ha = Half(a), hac = Half(Clock(a)) DO SetEdgeAll(ha, ha.facetedge.edge); SetEdgeAll(hac, hac.facetedge.edge); END; END; FOR i := 0 TO top.NP-1 DO WITH v = top.region[i], a = Tors(v), af = Fnext_1(a), ae = Enext_1(a), aee = Enext(a) DO <* ASSERT Pneg(a).num = i *> <* ASSERT Org(v).num = i *> IF Ppos(af) # NIL THEN <* ASSERT Pneg(a) = Ppos (af) *> END; gi[i,0] := Clock(Enext(Fnext_1(Enext(Half(a))))); gi[i,1] := Clock(Enext(Fnext(Enext(Half(af))))); gi[i,2] := Clock(Enext(Fnext(Enext(Half(Fnext_1(ae)))))); gi[i,3] := Fnext(Enext(Half(Fnext_1(aee)))); END END; FOR i := 0 TO top.NP-1 DO RefineCell(RowT{gi[i,0],gi[i,1],gi[i,2],gi[i,3]},i); END; ntop := Triangulation.MakeTopology(Half(top.facetedge[1])); WITH nc = NEW(REF Coords, ntop.NV)^, com = "Refined from: " & o.inFileTp & ".tp\n" & "Created by RefineTriang: " & o.outFile & ".tp" DO <* ASSERT ntop.NV = top.NV + top.NE + top.NP *> <* ASSERT ntop.NE = 2*top.NE + 3*top.NF + 6*top.NP*> <* ASSERT ntop.NF = 4*top.NF + 16*top.NP *> <* ASSERT ntop.NP = 12*top.NP *> (*IF top.bdr = 0 THEN <* ASSERT ntop.NFE = 72*top.NP *> END;*) FOR j := 0 TO top.NFE-1 DO WITH a = top.facetedge[j], ou = OrgV(a).num, ov = OrgV(Clock(a)).num, nu = OrgV(Half(a)).num, nv = OrgV(Half(Clock(a))).num, nx = OrgV(Clock(Half(a))).num, ny = OrgV(Clock(Half(Clock(a)))).num DO <* ASSERT nx = ny *> nc[nu] := c[ou]; nc[nv] := c[ov]; nc[nx] := LR4.Scale(0.5d0, LR4.Add(c[ou], c[ov])); END END; IF o.net THEN (* we compute the number of existing faces in the previus topology. *) VAR nefp: CARDINAL := 0; (* existing faces in the previus topology*) neep: CARDINAL := 0; (* existing edges in the previus topology*) neea: CARDINAL := 0; (* existing edges in the actual topology*) BEGIN FOR i := 0 TO top.NF-1 DO WITH f = top.face[i] DO IF f.exists THEN INC(nefp) END END END; FOR i := 0 TO top.NE-1 DO WITH e = top.edge[i] DO IF e.exists THEN INC(neep) END; END END; FOR i := 0 TO ntop.NE-1 DO WITH e = ntop.edge[i] DO IF e.exists THEN INC(neea) END END END; <* ASSERT neea = 3 * nefp + 2 * neep *> END END; FOR i := 0 TO top.NP-1 DO WITH ou = OrgV(gi[i,1]).num, ov = OrgV(Enext_1(gi[i,2])).num DO nc[x[i].num] := LR4.Scale(0.5d0, LR4.Add(nc[ou], nc[ov])); END END; Triangulation.WriteTopology (o.outFile, ntop, com); (*Triangulation.WriteTable (o.outFile, ntop, com);*) Triangulation.WriteState (o.outFile, ntop, nc, com); Triangulation.WriteMaterials(o.outFile, ntop, com, FALSE); (* Now, unmark the attribute "mark" of FacetEdge *) FOR i:= 0 TO top.NFE-1 DO WITH fe = NARROW(top.facetedge[i].facetedge, FacetEdge) DO IF fe.mark THEN fe.mark := FALSE; END; END END END END END END DoIt; PROCEDURE SubdivideEdge(an : Pair; i: INTEGER; net: BOOLEAN) = VAR a,bn,m1,m2,m3,t0,t1,t2: REF ARRAY OF Pair; wn, p: REF ARRAY OF Node; CONST n = 4; BEGIN a := NEW(REF ARRAY OF Pair,n); bn := NEW(REF ARRAY OF Pair,n); m1 := NEW(REF ARRAY OF Pair,n); m2 := NEW(REF ARRAY OF Pair,n); m3 := NEW(REF ARRAY OF Pair,n); t0 := NEW(REF ARRAY OF Pair,n); t1 := NEW(REF ARRAY OF Pair,n); t2 := NEW(REF ARRAY OF Pair,n); (* save the pairs *) a := NEW(REF ARRAY OF Pair,n); a[0] := an; FOR i := 1 TO n-1 DO a[i] := Fnext(a[i-1]); END; (* save the vertices *) wn := NEW(REF ARRAY OF Node,n); FOR i := 0 TO n-1 DO wn[i] := Org(Enext_1(a[i])); END; (* save the polyhedra *) p := NEW(REF ARRAY OF Node,n); FOR i := 0 TO n-1 DO p[i] := Pneg(a[i]); END; (* save other pairs *) bn := NEW(REF ARRAY OF Pair,n); FOR i := 0 TO n-1 DO bn[i] := Clock(Enext_1(Fnext(Enext_1(a[i])))); END; (* insert facetedges and edges *) FOR i := 0 TO n-1 DO m1[i] := MakeFacetEdge(); m2[i] := MakeFacetEdge(); m3[i] := MakeFacetEdge(); t0[i] := MakeTriangle(FALSE); t1[i] := Enext(t0[i]); t2[i] := Enext(t1[i]); (* If net=TRUE the simulates the net with cylinders ans spheres, *) IF net AND bn[i].facetedge.edge.exists THEN t0[i].facetedge.edge.exists := TRUE; t0[i].facetedge.edge.radius := 0.0025; t0[i].facetedge.edge.color := R3.T{1.0,1.0,0.5}; END; WITH f = t0[i].facetedge.face, e1 = t1[i].facetedge.edge, e2 = t2[i].facetedge.edge DO f.exists := FALSE; e1.exists := FALSE; e2.exists := FALSE; END END; (* Now subdivide edge and extend the subdivision on the star of the edge *) x[i] := MakeVertex(); WITH v = NARROW(x[i], Vertex) DO v.exists := FALSE; v.label := "VE"; END; FOR j := 0 TO n-1 DO WITH ee = a[j].facetedge.edge, ff = m2[j].facetedge.edge, b = Enext(a[j]), be = b.facetedge.edge, c = Enext(b), ce = c.facetedge.edge, u = Org(a[j]), v = Org(b), w = Org(c), (* save the attributes of the edge-face component of the pair a[j] *) f = a[j].facetedge.face, g = m3[j].facetedge.face, ge = g.exists, h = m3[j].facetedge.edge DO ee.exists := FALSE; ff.exists := FALSE; SetEnext(a[j],m1[j]); SetEnext(m1[j],c); SetEnext(m2[j],m3[j]); SetEnext(m3[j],Clock(b)); SetOrg(a[j], u); SetOrg(Clock(a[j]), x[i]); SetOrg(m2[j],v); SetOrg(Clock(m2[j]), x[i]); SetOrg(m3[j], x[i]); SetOrg(Clock(m3[j]), w); SetOrg(m1[j], x[i]); SetOrg(Clock(m1[j]), w); SetFnext(m1[j],m3[j]); (* set the attributes for the face component *) ge := FALSE; SetFaceAll(a[j],f); SetFaceAll(m3[j],g); SetEdgeAll(m3[j],h); SetEdgeAll(b,be); SetEdgeAll(c,ce); SetEdgeAll(a[j],ee); SetEdgeAll(m2[j],ff); SetFaceAll(bn[j],bn[j].facetedge.face); SetFaceAll(Fnext_1(bn[j]),Fnext_1(bn[j]).facetedge.face); END END; FOR j := 0 TO n-1 DO SetFnext(Clock(m2[j]),Clock(m2[(j+1) MOD n])); END; WITH ff = m2[0].facetedge.edge DO SetEdgeAll(m2[0],ff); END; FOR j := 0 TO n-1 DO WITH cn = Fnext(bn[j]), e0 = t0[j].facetedge.edge, e1 = t1[j].facetedge.edge, e2 = t2[j].facetedge.edge DO SetAllOrgs(t0[j],wn[j]); SetAllOrgs(t1[j],wn[(j+1) MOD n]); SetAllOrgs(t2[j],x[i]); SetFnext(bn[j], t0[j]); SetFnext(t0[j],cn); SetFnext(m1[j],t2[j]); SetFnext(t2[j],m3[j]); SetFnext(Clock(m1[(j+1) MOD n]), t1[j]); SetFnext(t1[j],Clock(m3[(j+1) MOD n])); SetEdgeAll(t0[j],e0); SetEdgeAll(t1[j],e1); SetEdgeAll(t2[j],e2); SetEdgeAll(Enext(t0[j]),Enext(t0[j]).facetedge.edge); SetEdgeAll(Enext(t1[j]),Enext(t1[j]).facetedge.edge); SetEdgeAll(Enext(t2[j]),Enext(t2[j]).facetedge.edge); END; END; (* insert polyhedra *) FOR j := 0 TO n-1 DO WITH q = Triangulation.MakePolyhedron() DO Triangulation.SetAllPneg(a[j],p[j]); Triangulation.SetAllPneg(m2[j],q); END END; END SubdivideEdge; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFileTp"); o.inFileTp := pp.getNext(); pp.getKeyword("-inFileSt"); o.inFileSt := pp.getNext(); pp.getKeyword("-outFile"); o.outFile := pp.getNext(); o.fixOri := pp.keywordPresent("-fixOri"); o.net := pp.keywordPresent("-net"); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: RefineTriang \\\n"); Wr.PutText(stderr, " -inFileTp \\\n"); Wr.PutText(stderr, " -inFileSt \\\n"); Wr.PutText(stderr, " -outFile \\\n"); Wr.PutText(stderr, " [ -fixOri ] [-assert] [-net]\n"); Process.Exit (1); END END; RETURN o END GetOptions; PROCEDURE MakeTriangle(exists: BOOLEAN) : Pair = (* Make one triangular face and set of the three pairs facetedges with the same face component. If exists is TRUE then the triangular face exists, FALSE otherwise. *) BEGIN WITH a = MakeFacetEdge(), b = MakeFacetEdge(), c = MakeFacetEdge(), f = a.facetedge.face, u = MakeVertex(), v = MakeVertex(), w = MakeVertex() DO IF exists THEN f.exists := TRUE ELSE f.exists := FALSE END; a.facetedge.edge.exists := ThinEdgeExists; SetOrg(a, u); SetOrg(Clock(a),v); b.facetedge.edge.exists := ThinEdgeExists; SetEnext(a,b); SetFace (b,f); SetOrg (b,v); SetOrg(Clock(b),w); c.facetedge.edge.exists := ThinEdgeExists; SetEnext(b,c); SetFace (c,f); SetOrg (c, w); SetOrg(Clock(c), Org(a)); RETURN a END END MakeTriangle; BEGIN DoIt() END RefineTriang. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/RefineTriangGood.m3 MODULE RefineTriangGood EXPORTS Main; (* Refines (or duplicate) a given triangulation (".tp" file). Created in 1999 by L. Lozada (see notice of copyright at the end of this file). This program is inspired in the implementations of Rober M. Rosi and J. Stolfi for the bidimensional case. *) IMPORT Thread, Wr, Process, LR4, Triangulation, Octf, ParseParams; FROM Triangulation IMPORT Coords, Vertex, OrgV, MakeFacetEdge, MakeVertex, SetOrg, Org, Pneg, Ppos, SetNextPneg, MakePolyhedron; FROM Octf IMPORT Pair, Tors, Spin, Clock, Fnext, SpinBit, OrientationBit, SpliceEdges, Enext, SetFnext, SetEnext, SetFace, Enext_1, SetEdge, Fnext_1, SetEdgeAll, Srot; FROM Stdio IMPORT stderr; TYPE Options = RECORD inFileTp: TEXT; (* Input file name (minus ".tp" extension) *) inFileSt: TEXT; (* Input file name (minus ".st" extension) *) outFile: TEXT; (* Output file name prefix *) fixOriginal: BOOLEAN; (* TRUE to fix original vertices *) END; RowT = ARRAY [0..3] OF Pair; PROCEDURE DoIt() = CONST ThinEdgeRadius = 0.0025; <* FATAL Wr.Failure, Thread.Alerted *> VAR NNE: CARDINAL := 0; NNV: CARDINAL := 0; NNP: CARDINAL := 0; gi : REF ARRAY OF ARRAY OF Pair; ntop : Triangulation.Topology; BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToTaMa(o.inFileTp), top = tc.top, rc = Triangulation.ReadState(o.inFileSt), c = rc^, half = NEW(REF ARRAY OF Pair, 2*top.NFE)^, vnew = NEW(REF ARRAY OF Vertex, top.NV)^ DO IF top.der # 3 THEN Wr.PutText(stderr,"This topology isn't a triangulation\n"); Process.Exit(1); END; Wr.PutText(stderr, "Refining from: " & o.inFileTp & ".tp\n"); gi := NEW(REF ARRAY OF ARRAY OF Pair, top.NP, 4); PROCEDURE Half(a: Pair): Pair = BEGIN WITH na = a.facetedge.num, oa = OrientationBit(a), sa = SpinBit(a), h = half[2*na + oa] DO IF sa = 0 THEN RETURN h ELSE RETURN Spin(h) END END END Half; PROCEDURE MakeTriangle() : Pair = (* Make one triangular face and set of the three pairs facetedges with the same face component. *) BEGIN WITH a = MakeFacetEdge(), b = MakeFacetEdge(), c = MakeFacetEdge(), f = a.facetedge.face, u = MakeVertex(), v = MakeVertex(), w = MakeVertex() DO a.facetedge.num := NNE; INC(NNE); a.facetedge.num := NNE; INC(NNE); a.facetedge.edge.radius := ThinEdgeRadius; SetOrg(a, u); SetOrg(Clock(a),v); b.facetedge.num := NNE; INC(NNE); b.facetedge.edge.radius := ThinEdgeRadius; SetEnext(a,b); SetFace(b,f); SetOrg(b,v); SetOrg(Clock(b),w); c.facetedge.num := NNE; INC(NNE); c.facetedge.edge.radius := ThinEdgeRadius; SetEnext(b,c); SetFace(c,f); SetOrg(c, w); SetOrg(Clock(c), Org(a)); RETURN a; END END MakeTriangle; (* ==== Refine the Tetrahedral Cell ==== *) PROCEDURE RefineCell(g: RowT) = BEGIN (* To insert four faces obliques "i", "j", "k", "l" *) WITH i = MakeTriangle(), j = MakeTriangle(), k = MakeTriangle(), l = MakeTriangle() DO (* the facet "i" will be splice with g[1], g[2], g[3] *) SetFnext(i,Clock(g[1])); SetFnext(Enext(i),Enext(g[3])); SetFnext(Enext_1(i),Clock(g[2])); (* updating component edge *) SetEdge(i, g[1].facetedge.edge); SetEdge(Enext(i), Enext(g[3]).facetedge.edge); SetEdge(Enext_1(i), g[2].facetedge.edge); (* updating origins *) SetOrg(i, Org(g[2])); SetOrg(Clock(i), Org(g[1])); SetOrg(Enext(i), Org(Clock(i))); SetOrg(Clock(Enext(i)), Org(Enext(g[2]))); SetOrg(Enext_1(i), Org(Clock(Enext(i)))); SetOrg(Clock(Enext_1(i)), Org(i)); (* the facet "j" will be splice with: g[0], g[1], g[2] *) SetFnext(j,Enext(g[0])); SetFnext(Enext(j),Clock(Enext(g[1]))); SetFnext(Enext_1(j),Clock(Enext_1(g[2]))); (* updating component edge *) SetEdge(j, Enext(g[0]).facetedge.edge); SetEdge(Enext(j), Enext(g[1]).facetedge.edge); SetEdge(Enext_1(j), Enext_1(g[2]).facetedge.edge); (* updating origins *) SetOrg(j, Org(Enext(g[0]))); SetOrg(Clock(j), Org(Enext_1(g[0]))); SetOrg(Enext(j), Org(Clock(j))); SetOrg(Clock(Enext(j)), Org(g[2])); SetOrg(Enext_1(j), Org(Clock(Enext(j)))); SetOrg(Clock(Enext_1(j)), Org(j)); (* the facet "k" will be splice with: g[0], g[1], g[3]) *) SetFnext(k,Clock(Fnext_1(Enext_1(g[0])))); SetFnext(Enext(k),Fnext(Enext_1(g[1]))); SetFnext(Enext_1(k),Clock(Fnext_1(g[3]))); (* updating component edge *) SetEdge(k,Enext_1(g[0]).facetedge.edge); SetEdge(Enext(k),Enext_1(g[1]).facetedge.edge); SetEdge(Enext_1(k),g[3].facetedge.edge); (* updating origins *) SetOrg(k, Org(g[0])); SetOrg(Clock(k), Org(Enext_1(g[0]))); SetOrg(Enext(k), Org(Clock(k))); SetOrg(Clock(Enext(k)), Org(g[1])); SetOrg(Enext_1(k), Org(Clock(Enext(k)))); SetOrg(Clock(Enext_1(k)), Org(k)); (* the facet "l" will be splice with: g[0], g[2], g[3] *) SetFnext(l, Clock(Fnext_1(g[0]))); SetFnext(Enext(l), Clock(Fnext_1(Enext_1(g[3])))); SetFnext(Enext_1(l), Fnext(Enext(g[2]))); (* updating component edge *) SetEdge(l, g[0].facetedge.edge); SetEdge(Enext(l), Enext_1(g[3]).facetedge.edge); SetEdge(Enext_1(l), Enext(g[2]).facetedge.edge); (* updating origins *) SetOrg(l, Org(Clock(g[0]))); SetOrg(Clock(l), Org(g[0])); SetOrg(Enext(l), Org(Clock(l))); SetOrg(Clock(Enext(l)), Org(Enext(g[2]))); SetOrg(Enext_1(l), Org(Clock(Enext(l)))); SetOrg(Clock(Enext_1(l)), Org(l)); (* Subdivision of Octahedron delimitate by vertices mediates *) WITH o1 = MakeTriangle(), o2 = MakeTriangle(), o3 = MakeTriangle(), o4 = MakeTriangle() DO <* ASSERT i = Fnext_1(Clock(g[1])) *> <* ASSERT i = Clock(Fnext(g[1])) *> <* ASSERT i = Clock(Enext_1(Fnext(g[2]))) *> <* ASSERT j = Fnext_1(Enext(g[0])) *> <* ASSERT k = Clock(Fnext_1(Enext_1(g[0]))) *> <* ASSERT k = Clock(Enext_1(Fnext_1(g[3]))) *> <* ASSERT l = Clock(Fnext_1(g[0])) *> (* triangle o1 *) SetFnext(o1, Enext(k)); SetFnext(Enext_1(g[1]), o1); SetFnext(Enext_1(o1), Enext(g[0])); SetFnext(j, Enext_1(o1)); (* updating component edge *) SetEdge(o1, Enext(k).facetedge.edge); SetEdge(Enext_1(o1), j.facetedge.edge); (* updating origins *) SetOrg(o1, Org(Enext_1(g[1]))); SetOrg(Clock(o1), Org(Clock(Enext_1(g[1])))); SetOrg(Enext_1(o1), Org(Enext(g[0]))); SetOrg(Clock(Enext_1(o1)), Org(Clock(Enext(g[0])))); SetOrg(Enext(o1), Org(Enext_1(k))); SetOrg(Clock(Enext(o1)), Org(j)); (* triangle o2 *) SetFnext(Enext(o2), Enext(g[3])); SetFnext(Enext(i), Enext(o2)); SetFnext(Enext_1(o2), Enext_1(l)); SetFnext(Enext(g[2]), Enext_1(o2)); (* updating component edge *) SetEdge(Enext(o2), Enext(g[3]).facetedge.edge); SetEdge(Enext_1(o2), Enext(g[2]).facetedge.edge); (* updating origins *) SetOrg(o2, Org(j)); SetOrg(Clock(o2), Org(Enext_1(k))); SetOrg(Enext(o2), Org(Enext(g[3]))); SetOrg(Clock(Enext(o2)), Org(Clock(Enext(g[3])))); SetOrg(Enext_1(o2), Org(Enext(g[2]))); SetOrg(Clock(Enext_1(o2)), Org(Clock(Enext(g[2])))); (* triangle o3 *) SetFnext(o3, l); SetFnext(Clock(g[0]), o3); SetFnext(Enext(o3), g[3]); SetFnext(Clock(Enext_1(k)), Enext(o3)); (* updating component edge *) SetEdge(o3, l.facetedge.edge); SetEdge(Enext(o3), g[3].facetedge.edge); (* updating origins *) SetOrg(o3, Org(Clock(g[0]))); SetOrg(Clock(o3), Org(g[0])); SetOrg(Enext(o3), Org(g[3])); SetOrg(Clock(Enext(o3)), Org(Clock(g[3]))); SetOrg(Enext_1(o3), Org(Enext_1(k))); SetOrg(Clock(Enext_1(o3)), Org(j)); (* triangle o4 *) SetFnext(g[1], Enext(o4)); SetFnext(Enext(o4), Clock(i)); SetFnext(Enext_1(j), Enext_1(o4)); SetFnext(Enext_1(o4), Clock(Enext_1(g[2]))); SetFnext(o4, o2); SetFnext(o2, Clock(Enext_1(o3))); SetFnext(Clock(Enext_1(o3)), Clock(Enext(o1))); (* updating component edge *) SetEdge(Enext(o4), Clock(i).facetedge.edge); SetEdge(Enext_1(o4), Enext_1(j).facetedge.edge); SetEdgeAll(o2, o2.facetedge.edge); (* updating origins *) SetOrg(Enext(o4), Org(g[1])); SetOrg(Clock(Enext(o4)), Org(Clock(g[1]))); SetOrg(Enext_1(o4), Org(Clock(Enext_1(g[2])))); SetOrg(Clock(Enext_1(o4)), Org(Enext_1(g[2]))); SetOrg(o4, Org(o2)); SetOrg(Clock(o4), Org(Clock(o2))); (* making eigth cell tetrahedral *) SetAllPneg(j); SetAllPneg(Clock(Fnext_1(Enext_1(Fnext(k))))); SetAllPneg(Clock(Fnext_1(Enext(i)))); SetAllPneg(Clock(Fnext_1(Enext(Fnext(l))))); SetAllPneg(Enext_1(Fnext(o1))); SetAllPneg(o2); SetAllPneg(Fnext(o3)); SetAllPneg(o4); (* tests *) <* ASSERT Org(Srot(j)) = Pneg(j) *> <* ASSERT Org(Srot(Clock(Fnext_1(Enext_1(Fnext(k)))))) = Pneg(Clock(Fnext_1(Enext_1(Fnext(k))))) *> <* ASSERT Org(Srot(Clock(Fnext_1(Enext(i))))) = Pneg(Clock(Fnext_1(Enext(i)))) *> <* ASSERT Org(Srot(Clock(Fnext_1(Enext(Fnext(l)))))) = Pneg(Clock(Fnext_1(Enext(Fnext(l))))) *> <* ASSERT Org(Srot(Fnext(o3))) = Pneg(Fnext(o3)) *> <* ASSERT Org(Srot(Enext_1(Fnext(o1)))) = Pneg(Enext_1(Fnext(o1))) *> <* ASSERT Org(Srot(o4)) = Pneg(o4) *> <* ASSERT Org(Srot(o2)) = Pneg(o2) *> WITH v = Srot(j), v1 = Clock(Enext_1(Srot(j))) DO <* ASSERT Pneg(Tors(v)) = Pneg(Tors(v1)) *> END; WITH v = Srot(Fnext(o3)), v1 = Clock(Enext_1(Srot(Fnext(o3)))) DO <* ASSERT Pneg(Tors(v)) = Pneg(Tors(v1)) *> END; WITH v = Srot(o2), v1 = Clock(Enext_1(Srot(o2))) DO <* ASSERT Pneg(Tors(v)) = Pneg(Tors(v1)) *> END; WITH v = Srot(o4), v1 = Clock(Enext_1(Srot(o4))) DO <* ASSERT Pneg(Tors(v)) = Pneg(Tors(v1)) *> END; WITH v = Srot(Enext_1(Fnext(o1))), v1 = Clock(Enext_1(Srot(Enext_1(Fnext(o1))))) DO <* ASSERT Pneg(Tors(v)) = Pneg(Tors(v1)) *> END; WITH v = Srot(Clock(Fnext_1(Enext_1(Fnext(k))))), v1 = Clock(Enext_1(Srot(Clock(Fnext_1(Enext_1(Fnext(k))))))) DO <* ASSERT Pneg(Tors(v)) = Pneg(Tors(v1)) *> END; WITH v = Srot(Clock(Fnext_1(Enext(i)))), v1 = Clock(Enext_1(Srot(Clock(Fnext_1(Enext(i)))))) DO <* ASSERT Pneg(Tors(v)) = Pneg(Tors(v1)) *> END; WITH v = Srot(Clock(Fnext_1(Enext(Fnext(l))))), v1 = Clock(Enext_1(Srot(Clock(Fnext_1(Enext(Fnext(l))))))) DO <* ASSERT Pneg(Tors(v)) = Pneg(Tors(v1)) *> END END END; END RefineCell; PROCEDURE CreateVertex(a: Pair): BOOLEAN = VAR t: Pair := a; BEGIN WITH fe = NARROW(a.facetedge,Triangulation.FacetEdge) DO IF NOT fe.mark THEN fe.mark := TRUE; REPEAT WITH fe = NARROW(t.facetedge,Triangulation.FacetEdge) DO fe.mark := TRUE; END; t := Fnext(t) UNTIL t = a; RETURN TRUE; END; RETURN FALSE; END; END CreateVertex; PROCEDURE SetAllVhnum(a: Pair; n: CARDINAL)= PROCEDURE SetVhnum(a: Pair; n : CARDINAL) = BEGIN WITH fe = NARROW(a.facetedge, Triangulation.FacetEdge) DO fe.vhnum := n; END; END SetVhnum; VAR t: Pair := a; BEGIN REPEAT SetVhnum(t,n); t := Fnext(t); UNTIL t = a; END SetAllVhnum; PROCEDURE SetAllPneg(a : Pair) = (* set the pairs facetdeges belong to same polyhedron *) VAR t : Pair := a; BEGIN WITH p = MakePolyhedron() DO p.num := NNP; INC(NNP); SetNextPneg(t,p); REPEAT SetNextPneg(Clock(Fnext_1(t)),p); t := Enext_1(t); UNTIL t = a; END; END SetAllPneg; PROCEDURE Vhnum(a: Pair): CARDINAL = BEGIN WITH fe = NARROW(a.facetedge, Triangulation.FacetEdge) DO RETURN fe.vhnum; END; END Vhnum; BEGIN (* Copy original vertices, save correspondence in "vnew" array: *) FOR iu := 0 TO top.NV-1 DO WITH u = top.vertex[iu], v = MakeVertex() DO v.num := u.num; v.exists := u.exists; v.fixed := u.fixed OR o.fixOriginal; v.color := u.color; v.radius := u.radius; vnew[iu] := v END END; (* Create two new facetedges for each original facetedge "fe". The new facetedge corresponding to the origin half of "fe", with same spin and orientation, will be | Half(a) = Spin^s(half[2*a.facetedge.num + s]) where s = SpinBit(a), s = OrientationBit(a) *) VAR ve: REF ARRAY OF Vertex := NEW(REF ARRAY OF Vertex, top.NE); i: CARDINAL := 0; BEGIN FOR ie := 0 TO top.NFE-1 DO WITH a = top.facetedge[ie], oa = OrientationBit(a), sa = SpinBit(a), ho = half[2*ie + oa], hd = half[2*ie + 1 - oa], fe = NARROW(a.facetedge, Triangulation.FacetEdge), b = CreateVertex(a) DO IF b THEN ve[i] := MakeVertex(); ve[i].num := top.NV + NNV; INC (NNV); ve[i].exists := top.edge[fe.edge.num].exists; ve[i].fixed := FALSE; ve[i].radius := fe.edge.radius; ve[i].color := fe.edge.color; SetAllVhnum(a, ve[i].num); INC(i); END; ho := MakeFacetEdge(); WITH hoe = NARROW(ho.facetedge, Triangulation.FacetEdge) DO hoe.num := NNE; INC(NNE); hoe.edge.exists := fe.edge.exists; hoe.edge.radius := fe.edge.radius; hoe.edge.color := fe.edge.color; END; IF sa = 1 THEN ho := Spin(ho) END; hd := MakeFacetEdge(); WITH hde = NARROW(hd.facetedge, Triangulation.FacetEdge) DO hde.num := NNE; INC(NNE); hde.edge.exists := fe.edge.exists; hde.edge.radius := fe.edge.radius; hde.edge.color := fe.edge.color; END; IF sa = 1 THEN ho := Spin(ho) END; SpliceEdges(ho, Clock(hd)); WITH m = Vhnum(a) DO SetOrg(Clock(ho),ve[m-top.NV]); SetOrg(Clock(hd),ve[m-top.NV]); END; SetOrg(ho, vnew[OrgV(a).num]); SetOrg(hd, vnew[OrgV(Clock(a)).num]); END; END; END; (* Connect the half-facetedges as in the original triangulation *) FOR ie := 0 TO top.NFE-1 DO WITH a = top.facetedge[ie], b = Fnext(a), c = Enext(a), ha = Half(a), hac = Half(Clock(a)), hb = Half(b), hc = Half(c) DO IF b # a AND Fnext(ha) # hb THEN SetFnext(ha, hb); (* so, Fnext(ha) = hb *) SetEdge(hb, ha.facetedge.edge); END; IF c # a AND Enext(Clock(hac)) # hc THEN SetEnext(Clock(hac), hc); (* so, Enext(Clock(hac) = hc *) END; END; WITH a = Clock(top.facetedge[ie]), b = Fnext(a), c = Enext(a), ha = Half(a), hac = Half(Clock(a)), hb = Half(b), hc = Half(c) DO IF b # a AND Fnext(ha) # hb THEN SetFnext(ha, hb); (* so, Fnext(ha) = hb *) SetEdge(hb, ha.facetedge.edge); END; IF Enext(Clock(hac)) # hc THEN SetEnext(Clock(hac), hc); (* so, Enext(Clock(hac) = hc *) END; END END; FOR j := 0 TO top.NF-1 DO VAR d,e,f,g : Pair; BEGIN WITH a = top.face[j].pa^, b = Enext(a), c = Enext_1(a), ha = Half(a), hac = Half(Clock(a)), hb = Half(b), hbc = Half(Clock(b)), hc = Half(c), hcc = Half(Clock(c)) DO d := MakeFacetEdge(); d.facetedge.num := NNE; INC(NNE); d.facetedge.edge.radius := ThinEdgeRadius; e := MakeFacetEdge(); e.facetedge.num := NNE; INC(NNE); e.facetedge.edge.radius := ThinEdgeRadius; f := MakeFacetEdge(); f.facetedge.num := NNE; INC(NNE); f.facetedge.edge.radius := ThinEdgeRadius; (* first facetedge link *) SetEnext(hc, d); SetEnext(d, Clock(hbc)); SetEnext(Clock(hc), hbc); (* updating Origins *) SetOrg(d, Org(Clock(hc))); SetOrg(Clock(d), Org(Clock(hbc))); (* updating component facet *) SetFace(hc, d.facetedge.face); SetFace(hbc, d.facetedge.face); d.facetedge.face.color := top.face[j].color; d.facetedge.face.transp := top.face[j].transp; (* second facetedge link*) SetEnext(ha, e); SetEnext(e, Clock(hcc)); SetEnext(Clock(ha), hcc); (* updating Origins *) SetOrg(e, Org(Clock(ha))); SetOrg(Clock(e), Org(Clock(hcc))); (* updating component facet *) SetFace(ha, e.facetedge.face); SetFace(hcc, e.facetedge.face); e.facetedge.face.color := top.face[j].color; e.facetedge.face.transp := top.face[j].transp; (* thrid facetedge link *) SetEnext(hac, f); SetEnext(f, Clock(hb)); SetEnext(Clock(hac), hb); (* updating Origins *) SetOrg(f, Org(Clock(hac))); SetOrg(Clock(f), Org(Clock(hb))); (* updating component facet *) SetFace(hac, f.facetedge.face); SetFace(hb, f.facetedge.face); f.facetedge.face.color := top.face[j].color; f.facetedge.face.transp := top.face[j].transp; (* Creating Triangular Face to insert *) g := MakeTriangle(); (* making connections *) SetFnext(Enext(hc), Clock(g)); SetFnext(Enext(hbc), g); SetFnext(Enext(g), Enext(hcc)); SetFnext(Clock(Enext(g)), Clock(Enext(hcc))); SetFnext(Clock(Enext(hb)), Enext_1(g)); SetFnext(Clock(Enext(hac)),Clock(Enext_1(g))); (* updating component edge *) SetEdge(d, Clock(g).facetedge.edge); SetEdge(e, Clock(Enext(g)).facetedge.edge); SetEdge(f, Enext_1(g).facetedge.edge); (* updating Origins *) SetOrg(g, Org(Clock(d))); SetOrg(Clock(g), Org(d)); SetOrg(Enext(g), Org(Clock(e))); SetOrg(Clock(Enext(g)), Org(e)); SetOrg(Enext_1(g), Org(f)); SetOrg(Clock(Enext_1(g)), Org(Clock(f))); g.facetedge.face.color := top.face[j].color; g.facetedge.face.transp := top.face[j].transp; END; END; END; FOR i := 0 TO top.NFE-1 DO WITH a = top.facetedge[i], ha = Half(a), hac = Half(Clock(a)) DO SetEdgeAll(ha, ha.facetedge.edge); SetEdgeAll(hac, hac.facetedge.edge); END; END; FOR i := 0 TO top.NP-1 DO WITH v = top.region[i], a = Tors(v), af = Fnext_1(a), ae = Enext_1(a), aee = Enext(a) DO <* ASSERT Pneg(a).num = i *> <* ASSERT Org(v).num = i *> IF Ppos(af) # NIL THEN <* ASSERT Pneg(a) = Ppos (af) *> END; gi[i,0] := Clock(Enext(Fnext_1(Enext(Half(a))))); gi[i,1] := Clock(Enext(Fnext(Enext(Half(af))))); gi[i,2] := Clock(Enext(Fnext(Enext(Half(Fnext_1(ae)))))); gi[i,3] := Fnext(Enext(Half(Fnext_1(aee)))); END; END; FOR i := 0 TO top.NP-1 DO RefineCell(RowT{gi[i,0],gi[i,1],gi[i,2],gi[i,3]}); END; IF top.bdr = 0 THEN ntop := Triangulation.MakeTopology(Half(top.facetedge[1]),0); ELSE ntop := Triangulation.MakeTopology(Half(top.facetedge[1]),1); END; WITH nc = NEW(REF Coords, ntop.NV)^, comments = "Refined from: " & o.inFileTp & ".tp\n" & "Created by RefineTriang: " & o.outFile & ".tp" DO <* ASSERT ntop.NV = top.NV + top.NE *> <* ASSERT ntop.NE = 2*top.NE + 3*top.NF + top.NP*> <* ASSERT ntop.NF = 4*top.NF + 8*top.NP *> <* ASSERT ntop.NP = 8*top.NP *> IF top.bdr = 0 THEN <* ASSERT ntop.NFE = 48*top.NP *> END; FOR j := 0 TO top.NFE-1 DO WITH a = top.facetedge[j], ou = OrgV(a).num, ov = OrgV(Clock(a)).num, nu = OrgV(Half(a)).num, nv = OrgV(Half(Clock(a))).num, nx = OrgV(Clock(Half(a))).num, ny = OrgV(Clock(Half(Clock(a)))).num DO <* ASSERT nx = ny *> nc[nu] := c[ou]; nc[nv] := c[ov]; nc[nx] := LR4.Scale(0.5d0, LR4.Add(c[ou], c[ov])); END END; Triangulation.WriteTopology(o.outFile, ntop, comments); Triangulation.MakeTopologyTable(o.outFile, ntop, comments); Triangulation.WriteState(o.outFile, ntop, nc, comments); Triangulation.FindDegeneracies(ntop); Triangulation.WriteMaterials(o.outFile, ntop, comments); (* Now, unmark the attribute "mark" of Triangulation.FacetEdge *) FOR i:= 0 TO top.NFE-1 DO WITH fe = NARROW(top.facetedge[i].facetedge, Triangulation.FacetEdge) DO IF fe.mark THEN fe.mark := FALSE; END; END END END END END END DoIt; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFileTp"); o.inFileTp := pp.getNext(); pp.getKeyword("-inFileSt"); o.inFileSt := pp.getNext(); pp.getKeyword("-outFile"); o.outFile := pp.getNext(); o.fixOriginal := pp.keywordPresent("-fixOriginal"); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: RefineTriang \\\n"); Wr.PutText(stderr, " -inFileTp \\\n"); Wr.PutText(stderr, " -inFileSt \\\n"); Wr.PutText(stderr, " -outFile \\\n"); Wr.PutText(stderr, " [ -fixOriginal ] \n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt() END RefineTriangGood. (**************************************************************************) (* *) (* Copyright (C) 1999 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/RootBarycenter.m3 MODULE RootBarycenter EXPORTS Main; (* This program builds the "baricentric subdivision" of a topology (".tp" file) of a given 3D cellular map without boundary or with boundary. See the copyright and authorship futher down. Added the heredity of the "root" attributes for tetrahedra. *) IMPORT Triangulation, Stdio, Wr, Thread, Process, ParseParams, Octf, Bary, R3, Text, Mis, LR4; FROM Stdio IMPORT stderr; FROM Triangulation IMPORT Pair, Org, MakeTopology, PposP, PnegP, OrgV, Vertex, Edge, Face, Pneg, Ppos; FROM Octf IMPORT Fnext, Srot, Clock, Enext, Fnext_1, Enext_1, Spin, Tors; FROM Bary IMPORT Corner, CCorner, SetCorner; CONST order = 2; TYPE Options = RECORD inFile : TEXT; (* Initial guess file name (minus ".tp") *) outFile : TEXT; (* Output file name prefix *) fixed : BOOLEAN; (* Retains the previous geometry *) net : BOOLEAN; (* Implements the net faces *) END; PROCEDURE DoIt() = VAR ps : REF ARRAY OF Pair; nvv,nve,nvf,nvp: CARDINAL := 0; <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToMa(o.inFile, TRUE), top = tc.top, rc = Triangulation.ReadState(o.inFile), c = rc^, NFE = top.NFE, vlt = "VP", vlf = "VF" DO ps := NEW(REF ARRAY OF Pair, NFE); Wr.PutText(stderr, "Subdividing from: " & o.inFile & ".tp\n"); FOR i := 0 TO NFE-1 DO WITH aposp = PposP(top.facetedge[i]), apneg = PnegP(top.facetedge[i]) DO IF (aposp # NIL) AND (apneg #NIL) THEN (* Make one Topological tetrahedron of 2x2 order, for each facetedge in the topology and set the atributes "ca" for each original facetedge. *) ps[i] := Bary.MakeFacetEdge(order,order); WITH fes = NARROW(ps[i].facetedge, Bary.FacetEdge), fet = top.facetedge[i].facetedge, fn = fet.face.num, en = fet.edge.num, on = OrgV(top.facetedge[i]), dn = OrgV(Clock(top.facetedge[i])), ovr = on.radius, ovc = on.color, ovt = on.transp, ovl = on.label, ove = on.exists, dvr = dn.radius, dvc = dn.color, dvt = dn.transp, dvl = dn.label, dve = dn.exists, era = top.edge[en].radius, eco = top.edge[en].color, eta = top.edge[en].transp, eex = top.edge[en].exists, ero = top.edge[en].root, fco = top.face[fn].color, fta = top.face[fn].transp, fex = top.face[fn].exists, fro = top.face[fn].root DO <* ASSERT Octf.OrientationBit(top.facetedge[i]) = 0 *> fet.ca := fes.ca; SetTetraRoot(fet.ca[0],apneg.num,aposp.num,R3.T{1.0,1.0,1.0}); SetDual (fet.ca[3],vlt,vlf,FALSE,TRUE); SetPrimal(fet.ca[0],ovr,ovc,ovt,ovl,ove,dvr,dvc, dvt,dvl,dve,era,eco,eta,eex,ero,fco,fta, fex,fro,FALSE,TRUE,o.net); END END END END; IF NOT IsMapWithBorder(top) THEN FOR i := 0 TO NFE-1 DO WITH pa = top.facetedge[i] DO GlueTetra(pa) END END; WITH newtop = MakeTopology(top.facetedge[NFE-1].facetedge.ca[1]), nc = Triangulation.GenCoords(newtop)^, comments = "Subdivided from: " & o.inFile & ".tp\n" &"Created by Barycenter Subdivision: "&o.outFile & ".tp on " & Mis.Today() DO FOR i := 0 TO newtop.NV-1 DO WITH v = NARROW(newtop.vertex[i],Triangulation.Vertex), vl = v.label DO IF Text.Equal(vl,"VV") THEN INC(nvv); ELSIF Text.Equal(vl,"VE") THEN INC(nve); ELSIF Text.Equal(vl,"VF") THEN INC(nvf); ELSIF Text.Equal(vl,"VP") THEN INC(nvp); END END END; <* ASSERT newtop.NV = nvv + nve + nvf + nvp *> <* ASSERT newtop.NV = top.NV + top.NE + top.NF + top.NP *> <* ASSERT newtop.NF = 8 * top.NFE *> <* ASSERT newtop.NFE = 24 * top.NFE *> <* ASSERT newtop.NP = 4 * top.NFE *> IF o.fixed THEN (* compute new coordinates for vertices of type "VV" and "VE". *) FOR j := 0 TO top.NFE-1 DO WITH a = top.facetedge[j], ou = OrgV(a).num, ov = OrgV(Clock(a)).num, nu = OrgV(Corner(a)).num, nv = OrgV(Corner(Clock(a))).num, nx = OrgV(Clock(Corner(a))).num DO nc[nu] := c[ou]; nc[nv] := c[ov]; nc[nx] := LR4.Scale(0.5d0, LR4.Add(c[ou], c[ov])); END END; (* compute new coordinates for vertices of type "VF". *) FOR j := 0 TO top.NF-1 DO WITH a = top.face[j].pa, uu = OrgV(Clock(Corner(Srot(a)))), (* type VF *) un = NARROW(uu, Vertex), ul = un.label DO <* ASSERT Text.Equal(ul,"VF") *> nc[un.num] := Triangulation.FaceBarycenter(a,c); END END; (* compute new coordinates for vertices of type "VP". *) FOR j := 0 TO top.NP-1 DO WITH a = top.region[j], p = Triangulation.MakePolyhedronTopology(a), b = Tors(a), uu = OrgV(Corner(Srot(b))), un = NARROW(uu, Vertex) DO VAR ba: LR4.T := LR4.T{0.0d0,0.0d0,0.0d0,0.0d0}; BEGIN FOR k := 0 TO p.NV-1 DO WITH ver = p.vRef[k], num = OrgV(ver).num DO ba := LR4.Add(ba,c[num]); END; END; nc[un.num] := LR4.Scale(1.0d0/FLOAT(p.NV,LONGREAL),ba); END END END END; Triangulation.WriteTopology(o.outFile, newtop, comments); Triangulation.WriteState(o.outFile, newtop, nc, comments & "\nRandom Geometry"); Triangulation.WriteMaterials(o.outFile, newtop, comments, TRUE); (* unmark all the facetedges *) FOR i := 0 TO NFE-1 DO WITH fet = top.facetedge[i].facetedge DO fet.marks := FALSE; END END END END END END DoIt; PROCEDURE GlueTetra(a: Pair) = (* Glueing the topological tetrahedra such as the topology. *) BEGIN <* ASSERT a.bits = 0 *> WITH b = Fnext(a), c = Fnext_1(a), d = Enext(a), e = Enext_1(a) DO WITH aa = Corner(a), bb = CCorner(b) DO IF (bb # aa) THEN (* Not yet glued, glue it: *) EVAL Triangulation.Glue(bb, aa, order,TRUE); (* Update Corners to mark this pairs facetedges as glued *) SetCorner(a, bb); SetCorner(Spin(Clock(a)), CCorner(Spin(Clock(b)))); END END; WITH cc = Corner(c), dd = CCorner(a) DO IF (dd # cc) THEN (* Not yet glued, glue it: *) EVAL Triangulation.Glue(dd, cc, order,TRUE); (* Update Corners to mark this pairs facetedges as glued *) SetCorner(c, dd); SetCorner(Spin(Clock(c)), CCorner(Spin(Clock(a)))); END END; WITH ee = Corner(Srot(d)), ff = CCorner(Srot(a)) DO IF (ff # ee) THEN (* Not yet glued, glue it: *) EVAL Triangulation.Glue(ff, ee, order,TRUE); (* Update Corners to mark this pairs facetedges as glued *) SetCorner(Srot(d), ff); SetCorner(Spin(Tors(d)), CCorner(Spin(Tors(a)))); END END; WITH gg = Corner(Srot(a)), hh = CCorner(Srot(e)) DO IF (gg # hh) THEN EVAL Triangulation.Glue(hh, gg, order,TRUE); (* Update Corners to mark this pairs facetedges as glued *) SetCorner(Srot(a), hh); SetCorner(Spin(Tors(a)), CCorner(Spin(Tors(e)))); END END END END GlueTetra; PROCEDURE SetTetraRoot( a : Pair; (* pair of the tetrahedron 2x2 or 1x2 *) rn: CARDINAL; (* root of the Pneg(a) *) rp: CARDINAL; (* root of the Ppos(a) *) co: R3.T; (* color of the Pneg(a) *) ) = PROCEDURE SetAllPnegRoot(a: Pair; ro: CARDINAL) = (* Set the (12) pairs facetedges belonging to same tetrahedron with the same root attribute "ro". *) PROCEDURE SetPnegRoot(b: Pair) = (* Set the polyhedron PnegP(b) with root equal to "ro". *) BEGIN WITH p = Triangulation.PnegP(b) DO p.root := ro; p.color := co; END END SetPnegRoot; PROCEDURE SetNextPnegRoot(c: Pair) = (* Repeat the SetPnegRoot procedure for each pair belonging to the same triangular face. *) VAR t: Pair := c; BEGIN REPEAT SetPnegRoot(t); t := Enext_1(t); UNTIL t = c; END SetNextPnegRoot; VAR t: Pair := a; BEGIN SetNextPnegRoot(t); REPEAT SetNextPnegRoot(Clock(Fnext_1(t))); t := Enext_1(t); UNTIL t = a; END SetAllPnegRoot; BEGIN SetAllPnegRoot(a, rp); SetAllPnegRoot(Clock(Fnext(a)), rn); WITH b = Clock(Enext_1(Fnext(Enext(a)))) DO SetAllPnegRoot(b, rp); SetAllPnegRoot(Clock(Fnext(b)), rn); END; END SetTetraRoot; PROCEDURE SetPrimal( a: Pair; (* pair of the topological tetrahedron 2x2 or 1x2 *) ovr: REAL; (* origen vertex radius *) ovc: R3.T; (* origen vertex color *) ovt: R3.T; (* origen vertex transparency *) ovl: TEXT; (* origen vertex label *) ove: BOOLEAN; dvr: REAL; (* destine vertex radius *) dvc: R3.T; (* destine vertex color *) dvt: R3.T; (* destine vertex transparency *) dvl: TEXT; (* destine vertex label *) dve: BOOLEAN; era: REAL; (* edge radius *) eco: R3.T; (* edge color *) eta: R3.T; (* edge transparency *) eex: BOOLEAN; (* edge exists *) ero: INTEGER; (* edge root *) fco: R3.T; (* face color *) fta: R3.T; (* face transparency *) fex: BOOLEAN; (* face exists *) fro: INTEGER; (* face root *) mid: BOOLEAN; (* TRUE iff the topological tetrahedron is 1x2 *) side: BOOLEAN; (* indicate the side of the topological tetrahedron 1x2 *) net : BOOLEAN; (* simulates a grade with thin cylindres and spheres *) ) = PROCEDURE SetVertex( v: Vertex; e: BOOLEAN; (* exists *) c: R3.T; (* color *) t: R3.T; (* transp *) r: REAL; (* radius *) l: TEXT; (* label *) ) = BEGIN v.exists := e; v.color := c; v.transp := t; v.label := l; v.radius := r; END SetVertex; PROCEDURE SetGhostFace(a: Pair) = BEGIN WITH t = NARROW(a.facetedge.face, Face) DO t.exists := FALSE; END; END SetGhostFace; PROCEDURE NewSetTriangle( b: Pair; e: BOOLEAN; (* exists *) c: R3.T; (* color *) t: R3.T; (* transp *) r: INTEGER; (* root *) ) = BEGIN WITH f = NARROW(b.facetedge.face, Face) DO f.exists := e; f.color := c; f.transp := t; f.root := r; END END NewSetTriangle; PROCEDURE NewSetEdge( b: Pair; e: BOOLEAN; (* exists *) c: R3.T; (* color *) t: R3.T; (* transp *) ra: REAL; (* radius *) ro: INTEGER; (* root *) ) = BEGIN WITH ee = NARROW(b.facetedge.edge, Edge) DO ee.exists := e; ee.color := c; ee.transp := t; ee.radius := ra; ee.root := ro; END END NewSetEdge; BEGIN (* set the origin of the pair ca[0] *) SetVertex(Org(a), ove, ovc, ovt, ovr, ovl); (* set the origin of the pair Clock(ca[0]) *) SetVertex(Org(Clock(a)), eex, eco, eta, era, "VE"); (* set the edge component of the topological tetrahedron *) NewSetEdge(a, eex, eco, eta, era, ero); WITH b = Clock(Enext_1(Fnext(Enext(a)))) DO SetVertex(Org(Clock(b)), dve, dvc, dvt, dvr, dvl); NewSetEdge(b, eex, eco, eta, era, ero); END; IF NOT mid THEN SetGhostFace(a); SetGhostFace(Fnext(a)); NewSetTriangle(Fnext_1(a), fex, fco, fta, fro); WITH b = Clock(Enext_1(Fnext(Enext(a)))) DO SetGhostFace(b); SetGhostFace(Fnext(b)); NewSetTriangle(Fnext_1(b), fex, fco, fta, fro); END; IF net THEN WITH X = Enext_1(Fnext_1(a)).facetedge.edge, Y = Enext (Fnext_1(a)).facetedge.edge, Z = Clock(Enext_1(Fnext(Enext(a)))), W = Enext (Fnext_1(Z)).facetedge.edge, S = OrgV(Enext_1(Fnext_1(a))), co = R3.T{1.00,1.000,0.500}, (* color, transparency and radius *) tp = R3.T{0.00,0.000,0.000}, (* of the thin cylinder and sohere*) ra = 0.0025 DO X.exists := TRUE; Y.exists := TRUE; W.exists := TRUE; S.exists := TRUE; X.color := co; X.radius := ra; X.transp := tp; Y.color := co; Y.radius := ra; Y.transp := tp; W.color := co; W.radius := ra; W.transp := tp; S.color := co; S.radius := ra; S.transp := tp; END END ELSIF mid THEN IF side THEN SetGhostFace(a); NewSetTriangle(Fnext_1(a), fex, fco, fta, fro); WITH b = Clock(Enext_1(Fnext(Enext(a)))) DO SetGhostFace(b); NewSetTriangle(Fnext_1(b), fex, fco, fta, fro); END ELSE SetGhostFace(Fnext_1(a)); NewSetTriangle(a, fex, fco, fta, fro); WITH an = Clock(Enext_1(Fnext_1(Enext(Fnext_1(a))))) DO SetGhostFace(an); NewSetTriangle(Fnext_1(an), fex, fco, fta, fro); END END END END SetPrimal; PROCEDURE SetDual( a: Pair; vlt: TEXT; vlf: TEXT; mid: BOOLEAN; side: BOOLEAN; ) = PROCEDURE SetVertex(v: Vertex; label: TEXT) = BEGIN WITH vv = NARROW(v, Vertex) DO vv.exists := FALSE; vv.label := label; END; END SetVertex; PROCEDURE SetGhostFace(a: Pair) = BEGIN WITH t = NARROW(a.facetedge.face, Face) DO t.exists := FALSE; END; END SetGhostFace; PROCEDURE SetGhostEdge(a: Pair) = BEGIN WITH t = NARROW(a.facetedge.edge, Edge) DO t.exists := FALSE; END; END SetGhostEdge; PROCEDURE SetRowEdge(d: Pair; r: CARDINAL) = VAR dn: Pair := d; BEGIN IF r = 3 THEN FOR j := 0 TO r-1 DO IF j=0 THEN FOR i := 0 TO r-1 DO SetGhostEdge(dn); dn := Enext(dn); END; END; dn := Fnext_1(dn); SetGhostEdge(Enext(dn)); SetGhostEdge(Enext_1(dn)); END; ELSIF r = 2 THEN FOR j := 0 TO r-1 DO IF j=0 THEN FOR i := 0 TO r-1 DO SetGhostEdge(dn); dn := Enext(dn); END; dn := Enext(dn); END; dn := Fnext_1(dn); SetGhostEdge(Enext(dn)); END; END; END SetRowEdge; PROCEDURE SetRowTriangle(b: Pair) = BEGIN FOR i := 0 TO 2 DO SetGhostFace(b); b := Fnext_1(b); END; END SetRowTriangle; BEGIN IF mid AND side THEN SetVertex(Org(a), vlf); SetVertex(Org(Clock(a)), vlt); SetRowTriangle(a); SetRowEdge(a,3); ELSIF mid AND (NOT side) THEN SetVertex(Org(a), vlt); SetVertex(Org(Clock(a)), vlf); SetRowTriangle(a); SetRowEdge(a,3); ELSIF NOT mid THEN SetVertex(Org(a), vlt); SetVertex(Org(Clock(a)), vlf); SetRowTriangle(a); SetRowEdge(a,3); WITH an = Enext_1(Fnext(Enext(a))) DO SetVertex(Org(an),vlt); SetRowTriangle(an); SetRowEdge(Clock(an),2); END END END SetDual; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFile"); o.inFile := pp.getNext(); pp.getKeyword("-outFile"); o.outFile := pp.getNext(); o.fixed := pp.keywordPresent("-fixed"); o.net := pp.keywordPresent("-net"); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: RootBarycenter" ); Wr.PutText(stderr, " -inFile -outFile \\\n"); Wr.PutText(stderr, " [ -fixed ] [ -net ] \n"); Process.Exit (1); END END; RETURN o END GetOptions; PROCEDURE IsMapWithBorder(READONLY top:Triangulation.Topology) : BOOLEAN = BEGIN FOR i := 0 TO top.NFE-1 DO WITH a = top.facetedge[i], n = Pneg(a), p = Ppos(a) DO IF (n=NIL) AND (p=NIL) THEN RETURN TRUE END; END END; RETURN FALSE; END IsMapWithBorder; BEGIN DoIt() END RootBarycenter. (**************************************************************************) (* *) (* Copyright (C) 2001 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/Round.m3 MODULE Round EXPORTS Main; IMPORT Stdio, Wr, Fmt, Thread; VAR a,b,c,d : REAL; <* FATAL Wr.Failure, Thread.Alerted *> BEGIN a := 79.499; b := 202.50; c := 38.51; d := 142.4; Wr.PutText(Stdio.stdout, " a = " & Fmt.Int(ROUND(a)) & " b = " & Fmt.Int(ROUND(b)) & " c = " & Fmt.Int(ROUND(c)) & " d = " & Fmt.Int(ROUND(d)) & "\n"); END Round. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/SelectSubdivision.m3 MODULE SelectSubdivision EXPORTS Main; (* This module implements the "selective subdivision" of the k-elements ( 1 <= k <=3) of a given 3D cellular map that are involved in geometric degeneracies. The option "element" allows to choose the selective subdivision of the k-element. The selective subdivision of a k-element also propagates the subdivision of their star (neighbors elements). Implemented by L. P. Lozada (see the copyright and authorship futher down). Revisions: 08-06-2000: Fixed and removed a bug that increases the number of original elements. 11-06-2000: Added the heredity of the "root" attributes for edges and faces, and we optimize the code. Hidden the new elements insert in the refiment process: faces, edges and vertices are set with the attibute "exists= FALSE". *) IMPORT Triangulation, Stdio, Wr, Thread, Process, ParseParams, Octf, Squared, R3, Text, Mis; FROM Stdio IMPORT stderr; FROM Triangulation IMPORT Pair, Org, MakeTopology, Node, Vertex, MakePolyhedron, MakeFacetEdge, MakeVertex, SetOrg, SetAllOrgs, Pneg, SetAllPneg, Topology; FROM Octf IMPORT Fnext, Clock, Enext, Enext_1, Fnext_1, SetEnext, Spin, SetEdgeAll, SetFaceAll, SetFnext, Tors; FROM Squared IMPORT MakeTriangle; VAR NVE: CARDINAL := 0; NVF: CARDINAL := 0; NVP: CARDINAL := 0; TYPE Element = { Edge, Face, Tetrahedron }; Options = RECORD inFile: TEXT; (* Initial guess file name (minus ".tp") *) outFile: TEXT; (* Output file name prefix *) element: Element; elename: TEXT; END; PROCEDURE DoIt() = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToMa(o.inFile), top = tc.top DO IF o.element = Element.Edge THEN (* Rescue the overall attributes of the triangulation *) FOR i:= 0 TO top.NFE-1 DO WITH p = top.facetedge[i], e = p.facetedge.edge, en = e.num, f = p.facetedge.face, fn = f.num DO IF top.face[fn].exists THEN p.facetedge.face.exists := TRUE; ELSE p.facetedge.face.exists := FALSE; END; IF top.edge[en].exists THEN p.facetedge.edge.exists := TRUE; ELSE p.facetedge.edge.exists := FALSE; END; p.facetedge.face.root := top.face[fn].root; p.facetedge.edge.root := top.edge[en].root; END END; (* Subdivision of degenerative edges *) Wr.PutText(stderr, "Eliminating degenerative edges\n"); FOR j := 0 TO top.NE-1 DO WITH e = top.edge[j] DO IF e.degenerate THEN WITH a = e.pa, dfr = Octf.DegreeFaceRing(a) DO SubdivideEdge(a,dfr,top); END END END END END; IF o.element = Element.Face THEN (* Rescue the overall attributes of the triangulation *) FOR i:= 0 TO top.NFE-1 DO WITH p = top.facetedge[i], e = p.facetedge.edge, en = e.num, f = p.facetedge.face, fn = f.num DO p.facetedge.face.root := top.face[fn].root; p.facetedge.edge.root := top.edge[en].root; END END; (* Subdivision of degenerative faces *) Wr.PutText(stderr, "Eliminating degenerative faces\n"); FOR j := 0 TO top.NF-1 DO WITH f = top.face[j], a = f.pa DO IF f.degenerate THEN SubdivideFace(a,top); END END END END; IF o.element = Element.Tetrahedron THEN (* Rescue the overall attributes of the triangulation *) FOR i:= 0 TO top.NFE-1 DO WITH p = top.facetedge[i], e = p.facetedge.edge, en = e.num, f = p.facetedge.face, fn = f.num DO p.facetedge.face.root := top.face[fn].root; p.facetedge.edge.root := top.edge[en].root; END END; (* Subdivision of degenerative tetrahedra *) Wr.PutText(stderr, "Eliminating degenerative tetrahedra\n"); FOR j := 0 TO top.NP-1 DO WITH p = top.polyhedron[j], r = top.region[j], a = Tors(r) DO IF p.degenerate THEN SubdivideTetrahedron(a,top); END END END END; WITH newtop = MakeTopology(top.facetedge[0]), nc = Triangulation.GenCoords(newtop)^, comments = "Created by Selective Subdivision of " & o.elename & " : " & o.outFile DO Triangulation.WriteTopology(o.outFile, newtop, comments & ".tp\n" & "on " & Mis.Today() ); Triangulation.WriteState(o.outFile,newtop,nc, comments & ".st\n" & "on "&Mis.Today() & "\nRandom Geometry"); Triangulation.WriteMaterials(o.outFile, newtop, comments & ".ma\n" & "on " & Mis.Today() ); END; END END DoIt; PROCEDURE SubdivideEdge( an: Pair; n: CARDINAL; READONLY top: Triangulation.Topology; ) = VAR x: Node; a,bn,m1,m2,m3,t0,t1,t2: REF ARRAY OF Pair; wn,p: REF ARRAY OF Node; BEGIN a := NEW(REF ARRAY OF Pair,n); bn := NEW(REF ARRAY OF Pair,n); m1 := NEW(REF ARRAY OF Pair,n); m2 := NEW(REF ARRAY OF Pair,n); m3 := NEW(REF ARRAY OF Pair,n); t0 := NEW(REF ARRAY OF Pair,n); t1 := NEW(REF ARRAY OF Pair,n); t2 := NEW(REF ARRAY OF Pair,n); (* save the pairs *) a := NEW(REF ARRAY OF Pair,n); a[0] := an; WITH f = a[0].facetedge.face, e = a[0].facetedge.edge, ee = Enext(a[0]).facetedge.edge, ee_ = Enext_1(a[0]).facetedge.edge DO IF top.face[f.num].exists THEN f.exists := TRUE; ELSE f.exists := FALSE; END; f.color := top.face[f.num].color; f.transp := top.face[f.num].transp; f.root := top.face[f.num].root; IF top.edge[e.num].exists THEN e.exists := TRUE; ELSE e.exists := FALSE; END; e.color := top.edge[e.num].color; e.transp := top.edge[e.num].transp; e.radius := top.edge[e.num].radius; e.root := top.edge[e.num].root; IF top.edge[ee.num].exists THEN ee.exists := TRUE; ELSE ee.exists := FALSE; END; ee.color := top.edge[ee.num].color; ee.transp := top.edge[ee.num].transp; ee.radius := top.edge[ee.num].radius; ee.root := top.edge[e.num].root; IF top.edge[ee_.num].exists THEN ee_.exists := TRUE; ELSE ee_.exists := FALSE; END; ee_.color := top.edge[ee_.num].color; ee_.transp := top.edge[ee_.num].transp; ee_.radius := top.edge[ee_.num].radius; ee_.root := top.edge[ee_.num].root; END; FOR i := 1 TO n-1 DO a[i] := Fnext(a[i-1]); WITH f = a[i].facetedge.face, ee = Enext(a[i]).facetedge.edge, ee_ = Enext_1(a[i]).facetedge.edge DO IF top.face[f.num].exists THEN f.exists := TRUE; ELSE f.exists := FALSE; END; f.color := top.face[f.num].color; f.transp := top.face[f.num].transp; f.root := top.face[f.num].root; IF top.edge[ee.num].exists THEN ee.exists := TRUE; ELSE ee.exists := FALSE; END; ee.color := top.edge[ee.num].color; ee.transp := top.edge[ee.num].transp; ee.radius := top.edge[ee.num].radius; ee.root := top.edge[ee.num].root; IF top.edge[ee_.num].exists THEN ee_.exists := TRUE; ELSE ee_.exists := FALSE; END; ee_.color := top.edge[ee_.num].color; ee_.transp := top.edge[ee_.num].transp; ee_.radius := top.edge[ee_.num].radius; ee_.root := top.edge[ee_.num].root; END END; (* save the vertices *) wn := NEW(REF ARRAY OF Node,n); FOR i := 0 TO n-1 DO wn[i] := Org(Enext_1(a[i])); END; (* save the tetrahedra *) p := NEW(REF ARRAY OF Node,n); FOR i := 0 TO n-1 DO p[i] := Pneg(a[i]); END; (* save other pairs *) bn := NEW(REF ARRAY OF Pair,n); FOR i := 0 TO n-1 DO bn[i] := Clock(Enext_1(Fnext(Enext_1(a[i])))); WITH e = bn[i].facetedge.edge, f = bn[i].facetedge.face DO IF top.edge[e.num].exists THEN e.exists := TRUE; ELSE e.exists := FALSE; END; e.color := top.edge[e.num].color; e.transp := top.edge[e.num].transp; e.radius := top.edge[e.num].radius; e.root := top.edge[e.num].root; IF top.face[f.num].exists THEN f.exists := TRUE; ELSE f.exists := FALSE; END; f.color := top.face[f.num].color; f.transp := top.face[f.num].transp; f.root := top.face[f.num].root; END END; (* insert new pairs facetedges *) FOR i := 0 TO n-1 DO m1[i] := MakeFacetEdge(); (* edge component always FALSE *) m2[i] := MakeFacetEdge(); (* edge component will depend *) m3[i] := MakeFacetEdge(); (* edge component always FALSE *) t0[i] := MakeTriangle(); (* edge component will depend *) t1[i] := Enext(t0[i]); (* edge component always FALSE *) t2[i] := Enext(t1[i]); (* edge component always FALSE *) WITH f0 = t0[i].facetedge.face, f1 = t1[i].facetedge.face, f2 = t2[i].facetedge.face, e0 = t0[i].facetedge.edge, e1 = t1[i].facetedge.edge, e2 = t2[i].facetedge.edge, em1 = m1[i].facetedge.edge, em2 = m2[i].facetedge.edge, em3 = m3[i].facetedge.edge, fm1 = m1[i].facetedge.face, fm2 = m2[i].facetedge.face, fm3 = m3[i].facetedge.face DO (* with respect to m1[i], m2[i] and m3[i] *) (* edges *) em1.exists := FALSE; em3.exists := FALSE; IF a[i].facetedge.edge.exists THEN em2.exists := TRUE; ELSE em2.exists := FALSE; END; em2.root := a[i].facetedge.edge.root; (* faces *) IF a[i].facetedge.face.exists THEN fm1.exists := TRUE; fm2.exists := TRUE; fm3.exists := TRUE; ELSE fm1.exists := FALSE; fm2.exists := FALSE; fm3.exists := FALSE; END; (* with respect to insert face *) (* edges *) e1.exists := FALSE; e2.exists := FALSE; IF bn[i].facetedge.edge.exists THEN e0.exists := TRUE; ELSE e0.exists := FALSE; END; (* faces *) f0.exists := FALSE; f1.exists := FALSE; f2.exists := FALSE; END END; (* Now, subdivide edge and extend the subdivision on the edge's stars *) x := MakeVertex(); WITH v = NARROW(x, Vertex) DO v.label := "VE"; IF a[0].facetedge.edge.exists THEN v.exists := TRUE; v.radius := a[0].facetedge.edge.radius; v.color := a[0].facetedge.edge.color; v.transp := a[0].facetedge.edge.transp; ELSE v.exists := FALSE; END; v.num := NVE; INC(NVE); END; FOR j := 0 TO n-1 DO WITH b = Enext(a[j]), be = b.facetedge.edge, c = Enext(b), ce = c.facetedge.edge, u = Org(a[j]), v = Org(b), w = Org(c), (* save the attributes of the edge-face component of the pair a[j] *) f = a[j].facetedge.face, fn = f.num, ff = top.face[fn], fe = ff.exists, fc = ff.color, ft = ff.transp, g = m3[j].facetedge.face, ge = g.exists, gc = g.color, gt = g.transp, p = m1[j].facetedge.face, pe = p.exists, pc = p.color, pt = p.transp, h = m3[j].facetedge.edge DO SetEnext(a[j],m1[j]); SetEnext(m1[j],c); SetEnext(m2[j],m3[j]); SetEnext(m3[j],Clock(b)); SetOrg(a[j], u); SetOrg(Clock(a[j]), x); SetOrg(m2[j],v); SetOrg(Clock(m2[j]), x); SetOrg(m3[j], x); SetOrg(Clock(m3[j]), w); SetOrg(m1[j], x); SetOrg(Clock(m1[j]), w); SetFnext(m1[j],m3[j]); (* set the attributes for the face component *) SetFaceAll(a[j],f); SetFaceAll(m3[j],g); IF fe THEN ge := TRUE; pe := TRUE; ELSE ge := FALSE; pe := FALSE; END; gc := fc; pc := fc; gt := ft; pt := ft; SetEdgeAll(m3[j],h); SetEdgeAll(b,be); SetEdgeAll(c,ce); SetFaceAll(bn[j],bn[j].facetedge.face); SetFaceAll(Fnext(bn[j]),Fnext(bn[j]).facetedge.face); END END; FOR j := 0 TO n-1 DO SetFnext(Clock(m2[j]),Clock(m2[(j+1) MOD n])); END; WITH k = m2[0].facetedge.edge, q = m2[0].facetedge.face, f = a[0].facetedge.face, e = a[0].facetedge.edge, en = e.num, ea = top.edge[en], ee = ea.exists, er = ea.radius, ec = ea.color, et = e.transp, fn = f.num, fa = top.face[fn], fe = fa.exists, fc = fa.color, ft = fa.transp, ke = k.exists, kr = k.radius, kc = k.color, kt = k.transp, qe = q.exists, qc = q.color, qt = q.transp DO IF ee THEN ke := TRUE; ELSE ke := FALSE; END; kr := er; kc := ec; kt := et; SetEdgeAll(a[0],e); SetEdgeAll(m2[0],k); IF fe THEN qe := TRUE; ELSE qe := FALSE; END; qc := fc; qt := ft; END; FOR j := 0 TO n-1 DO WITH cn = Fnext(bn[j]), e1 = t1[j].facetedge.edge, e2 = t2[j].facetedge.edge, cnf = cn.facetedge.face, cne = cn.facetedge.edge DO IF top.face[cnf.num].exists THEN cnf.exists := TRUE; ELSE cnf.exists := FALSE; END; cnf.color := top.face[cnf.num].color; cnf.transp := top.face[cnf.num].transp; IF top.edge[cne.num].exists THEN cne.exists := TRUE; ELSE cne.exists := FALSE; END; cne.color := top.edge[cne.num].color; cne.transp := top.edge[cne.num].transp; cne.radius := top.edge[cne.num].radius; (* set the origins *) SetAllOrgs(t0[j],wn[j]); SetAllOrgs(t1[j],wn[(j+1) MOD n]); SetAllOrgs(t2[j],x); SetFnext(bn[j], t0[j]); SetFnext(t0[j],cn); SetFnext(m1[j],t2[j]); SetFnext(t2[j],m3[j]); SetFnext(Clock(m1[(j+1) MOD n]), t1[j]); SetFnext(t1[j],Clock(m3[(j+1) MOD n])); SetEdgeAll(t0[j],cn.facetedge.edge); SetEdgeAll(t1[j],e1); SetEdgeAll(t2[j],e2); END END; (* insert polyhedra *) FOR j := 0 TO n-1 DO WITH q = Triangulation.MakePolyhedron() DO SetAllPneg(a[j],p[j]); SetAllPneg(m2[j],q); END END END SubdivideEdge; PROCEDURE SubdivideFace(a: Pair; READONLY top: Triangulation.Topology) = (* Subdivide a degenerative triangular face in three new faces through the insertion of a new medial vertex of type "VF" and six face-edge pairs. Then, expand this subdivision on the face's star. *) VAR x: Node; BEGIN (* Create the medial vertex "VF" *) x := MakeVertex(); WITH v = NARROW(x, Vertex) DO v.exists:= FALSE; v.label := "VF"; v.num := NVF; INC(NVF); END; WITH fa = a.facetedge.face, ea = a.facetedge.edge, b = Enext(a), eb = b.facetedge.edge, c = Enext_1(a), ec = c.facetedge.edge, af = Fnext(a), bf = Fnext(b), cf = Fnext(c), af_ = Fnext_1(a), bf_ = Fnext_1(b), cf_ = Fnext_1(c), eaf = Enext_1(af).facetedge.edge, eaf_ = Enext_1(af_).facetedge.edge, faf = af.facetedge.face, faf_ = af_.facetedge.face, ebf = Enext_1(bf).facetedge.edge, ebf_ = Enext_1(bf_).facetedge.edge, fbf = bf.facetedge.face, fbf_ = bf_.facetedge.face, ecf = Enext_1(cf).facetedge.edge, ecf_ = Enext_1(cf_).facetedge.edge, fcf = cf.facetedge.face, fcf_ = cf_.facetedge.face, u = Org(a), v = Org(b), w = Org(c), d = MakeFacetEdge(), e = MakeFacetEdge(), f = MakeFacetEdge(), g = MakeFacetEdge(), h = MakeFacetEdge(), i = MakeFacetEdge(), df = d.facetedge.face, ff = f.facetedge.face, hf = h.facetedge.face, (* new faces to insert on the face's star *) f1 = MakeTriangle(), f2 = MakeTriangle(), f3 = MakeTriangle(), f4 = MakeTriangle(), f5 = MakeTriangle(), f6 = MakeTriangle(), q1 = MakePolyhedron(), q2 = MakePolyhedron(), q3 = MakePolyhedron(), q4 = MakePolyhedron(), q5 = MakePolyhedron(), q6 = MakePolyhedron() DO WITH t = top.face[fa.num], tc = t.color, tt = t.transp, tr = t.root DO IF t.exists THEN df.exists := TRUE; ff.exists := TRUE; hf.exists := TRUE; df.color := tc; df.transp := tt; df.root := tr; ff.color := tc; ff.transp := tt; ff.root := tr; hf.color := tc; hf.transp := tt; hf.root := tr; ELSE df.exists := FALSE; ff.exists := FALSE; hf.exists := FALSE; df.root := tr; ff.root := tr; hf.root := tr; END END; (* first link connecting the pair "a" *) SetEnext(a,d); SetEnext(d,e); SetEnext(e,a); SetFaceAll(d,df); (* second link connecting the pair "b" *) SetEnext(b,f); SetEnext(f,g); SetEnext(g,b); SetFaceAll(f,ff); (* third link connecting the pair "c" *) SetEnext(c,h); SetEnext(h,i); SetEnext(i,c); SetFaceAll(h,hf); (* save information about the original edge "a.facetedge.edge": "ea" *) ea.exists := top.edge[ea.num].exists; ea.color := top.edge[ea.num].color; ea.transp := top.edge[ea.num].transp; ea.radius := top.edge[ea.num].radius; (* save information about the original edge "b.facetedge.edge": "eb" *) eb.exists := top.edge[eb.num].exists; eb.color := top.edge[eb.num].color; eb.transp := top.edge[eb.num].transp; eb.radius := top.edge[eb.num].radius; (* save information about the original edge "c.facetedge.edge": "ec" *) ec.exists := top.edge[ec.num].exists; ec.color := top.edge[ec.num].color; ec.transp := top.edge[ec.num].transp; ec.radius := top.edge[ec.num].radius; (* save information about the face "af.facetedge.face" : "faf" *) faf.exists := top.face[faf.num].exists; faf.color := top.face[faf.num].color; faf.transp := top.face[faf.num].transp; (* save information about the edge "af.facetedge.edge" : "eaf" *) eaf.exists := top.edge[eaf.num].exists; eaf.color := top.edge[eaf.num].color; eaf.transp := top.edge[eaf.num].transp; eaf.radius := top.edge[eaf.num].radius; (* save information about the face "af_.facetedge.face" : "faf_" *) faf_.exists := top.face[faf_.num].exists; faf_.color := top.face[faf_.num].color; faf_.transp:= top.face[faf_.num].transp; (* save information about the edge "af_.facetedge.edge" : "eaf_" *) eaf_.exists := top.edge[eaf_.num].exists; eaf_.color := top.edge[eaf_.num].color; eaf_.transp := top.edge[eaf_.num].transp; eaf_.radius := top.edge[eaf_.num].radius; (* save information about the face "bf.facetedge.face" : "fbf" *) fbf.exists := top.face[fbf.num].exists; fbf.color := top.face[fbf.num].color; fbf.transp:= top.face[fbf.num].transp; (* save information about the edge "bf.facetedge.edge" : "ebf" *) ebf.exists := top.edge[ebf.num].exists; ebf.color := top.edge[ebf.num].color; ebf.transp := top.edge[ebf.num].transp; ebf.radius := top.edge[ebf.num].radius; (* save information about the face "bf_.facetedge.face" : "fbf_" *) fbf_.exists:= top.face[fbf_.num].exists; fbf_.color := top.face[fbf_.num].color; fbf_.transp:= top.face[fbf_.num].transp; (* save information about the edge "bf_.facetedge.edge" : "ebf_" *) ebf_.exists := top.edge[ebf_.num].exists; ebf_.color := top.edge[ebf_.num].color; ebf_.transp := top.edge[ebf_.num].transp; ebf_.radius := top.edge[ebf_.num].radius; (* save information about the face "cf.facetedge.face" : "fcf" *) fcf.exists := top.face[fcf.num].exists; fcf.color := top.face[fcf.num].color; fcf.transp:= top.face[fcf.num].transp; (* save information about the edge "cf.facetedge.edge" : "ecf" *) ecf.exists := top.edge[ecf.num].exists; ecf.color := top.edge[ecf.num].color; ecf.transp := top.edge[ecf.num].transp; ecf.radius := top.edge[ecf.num].radius; (* save information about the face "cf_.facetedge.face" : "fcf_" *) fcf_.exists := top.face[fcf_.num].exists; fcf_.color := top.face[fcf_.num].color; fcf_.transp:= top.face[fcf_.num].transp; (* save information about the edge "cf_.facetedge.edge" : "ecf_" *) ecf_.exists := top.edge[ecf_.num].exists; ecf_.color := top.edge[ecf_.num].color; ecf_.transp := top.edge[ecf_.num].transp; ecf_.radius := top.edge[ecf_.num].radius; (* set the attributes for the internal faces *) f1.facetedge.face.exists := FALSE; f2.facetedge.face.exists := FALSE; f3.facetedge.face.exists := FALSE; f4.facetedge.face.exists := FALSE; f5.facetedge.face.exists := FALSE; f6.facetedge.face.exists := FALSE; (* Now make the connections in the interior of face *) SetFnext(g,Clock(d)); SetFnext(i,Clock(f)); SetFnext(e,Clock(h)); (* Now subdivide the "Ppos(a)" tetrahedron ( the superior tetrahedron in my plan *) (* first we, insert f1 *) SetFnext(d, Clock(f1)); SetFnext(Clock(f1), Clock(g)); <* ASSERT Fnext(Clock(g)) = d *> SetFnext(Enext(f1),Enext(af)); SetFnext(Clock(Enext_1(bf)), Enext(f1)); (* now, we insert f2 *) SetFnext(f, Clock(f2)); SetFnext(Clock(f2), Clock(i)); <* ASSERT Fnext(Clock(i)) = f *> SetFnext(Enext(f2),Enext(bf)); SetFnext(Clock(Enext_1(cf)), Enext(f2)); (* now, we insert f3 *) SetFnext(h, Clock(f3)); SetFnext(Clock(f3), Clock(e)); <* ASSERT Fnext(Clock(e)) = h *> SetFnext(Enext(f3),Enext(cf)); SetFnext(Clock(Enext_1(af)), Enext(f3)); (* now make connections between the internal faces inserted *) SetFnext(Enext_1(f1),Enext_1(f3)); SetFnext(Enext_1(f3),Enext_1(f2)); <* ASSERT Fnext(Enext_1(f2)) = Enext_1(f1) *> (* set the superior axial edge *) SetEdgeAll(Enext_1(f1), Enext_1(f1).facetedge.edge); (* OK *) Enext_1(f1).facetedge.edge.exists := FALSE; (* Now subdivide the "Pneg(a)" tetrahedron ( the inferior tetrahedron in my plan *) (* now, we insert f4 *) SetFnext(Clock(g), Clock(f4)); <* ASSERT Fnext(Clock(f4)) = d *> SetFnext(Enext(af_), Enext(f4)); SetFnext(Enext(f4), Clock(Enext_1(bf_))); (* now, we insert f5 *) SetFnext(Clock(i), Clock(f5)); <* ASSERT Fnext(Clock(f5)) = f *> SetFnext(Enext(bf_), Enext(f5)); SetFnext(Enext(f5), Clock(Enext_1(cf_))); (* now, we insert f6 *) SetFnext(Clock(e), Clock(f6)); <* ASSERT Fnext(Clock(f6)) = h *> SetFnext(Enext(cf_), Enext(f6)); SetFnext(Enext(f6), Clock(Enext_1(af_))); (* now make connections between the internal faces inserted *) SetFnext(Enext_1(f4),Enext_1(f5)); SetFnext(Enext_1(f5),Enext_1(f6)); <* ASSERT Fnext(Enext_1(f6)) = Enext_1(f4) *> (* set the inferior axial edge *) SetEdgeAll(Enext_1(f4), Enext_1(f4).facetedge.edge); (* OK *) Enext_1(f4).facetedge.edge.exists := FALSE; (* set the origins *) SetAllOrgs(f1, x); SetAllOrgs(a, u); SetAllOrgs(b, v); SetAllOrgs(c, w); SetAllOrgs(Enext_1(f1), Org(Enext_1(af))); SetAllOrgs(Enext_1(f4), Org(Enext_1(af_))); (* set the new internal edges *) SetEdgeAll(f1,f1.facetedge.edge); f1.facetedge.edge.exists := FALSE; SetEdgeAll(f2,f2.facetedge.edge); f2.facetedge.edge.exists := FALSE; SetEdgeAll(f3,f3.facetedge.edge); f3.facetedge.edge.exists := FALSE; (* set the original edges and faces in the superior level *) SetEdgeAll(Enext_1(af),eaf); SetEdgeAll(Enext_1(bf),ebf); SetEdgeAll(Enext_1(cf),ecf); SetFaceAll(af,faf); SetFaceAll(bf,fbf); SetFaceAll(cf,fcf); (* set the original edges and faces in the inferior label *) SetEdgeAll(Enext_1(af_),eaf_); SetEdgeAll(Enext_1(bf_),ebf_); SetEdgeAll(Enext_1(cf_),ecf_); SetFaceAll(af_,faf_); SetFaceAll(bf_,fbf_); SetFaceAll(cf_,fcf_); (* set the original edges in the half label *) SetEdgeAll(a,ea); SetEdgeAll(b,eb); SetEdgeAll(c,ec); SetAllPneg(Clock(Enext_1(f1)),q1); SetAllPneg(Clock(Enext_1(f2)),q2); SetAllPneg(Clock(Enext_1(f3)),q3); SetAllPneg(Enext_1(f4),q4); SetAllPneg(Enext_1(f5),q5); SetAllPneg(Enext_1(f6),q6); END END SubdivideFace; PROCEDURE SubdivideTetrahedron(a: Pair; READONLY top: Topology) = (* Subdivide a degenerative tetrahedron in four new tetrahedra through the insertion of a new medial vertex of type "VP" more six faces and three edges. *) VAR y: Node; BEGIN (* Create the medial vertex "VP" *) y := MakeVertex(); WITH v = NARROW(y, Vertex) DO v.exists:= FALSE; v.label := "VP"; v.num := NVP; INC(NVP); END; WITH b = Fnext_1(a), c = Enext_1(b), d = Fnext(c), e = Enext_1(a), f = Fnext_1(e), g = Enext_1(f), h = Fnext(g), fa = a.facetedge.face, fb = b.facetedge.face, fg = g.facetedge.face, fh = h.facetedge.face, ea = a.facetedge.edge, ec = c.facetedge.edge, ee = e.facetedge.edge, eh = h.facetedge.edge, eeb =Enext(b).facetedge.edge, eea =Enext(a).facetedge.edge, i = Enext(a), j = Fnext_1(i), k = Enext(b), l = Fnext(k), u = Org(a), v = Org(Clock(a)), w = Org(c), x = Org(e), f1 = MakeTriangle(), f2 = MakeTriangle(), f3 = MakeTriangle(), f4 = MakeTriangle(), f5 = MakeTriangle(), f6 = MakeTriangle(), q1 = MakePolyhedron(), q2 = MakePolyhedron(), q3 = MakePolyhedron(), q4 = MakePolyhedron() DO (* save attributes for the original faces: "fa", "fb", "fg", "fh". *) fa.exists := top.face[fa.num].exists; fa.color := top.face[fa.num].color; fa.transp := top.face[fa.num].transp; fb.exists := top.face[fb.num].exists; fb.color := top.face[fb.num].color; fb.transp := top.face[fb.num].transp; fg.exists := top.face[fg.num].exists; fg.color := top.face[fg.num].color; fg.transp := top.face[fg.num].transp; fh.exists := top.face[fh.num].exists; fh.color := top.face[fh.num].color; fh.transp := top.face[fh.num].transp; (* save attributes for the original edges: "ea", "ec", "ee", "eh", "eeb", and "eea". *) ea.exists := top.edge[ea.num].exists; ea.color := top.edge[ea.num].color; ea.transp := top.edge[ea.num].transp; ea.radius := top.edge[ea.num].radius; ec.exists := top.edge[ec.num].exists; ec.color := top.edge[ec.num].color; ec.transp := top.edge[ec.num].transp; ec.radius := top.edge[ec.num].radius; ee.exists := top.edge[ee.num].exists; ee.color := top.edge[ee.num].color; ee.transp := top.edge[ee.num].transp; ee.radius := top.edge[ee.num].radius; eh.exists := top.edge[eh.num].exists; eh.color := top.edge[eh.num].color; eh.transp := top.edge[eh.num].transp; eh.radius := top.edge[eh.num].radius; eea.exists := top.edge[eea.num].exists; eea.color := top.edge[eea.num].color; eea.transp := top.edge[eea.num].transp; eea.radius := top.edge[eea.num].radius; eeb.exists := top.edge[eeb.num].exists; eeb.color := top.edge[eeb.num].color; eeb.transp := top.edge[eeb.num].transp; eeb.radius := top.edge[eeb.num].radius; (* set the attributes for the new internal faces *) f1.facetedge.face.exists := FALSE; f2.facetedge.face.exists := FALSE; f3.facetedge.face.exists := FALSE; f4.facetedge.face.exists := FALSE; f5.facetedge.face.exists := FALSE; f6.facetedge.face.exists := FALSE; (* insert f1 *) SetFnext(b,f1); SetFnext(f1,a); (* insert f2 *) SetFnext(c,f2); SetFnext(f2,d); (* insert f3 *) SetFnext(f,f3); SetFnext(f3,e); (* set the relations among f1,f2 and f3 *) SetFnext(Clock(Enext(f2)),Enext_1(f1)); SetFnext(Enext_1(f1),Clock(Enext(f3))); SetFnext(Clock(Enext(f3)),Clock(Enext(f2))); SetEdgeAll(Enext_1(f1), Enext_1(f1).facetedge.edge); Enext_1(f1).facetedge.edge.exists := FALSE; (* insert f4 *) SetFnext(j,f4); SetFnext(f4,i); (* insert f5 *) SetFnext(k,f5); SetFnext(f5,l); (* insert f6 *) SetFnext(g,f6); SetFnext(f6,h); (* set the internal relations along edge "yv" *) SetFnext(Enext_1(f5),Enext_1(f4)); SetFnext(Enext_1(f4),Clock(Enext(f1))); SetFnext(Clock(Enext(f1)), Enext_1(f5)); SetEdgeAll(Clock(Enext(f1)),Clock(Enext(f1)).facetedge.edge); Enext(f1).facetedge.edge.exists := FALSE; (* set the internal relations along edge "wy" *) SetFnext(Enext(f5),Clock(Enext_1(f6))); SetFnext(Clock(Enext_1(f6)),Clock(Enext_1(f2))); SetFnext(Clock(Enext_1(f2)),Enext(f5)); SetEdgeAll(Enext(f5),Enext(f5).facetedge.edge); Enext(f5).facetedge.edge.exists := FALSE; (* set the internal relations along edge "xy" *) SetFnext(Enext(f6), Enext(f4)); SetFnext(Enext(f4), Clock(Enext_1(f3))); SetFnext(Clock(Enext_1(f3)), Enext(f6)); SetEdgeAll(Enext(f4), Enext(f4).facetedge.edge); Enext(f4).facetedge.edge.exists := FALSE; (* set the overall edge component *) SetEdgeAll(a, ea); SetEdgeAll(c, ec); SetEdgeAll(e, ee); SetEdgeAll(i, eea); SetEdgeAll(k, eeb); SetEdgeAll(h, eh); SetFaceAll(a, fa); SetFaceAll(b, fb); SetFaceAll(g, fg); SetFaceAll(h, fh); (* set the origins *) SetAllOrgs(a,u); SetAllOrgs(Clock(a),v); SetAllOrgs(c,w); SetAllOrgs(e,x); SetAllOrgs(Enext_1(f1),y); (* set the polyhedrons *) SetAllPneg(a,q1); SetAllPneg(Spin(b),q2); SetAllPneg(Spin(g),q3); SetAllPneg(Spin(f6),q4); END; END SubdivideTetrahedron; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFile"); o.inFile := pp.getNext(); pp.getKeyword("-outFile"); o.outFile := pp.getNext(); pp.getKeyword("-element"); o.elename := pp.getNext(); IF Text.Equal(o.elename, "edge") THEN o.element := Element.Edge ELSIF Text.Equal(o.elename, "face") THEN o.element := Element.Face ELSIF Text.Equal(o.elename, "tetrahedron") THEN o.element := Element.Tetrahedron ELSE pp.error("bad element \"" & pp.getNext() & "\"\n") END; pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: SelectSubdivision\\\n" ); Wr.PutText(stderr, " -inFile -outFile \\\n" ); Wr.PutText(stderr, " -element { edge | face | tetrahedron }\n" ); Process.Exit (1); END END; RETURN o END GetOptions; <* UNUSED *> PROCEDURE OldSubdivideEdge( an: Pair; n: CARDINAL; READONLY top: Triangulation.Topology; ) = VAR x: Node; a,bn,m1,m2,m3,t0,t1,t2: REF ARRAY OF Pair; wn,p: REF ARRAY OF Node; BEGIN a := NEW(REF ARRAY OF Pair,n); bn := NEW(REF ARRAY OF Pair,n); m1 := NEW(REF ARRAY OF Pair,n); m2 := NEW(REF ARRAY OF Pair,n); m3 := NEW(REF ARRAY OF Pair,n); t0 := NEW(REF ARRAY OF Pair,n); t1 := NEW(REF ARRAY OF Pair,n); t2 := NEW(REF ARRAY OF Pair,n); (* save the pairs *) a := NEW(REF ARRAY OF Pair,n); a[0] := an; WITH f = a[0].facetedge.face, e = a[0].facetedge.edge, ee = Enext(a[0]).facetedge.edge, ee_ = Enext_1(a[0]).facetedge.edge DO IF top.face[f.num].exists THEN f.exists := TRUE; ELSE f.exists := FALSE; END; f.color := top.face[f.num].color; f.transp := top.face[f.num].transp; IF top.edge[e.num].exists THEN e.exists := TRUE; ELSE e.exists := FALSE; END; e.color := top.edge[e.num].color; e.transp := top.edge[e.num].transp; e.radius := top.edge[e.num].radius; IF top.edge[ee.num].exists THEN ee.exists := TRUE; ELSE ee.exists := FALSE; END; ee.color := top.edge[ee.num].color; ee.transp := top.edge[ee.num].transp; ee.radius := top.edge[ee.num].radius; IF top.edge[ee_.num].exists THEN ee_.exists := TRUE; ELSE ee_.exists := FALSE; END; ee_.color := top.edge[ee_.num].color; ee_.transp := top.edge[ee_.num].transp; ee_.radius := top.edge[ee_.num].radius; END; FOR i := 1 TO n-1 DO a[i] := Fnext(a[i-1]); WITH f = a[i].facetedge.face, ee = Enext(a[i]).facetedge.edge, ee_ = Enext_1(a[i]).facetedge.edge DO IF top.face[f.num].exists THEN f.exists := TRUE; ELSE f.exists := FALSE; END; f.color := top.face[f.num].color; f.transp := top.face[f.num].transp; IF top.edge[ee.num].exists THEN ee.exists := TRUE; ELSE ee.exists := FALSE; END; ee.color := top.edge[ee.num].color; ee.transp := top.edge[ee.num].transp; ee.radius := top.edge[ee.num].radius; IF top.edge[ee_.num].exists THEN ee_.exists := TRUE; ELSE ee_.exists := FALSE; END; ee_.color := top.edge[ee_.num].color; ee_.transp := top.edge[ee_.num].transp; ee_.radius := top.edge[ee_.num].radius; END END; (* save the vertices *) wn := NEW(REF ARRAY OF Node,n); FOR i := 0 TO n-1 DO wn[i] := Org(Enext_1(a[i])); END; (* save the tetrahedra *) p := NEW(REF ARRAY OF Node,n); FOR i := 0 TO n-1 DO p[i] := Pneg(a[i]); END; (* save other pairs *) bn := NEW(REF ARRAY OF Pair,n); FOR i := 0 TO n-1 DO bn[i] := Clock(Enext_1(Fnext(Enext_1(a[i])))); WITH e = bn[i].facetedge.edge, f = bn[i].facetedge.face DO IF top.edge[e.num].exists THEN e.exists := TRUE; ELSE e.exists := FALSE; END; e.color := top.edge[e.num].color; e.transp := top.edge[e.num].transp; e.radius := top.edge[e.num].radius; IF top.face[f.num].exists THEN f.exists := TRUE; ELSE f.exists := FALSE; END; f.color := top.face[f.num].color; f.transp := top.face[f.num].transp; END END; (* insert facetedges and edges *) FOR i := 0 TO n-1 DO m1[i] := MakeFacetEdge(); m2[i] := MakeFacetEdge(); m3[i] := MakeFacetEdge(); t0[i] := MakeTriangle(); t1[i] := Enext(t0[i]); t2[i] := Enext(t1[i]); WITH f = t0[i].facetedge.face, e0 = t0[i].facetedge.edge, e1 = t1[i].facetedge.edge, e2 = t2[i].facetedge.edge, (* new tests *) em1i = m1[i].facetedge.edge, em2i = m2[i].facetedge.edge DO (* new tests *) em1i.exists := FALSE; em2i.exists := FALSE; (* end new tests *) f.exists := FALSE; f.transp := R3.T{1.0,1.0,1.0}; e1.exists := FALSE; e2.exists := FALSE; e1.radius := 0.003; e1.transp := R3.T{1.0,1.0,1.0}; e2.radius := 0.003; e2.transp := R3.T{1.0,1.0,1.0}; IF bn[i].facetedge.edge.exists THEN e0.exists := TRUE; ELSE e0.exists := FALSE; END END END; (* Now, subdivide edge and extend the subdivision on the edge's stars *) x := MakeVertex(); WITH v = NARROW(x, Vertex) DO v.label := "VE"; IF a[0].facetedge.edge.exists THEN v.radius := a[0].facetedge.edge.radius; v.color := a[0].facetedge.edge.color; v.transp := a[0].facetedge.edge.transp; ELSE v.radius := 0.00; v.color := R3.T{1.0,1.0,1.0}; v.transp := R3.T{1.0,1.0,1.0}; END; v.num := NVE; INC(NVE); END; FOR j := 0 TO n-1 DO WITH b = Enext(a[j]), be = b.facetedge.edge, c = Enext(b), ce = c.facetedge.edge, u = Org(a[j]), v = Org(b), w = Org(c), (* save the attributes of the edge-face component of the pair a[j] *) f = a[j].facetedge.face, fe = f.exists, fc = f.color, ft = f.transp, g = m3[j].facetedge.face, ge = g.exists, gc = g.color, gt = g.transp, h = m3[j].facetedge.edge DO SetEnext(a[j],m1[j]); SetEnext(m1[j],c); SetEnext(m2[j],m3[j]); SetEnext(m3[j],Clock(b)); SetOrg(a[j], u); SetOrg(Clock(a[j]), x); SetOrg(m2[j],v); SetOrg(Clock(m2[j]), x); SetOrg(m3[j], x); SetOrg(Clock(m3[j]), w); SetOrg(m1[j], x); SetOrg(Clock(m1[j]), w); SetFnext(m1[j],m3[j]); (* set the attributes for the face component *) SetFaceAll(a[j],f); SetFaceAll(m3[j],g); IF fe THEN ge := TRUE; ELSE ge := FALSE; END; gc := fc; gt := ft; SetEdgeAll(m3[j],h); SetEdgeAll(b,be); SetEdgeAll(c,ce); SetFaceAll(bn[j],bn[j].facetedge.face); SetFaceAll(Fnext(bn[j]),Fnext(bn[j]).facetedge.face); END END; FOR j := 0 TO n-1 DO SetFnext(Clock(m2[j]),Clock(m2[(j+1) MOD n])); END; WITH k = m2[0].facetedge.edge, e = a[0].facetedge.edge, ee = e.exists, er = e.radius, ec = e.color, et = e.transp, ke = k.exists, kr = k.radius, kc = k.color, kt = k.transp DO IF ee THEN ke := TRUE; ELSE ke := FALSE; END; kr := er; kc := ec; kt := et; SetEdgeAll(a[0],e); SetEdgeAll(m2[0],k); END; FOR j := 0 TO n-1 DO WITH cn = Fnext(bn[j]), e1 = t1[j].facetedge.edge, e2 = t2[j].facetedge.edge, cnf = cn.facetedge.face, cne = cn.facetedge.edge DO IF top.face[cnf.num].exists THEN cnf.exists := TRUE; ELSE cnf.exists := FALSE; END; cnf.color := top.face[cnf.num].color; cnf.transp := top.face[cnf.num].transp; IF top.edge[cne.num].exists THEN cne.exists := TRUE; ELSE cne.exists := FALSE; END; cne.color := top.edge[cne.num].color; cne.transp := top.edge[cne.num].transp; cne.radius := top.edge[cne.num].radius; (* set the origins *) SetAllOrgs(t0[j],wn[j]); SetAllOrgs(t1[j],wn[(j+1) MOD n]); SetAllOrgs(t2[j],x); SetFnext(bn[j], t0[j]); SetFnext(t0[j],cn); SetFnext(m1[j],t2[j]); SetFnext(t2[j],m3[j]); SetFnext(Clock(m1[(j+1) MOD n]), t1[j]); SetFnext(t1[j],Clock(m3[(j+1) MOD n])); SetEdgeAll(t0[j],cn.facetedge.edge); SetEdgeAll(t1[j],e1); SetEdgeAll(t2[j],e2); END END; (* insert polyhedra *) FOR j := 0 TO n-1 DO WITH q = Triangulation.MakePolyhedron() DO SetAllPneg(a[j],p[j]); SetAllPneg(m2[j],q); END END END OldSubdivideEdge; <* UNUSED *> PROCEDURE Incident( b: Pair; n: CARDINAL; READONLY top: Triangulation.Topology; ): CARDINAL = (* This module indicates the number of existing faces incident to the component edge of the pair b. *) VAR bn: Pair := b; in: CARDINAL := 0; BEGIN FOR j := 0 TO n-1 DO WITH fn = bn.facetedge.face.num, f = top.face[fn] DO IF f.exists THEN INC(in) END; bn := Fnext(bn); END END; <* ASSERT bn = b *> RETURN in; END Incident; BEGIN DoIt() END SelectSubdivision. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/SplineToWire4.m3 MODULE SplineToWire4 EXPORTS Main; (* Given control points of a cubic spline curve, generates sample points along it. Writes the sample points as camera positions in the format expected by the "Wire4" - Interactive 4D Wireframe Display Program (".w4"). Also writes a plain text file with one point per line (preceded by its integer ID). -Include the option "renderInterval" ( between [1-10] ) for generate spacing among configurations. Last Modification by stolfi 06-08-2000 *) IMPORT ParseParams, Process, Wr, Thread, OSError, FileWr, Mis, LR4, Fmt, PZGeo4; FROM Stdio IMPORT stderr; FROM PZGeo4 IMPORT BSplineApproximation; TYPE Row3I = ARRAY [0..2] OF INTEGER; LONG = LONGREAL; Options = RECORD outFile: TEXT; (* Output file name prefix *) ncp: CARDINAL; (* Number of control points. *) cp: REF ARRAY OF LR4.T; (* Control points for spline. *) tips: BOOLEAN; (* TRUE includes the endpoints. *) normalize: LONGREAL; (* If nonzero, normalize From-To vectors to this length. *) renderInterval: CARDINAL; (* Subsampling ratio for camera positions. *) samplesPerArc: CARDINAL; (* Number of samples per spline arc (for Wire4 plotting). *) To4: LR4.T; (* Look at point *) Up4: LR4.T; (* Head-up point *) Over4: LR4.T; (* Hyperhead-up point *) END; <* FATAL Wr.Failure, Thread.Alerted, OSError.E *> PROCEDURE WriteColor(wr: Wr.T; READONLY c: Row3I) = (* Write colors in RGB mode *) BEGIN Mis.WriteInt(wr,c[0]); Wr.PutText(wr," "); Mis.WriteInt(wr,c[1]); Wr.PutText(wr," "); Mis.WriteInt(wr,c[2]); END WriteColor; PROCEDURE DoIt() = BEGIN WITH o = GetOptions(), comments = "Made by SplineToWire4 on " & Mis.Today() & "\n", w4 = FileWr.Open(o.outFile & ".w4"), txt = FileWr.Open(o.outFile & ".from4") DO WriteComments(w4,o,comments); WriteComments(txt,o,comments); WriteWire4Header(w4); SamplePath(o,w4,txt); Wr.Close(w4); Wr.Close(txt); END END DoIt; PROCEDURE WriteComments(wr: Wr.T; READONLY o: Options; comments: TEXT) = BEGIN Mis.WriteCommentsJS(wr,comments,'#'); Wr.PutText(wr, "# control points :\n"); FOR i := 0 TO o.ncp-1 DO Wr.PutText(wr, "# "); Mis.WritePoint(wr, o.cp[i]); Wr.PutText(wr, "\n"); END; Wr.PutText(wr, "\n"); END WriteComments; PROCEDURE WriteWire4Header(wr: Wr.T) = BEGIN Wr.PutText(wr, "DegreeRingEdges"); Wr.PutText(wr," 0"); Wr.PutText(wr,"\nDepthCueLevels 10"); Wr.PutText(wr,"\nFogDensity 0.5"); Wr.PutText(wr,"\n"); Wr.PutText(wr, "\nFrom4: +9 00 00 00"); Wr.PutText(wr, "\nTo4 : 00 00 00 00"); Wr.PutText(wr, "\nUp4 : 00 00 +1 00"); Wr.PutText(wr, "\nOver4: 00 00 00 +1"); Wr.PutText(wr, "\nVangle4: 30"); Wr.PutText(wr, "\n"); Wr.PutText(wr, "\nFrom3: +9 00 00"); Wr.PutText(wr, "\nTo3 : 00 00 00"); Wr.PutText(wr, "\nUp3 : 00 00 +1"); Wr.PutText(wr, "\nVangle3: 30"); END WriteWire4Header; PROCEDURE SamplePath(READONLY o: Options; w4: Wr.T; txt: Wr.T) = VAR nv,ne : CARDINAL; (* Number of vertices and edges in the curve spline. *) kv: CARDINAL; (* Vertex counter *) vcolor : Row3I := Row3I{100,100,100}; ecolor : Row3I := Row3I{0,255,255}; vradius : REAL := 1.0; eradius : REAL := 1.0; BEGIN PROCEDURE SampleSplineArc(a, b, c, d: LR4.T; np: CARDINAL) = BEGIN (* To amend the first control point *) WITH tini = FLOAT(-2*np, LONGREAL), ta = FLOAT( -np, LONGREAL), tb = FLOAT( 0, LONGREAL), tc = FLOAT( np, LONGREAL), td = FLOAT( 2*np, LONGREAL), tfin = FLOAT( 3*np, LONGREAL) DO ReportInterval(kv, kv+np-1); FOR j := 0 TO np-1 DO WITH t = FLOAT(j,LONG), Q = BSplineApproximation(t, tini, ta,a, tb,b, tc,c, td,d, tfin) DO ProcessSample(Q) END END END END SampleSplineArc; PROCEDURE ReportInterval(ini, fin: CARDINAL) = BEGIN Wr.PutText(stderr, "Interpoling between [ " & Fmt.Int(ini) & "-" & Fmt.Int(fin) & "]\n"); END ReportInterval; PROCEDURE ProcessSample(Q: LR4.T) = BEGIN IF o.normalize > 0.0d0 THEN Q := LR4.Scale(o.normalize, LR4.Dir(LR4.Sub(Q,o.To4))) END; WritePoint4DForWire4(Q,vcolor,vradius); IF kv MOD o.renderInterval = 0 THEN WritePoint4DAsText(Q,kv); END; INC(kv) END ProcessSample; PROCEDURE WriteCoord(wr: Wr.T; x: LONG) = BEGIN Wr.PutText(wr, Fmt.Pad(Fmt.LongReal(x, Fmt.Style.Fix, prec := 4), 7)); END WriteCoord; PROCEDURE WritePoint4DForWire4(READONLY c: LR4.T; vcolor: Row3I; vradius: REAL) = BEGIN WriteCoord(w4,c[0]); Wr.PutText(w4, " "); WriteCoord(w4,c[1]); Wr.PutText(w4, " "); WriteCoord(w4,c[2]); Wr.PutText(w4, " "); WriteCoord(w4,c[3]); Wr.PutText(w4, " : "); WriteColor(w4, vcolor); Wr.PutText(w4, " : "); Mis.WriteRadius(w4, vradius); Wr.PutText(w4, "\n"); END WritePoint4DForWire4; PROCEDURE WritePoint4DAsText(READONLY c: LR4.T; i: CARDINAL) = BEGIN Wr.PutText(txt, " " & Fmt.Int(i) & " "); WriteCoord(txt,c[0]); Wr.PutText(txt, " "); WriteCoord(txt,c[1]); Wr.PutText(txt, " "); WriteCoord(txt,c[2]); Wr.PutText(txt, " "); WriteCoord(txt,c[3]); Wr.PutText(txt, "\n"); END WritePoint4DAsText; BEGIN (* compute the number of vertices *) nv := (o.ncp - 3)*o.samplesPerArc; IF o.tips THEN nv := nv + 4*o.samplesPerArc + 1 END; Wr.PutText(w4, "\n\nVertexList : "); Wr.PutText(w4, Fmt.Int(nv+5) & "\n"); kv := 0; IF o.tips THEN SampleSplineArc(o.cp[0], o.cp[0], o.cp[0], o.cp[1], o.samplesPerArc); SampleSplineArc(o.cp[0], o.cp[0], o.cp[1], o.cp[2], o.samplesPerArc); END; FOR i := 0 TO o.ncp-4 DO SampleSplineArc(o.cp[i], o.cp[i+1], o.cp[i+2], o.cp[i+3], o.samplesPerArc); END; IF o.tips THEN SampleSplineArc(o.cp[o.ncp-3], o.cp[o.ncp-2], o.cp[o.ncp-1], o.cp[o.ncp-1], o.samplesPerArc); SampleSplineArc(o.cp[o.ncp-2], o.cp[o.ncp-1], o.cp[o.ncp-1], o.cp[o.ncp-1], o.samplesPerArc); ProcessSample(o.cp[o.ncp-1]) END; (* reference axis vertices *) Wr.PutText(w4, " 0 0 0 0 : 255 255 255 : 0\n"); Wr.PutText(w4, " 1 0 0 0 : 255 255 255 : 0\n"); Wr.PutText(w4, " 0 1 0 0 : 255 255 255 : 0\n"); Wr.PutText(w4, " 0 0 1 0 : 255 255 255 : 0\n"); Wr.PutText(w4, " 0 0 0 1 : 255 255 255 : 0\n"); Wr.PutText(w4, "\n"); ne := nv - 1; Wr.PutText(w4, "\nEdgeList " & Fmt.Int(ne+4) & ":\n"); FOR i := 0 TO ne-1 DO Wr.PutText(w4, Fmt.Pad(Fmt.Int(i), 4) & " " & Fmt.Pad(Fmt.Int(i+1),4) ); Wr.PutText(w4, " : "); (* color *) WriteColor(w4, ecolor); Wr.PutText(w4, " : "); Mis.WriteRadius(w4, eradius); Wr.PutText(w4, "\n"); END; (* reference axis edges *) Wr.PutText(w4, " " & Fmt.Int(nv) & " " & Fmt.Int(nv+1) ); Wr.PutText(w4, " : 125 125 125 : 1\n"); Wr.PutText(w4, " " & Fmt.Int(nv) & " " & Fmt.Int(nv+2) ); Wr.PutText(w4, " : 125 125 125 : 1\n"); Wr.PutText(w4, " " & Fmt.Int(nv) & " " & Fmt.Int(nv+3) ); Wr.PutText(w4, " : 125 125 125 : 1\n"); Wr.PutText(w4, " " & Fmt.Int(nv) & " " & Fmt.Int(nv+4) ); Wr.PutText(w4, " : 125 125 125 : 1\n"); Wr.PutText(w4, "\nFaceList 0\n"); Wr.Close(w4); END END SamplePath; PROCEDURE GetOptions(): Options = VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-outFile"); o.outFile := pp.getNext(); pp.getKeyword("-ncp"); o.ncp := pp.getNextInt(4,100); o.cp := NEW(REF ARRAY OF LR4.T, o.ncp); FOR i := 0 TO o.ncp-1 DO FOR j := 0 TO 3 DO o.cp[i,j] := pp.getNextLongReal(-100.0d0, 100.0d0); END END; o.tips := pp.keywordPresent("-tips"); IF pp.keywordPresent("-normalize") THEN o.normalize := pp.getNextLongReal(1.0d-10,1.0d+10); ELSE o.normalize := 0.0d0; END; IF pp.keywordPresent("-samplesPerArc") THEN o.samplesPerArc := pp.getNextInt(1,100); ELSE o.samplesPerArc := 10; END; IF pp.keywordPresent("-renderInterval") THEN o.renderInterval := pp.getNextInt(1,100); ELSE o.renderInterval := 10; END; pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: SplineToWire4 \\\n"); Wr.PutText(stderr, " -outFile \\\n"); Wr.PutText(stderr, " [ -normalize ] \\\n"); Wr.PutText(stderr, " -ncp \\\n"); Wr.PutText(stderr, " [ ] \\\n"); Wr.PutText(stderr, " ............................... \\\n"); Wr.PutText(stderr, " [ ] \\\n"); Wr.PutText(stderr, " [ -tips ] \\\n"); Wr.PutText(stderr, " [ -samplesPerArc ] \\\n"); Wr.PutText(stderr, " [ -renderInterval ]\n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt(); END SplineToWire4. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/Statistics.m3 (* This Program compute the statistics for test the influence of energy minimization (produced by OptShape). So print the average and standard desviation of length of edges, area of faces, volume of tetrahedra and dihedral angle between consecutives faces incidents to common edges. Read files (-final.tp). Created by L. P. Lozada (see the copyright and authorship futher down). Last version: 23-11-99 *) MODULE Statistics EXPORTS Main; IMPORT Triangulation, Fmt, Stdio, Wr, Thread, Process, ParseParams, LR4, Mis, Stat, LR4Extras, Math; FROM Stdio IMPORT stderr; FROM Triangulation IMPORT Topology, Coords, OrgV, Ppos, Pneg, Pair, Org; FROM Octf IMPORT Fnext, Enext, Enext_1, Tors, Clock; FROM Math IMPORT cos; CONST Pi = Math.Pi; TYPE Options = RECORD inFileTp: TEXT; (* Initial guess file name (minus ".tp") *) inFileSt: TEXT; (* Initial guess file name (minus ".tp") *) length: BOOLEAN; area: BOOLEAN; volume: BOOLEAN; angle: BOOLEAN; END; TYPE BOOLS = ARRAY OF BOOLEAN; Edge = Triangulation.Edge; Face = Triangulation.Face; DRF = REF ARRAY OF CARDINAL; VAR stl, stv, sta, std: Stat.T; PROCEDURE DoIt() = BEGIN Stat.Init(stl); Stat.Init(stv); Stat.Init(sta); Stat.Init(std); WITH o = GetOptions(), tc = Triangulation.ReadToMa(o.inFileTp), top = tc.top, rc = Triangulation.ReadState(o.inFileSt), c = rc^ DO MakeTest(o.length,o.area,o.volume,o.angle,top,c); END END DoIt; PROCEDURE MakeTest( length,area,volume,angle: BOOLEAN; READONLY top: Topology; READONLY c: Coords; ) = BEGIN IF length THEN MakeTestLength(top,c) END; IF area THEN MakeTestArea(top,c) END; IF volume THEN MakeTestVolume(top,c) END; IF angle THEN MakeTestAngle(top,c) END; END MakeTest; PROCEDURE MakeTestLength(READONLY top: Topology; READONLY c: Coords) = <* FATAL Thread.Alerted, Wr.Failure *> BEGIN Mis.WriteCommentsJS(stderr, "\nThe length of edges\n",'|'); FOR i := 0 TO top.NE-1 DO WITH e = top.edge[i], un = OrgV(e.pa).num, vn = OrgV(Clock(e.pa)).num, l = LR4.Dist(c[un],c[vn]), ll = FLOAT(l, REAL) DO Wr.PutText(stderr, Fmt.LongReal(l) & "\n"); Stat.Accum(stl, ll); END END; Wr.PutText(stderr, "\nWeight statistics of length's edges :\n"); Stat.Print(stderr, stl); Wr.PutText(stderr, "\n"); END MakeTestLength; PROCEDURE MakeTestAngle(READONLY top: Topology; READONLY c: Coords) = <* FATAL Thread.Alerted, Wr.Failure *> PROCEDURE Angle(READONLY f1,f2: Pair) : LONGREAL = BEGIN WITH a = f1, b = f2, ao = OrgV(a).num, ad = OrgV(Enext(a)).num, ae = OrgV(Enext_1(a)).num, bo = OrgV(b).num, bd = OrgV(Enext(b)).num, be = OrgV(Enext_1(b)).num, v1a = LR4.Sub(c[ad],c[ao]), v2a = LR4.Sub(c[ae],c[ao]), v1b = LR4.Sub(c[bd],c[bo]), v2b = LR4.Sub(c[be],c[bo]), p = FindOrthonormal(v1a,v2a), q = FindOrthonormal(v1b,v2b), cos = LR4.Dot(p,q) (*tethar = Math.acos(cos) (* Aproximation *)*) DO (* <* ASSERT (ao = bo) AND (ad = bd) *> <* ASSERT (0.0d0<=tethar) AND (tethar <= FLOAT(Pi,LONGREAL) ) *> tetha := (180.0d0*tethar)/FLOAT(Pi, LONGREAL); *) RETURN cos; END END Angle; PROCEDURE FindOrthonormal(READONLY v1,v2: LR4.T) : LR4.T = BEGIN WITH u1 = v1, v2_u1 = LR4.Project(v2,u1), u2 = LR4.Sub(v2,v2_u1) DO RETURN LR4.Dir(u2); END END FindOrthonormal; PROCEDURE CollectFaces(READONLY e: Edge): REF ARRAY OF Face = VAR NT: CARDINAL := 0; ct: CARDINAL; BEGIN WITH NF = top.NF, t = NEW(REF ARRAY OF Face, NF)^ DO FOR i := 0 TO NF-1 DO ct := 0; WITH f = top.face[i], fun = OrgV(f.pa).num, fvn = OrgV(Enext(f.pa)).num, fwn = OrgV(Enext_1(f.pa)).num, eun = OrgV(e.pa).num, evn = OrgV(Clock(e.pa)).num DO IF (fun=eun OR fun=evn) THEN INC(ct) END; IF (fvn=eun OR fvn=evn) THEN INC(ct) END; IF (fwn=eun OR fwn=evn) THEN INC(ct) END; IF ct = 2 THEN t[NT] := f; INC(NT); END END END; WITH r = NEW(REF ARRAY OF Face, NT) DO r^ := SUBARRAY(t,0,NT); RETURN r; END END END CollectFaces; VAR dihedral: LONGREAL; dihedralr: REAL; drf: DRF; edgeRelevant: REF BOOLS; internal : BOOLEAN; idealcosine: LONGREAL; BEGIN edgeRelevant := NEW(REF BOOLS, top.NE); Mis.WriteCommentsJS(stderr, "\nThe dihedral angles\n",'|'); drf := NEW(REF ARRAY OF CARDINAL, top.NE); FOR l := 0 TO top.NE-1 DO WITH e = top.edge[l], fie = CollectFaces(e), drf = LAST(fie^)+1 DO FOR j := 0 TO drf-1 DO WITH f1 = fie^[j], a = f1.pa, aPpos = Ppos(a), aPneg = Pneg(a) DO IF aPpos # NIL AND aPneg # NIL THEN internal := TRUE; ELSE internal := FALSE; END; END; edgeRelevant[l] := TRUE AND internal; END; IF edgeRelevant[l] THEN Wr.PutText(stderr, " -corresponding to edge: " & Fmt.Int(l) & "\n"); FOR j := 0 TO drf-1 DO WITH f1 = fie^[j], a = f1.pa, b = Fnext(a) DO dihedral := Angle(a,b); Wr.PutText(stderr, Fmt.LongReal(dihedral) & "\n"); dihedralr := FLOAT(dihedral, REAL); Stat.Accum(std,dihedralr); END END; idealcosine:=cos((2.0d0*FLOAT(Pi,LONGREAL))/FLOAT(drf,LONGREAL)); END END END; Wr.PutText(stderr, "\nWeight statistics of dihedral angles:\n"); Stat.Print(stderr, std); Wr.PutText(stderr, "\n"); Wr.PutText(stderr,"Ideal Cosine " & Fmt.LongReal(idealcosine) & "\n"); END MakeTestAngle; PROCEDURE MakeTestVolume(READONLY top: Topology; READONLY c: Coords) = <* FATAL Thread.Alerted, Wr.Failure *> BEGIN Mis.WriteCommentsJS(stderr, "\nThe volume of tetrahedrons\n",'|'); FOR i := 0 TO top.NP-1 DO WITH vt = TetrahedronVertices(top.region[i]), un = vt[0], vn = vt[1], wn = vt[2], xn = vt[3], uv = LR4.Sub(c[vn],c[un]), uw = LR4.Sub(c[wn],c[un]), ux = LR4.Sub(c[xn],c[un]), n = LR4Extras.Cross(uv, uw, ux), v = 1.0d0/6.0d0 * LR4.Norm(n), vv = FLOAT(v, REAL) DO Wr.PutText(stderr, Fmt.LongReal(v) & "\n"); Stat.Accum(stv, vv); END END; Wr.PutText(stderr, "\nWeight statistics of volume's polyhedron:\n"); Stat.Print(stderr, stv); Wr.PutText(stderr, "\n"); END MakeTestVolume; PROCEDURE TetrahedronVertices(f:Triangulation.Pair): ARRAY [0..3] OF CARDINAL = (* Was exchange OrgV by Org for considering the dual space. *) BEGIN WITH g = Tors(f), h = Tors(Clock(Enext_1(f))), p = Org(g).num, q = Org(Enext(g)).num, r = Org(Enext_1(g)).num, s = Org(Enext_1(h)).num DO RETURN ARRAY [0..3] OF CARDINAL{p, q, r, s} END END TetrahedronVertices; PROCEDURE MakeTestArea(READONLY top: Topology; READONLY c: Coords) = <* FATAL Thread.Alerted, Wr.Failure *> BEGIN Mis.WriteCommentsJS(stderr, "\nThe area of triangles\n",'|'); FOR i := 0 TO top.NF-1 DO WITH p = top.face[i], un = OrgV(p.pa).num, vn = OrgV(Enext(p.pa)).num, wn = OrgV(Enext_1(p.pa)).num, a = LR4.Dist(c[vn],c[un]), b = LR4.Dist(c[wn],c[un]), c = LR4.Dist(c[vn],c[wn]), p = (a+b+c), s = 0.5d0 * p, sa = s - a, sb = s - b, sc = s - c, ar = Math.sqrt(s*sa*sb*sc), arr = FLOAT(ar, REAL) DO Wr.PutText(stderr, Fmt.LongReal(ar) & "\n"); Stat.Accum(sta, arr); END END; Wr.PutText(stderr, "\nWeight statistics of area's faces:\n"); Stat.Print(stderr, sta); Wr.PutText(stderr, "\n"); END MakeTestArea; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFileTp"); o.inFileTp := pp.getNext(); pp.getKeyword("-inFileSt"); o.inFileSt := pp.getNext(); o.length := pp.keywordPresent("-length"); o.area := pp.keywordPresent("-area"); o.volume := pp.keywordPresent("-volume"); o.angle := pp.keywordPresent("-angle"); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: Statistics \\\n" ); Wr.PutText(stderr, " -inFileTp \\\n"); Wr.PutText(stderr, " -inFileSt \\\n"); Wr.PutText(stderr, " [ -length ] [ -volume ] [ -area ]" & " [ -angle ]\n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt() END Statistics. (**************************************************************************) (* *) (* Copyright (C) 1999 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/SubGon.m3 MODULE SubGon EXPORTS Main; (* This program receives as input a single polyhedron (the envelope) and produces a include file with the barycentric subdivision of faces (2-skeleton) and cells (3-skeleton) but in an exploding way. Revision: 19-05-2000 by lozada *) IMPORT Thread, Wr, Process, Triangulation, Octf, ParseParams, Fmt, Squared; FROM Triangulation IMPORT OrgV, SetAllOrgs; FROM Octf IMPORT Pair, Clock, Enext, SetFnext, Enext_1, SetEdgeAll; FROM Stdio IMPORT stderr; FROM Wr IMPORT PutText; TYPE Options = RECORD order : CARDINAL; (* order of the triangle star *) outFile: TEXT; (* Output file name prefix *) END; PROCEDURE DoIt() = VAR a : REF ARRAY OF Pair; tp : Triangulation.Topology; BEGIN WITH o = GetOptions() DO a := NEW(REF ARRAY OF Pair, o.order); FOR i := 0 TO o.order-1 DO a[i] := Squared.MakeTriangle(); END; FOR i := 0 TO o.order-1 DO SetFnext(Enext(a[i]), Clock(Enext_1(a[(i+1) MOD o.order]))); SetEdgeAll(Enext(a[i]), Enext(a[i]).facetedge.edge); END; FOR i := 0 TO o.order-1 DO SetAllOrgs(Enext(a[i]), OrgV(Enext(a[i]))); SetAllOrgs(Enext_1(a[i]), OrgV(Enext_1(a[i]))); SetAllOrgs(a[i], OrgV(a[i])); END; tp := Triangulation.MakeTopology(a[0]); WITH c = Triangulation.GenCoords(tp) DO Triangulation.WriteTopology(o.outFile, tp, "Created by SubGon: gon-" & Fmt.Int(o.order) & ".tp"); Triangulation.WriteState(o.outFile, tp, c^, "Created by SubGon: gon-" & Fmt.Int(o.order) & ".st"); Triangulation.WriteMaterials(o.outFile, tp,"Created by SubGon: gon-" & Fmt.Int(o.order) & ".ma"); END END END DoIt; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-outFile"); o.outFile := pp.getNext(); pp.getKeyword("-order"); o.order := pp.getNextInt(2,20); pp.finish(); EXCEPT | ParseParams.Error => PutText(stderr, "Usage: SubGon \\\n"); PutText(stderr, " -order \\\n"); PutText(stderr, " -outFile \n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt() END SubGon. (**************************************************************************) (* *) (* Copyright (C) 2001 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/TestCorner.m3 MODULE TestCorner EXPORTS Main; (* Test the corners for one topological tetrahedron. *) IMPORT Triangulation, Octf, Stdio, Wr, Fmt, Thread, Mapi; FROM Octf IMPORT Clock, Spin, Srot, Tors; FROM Stdio IMPORT stderr; FROM Mapi IMPORT Corner, CCorner; TYPE Pair = Octf.Pair; VAR ca : ARRAY [0..7] OF Pair; PROCEDURE PrintCorner() = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN FOR l := 1 TO 4 DO WITH a = Octf.MakeFacetEdge(), b = Mapi.MakeFacetEdge(l), fes = NARROW(b.facetedge, Mapi.FacetEdge), fet = a.facetedge DO fet.order := fes.order; fet.ca := fes.ca; (* Octf.PrintPairnl(stderr, a); Wr.PutText(stderr, "\n"); *) Wr.PutText(stderr, "(" & Fmt.Int(l) & "," & Fmt.Int(l) & "):" & "\n" ); Wr.PutText(stderr, "Corner(a)= " ); Octf.PrintPairnl(stderr, Corner(a)); Wr.PutText(stderr, "CornerSpin(a)= " ); Octf.PrintPairnl(stderr, Corner(Spin(a))); Wr.PutText(stderr, "CornerSrot(a)= " ); Octf.PrintPairnl(stderr, Corner(Srot(a))); Wr.PutText(stderr, "CornerSpinSrot(a)= " ); Octf.PrintPairnl(stderr, Corner(Spin(Srot(a)))); Wr.PutText(stderr, "CornerClock(a)= " ); Octf.PrintPairnl(stderr, Corner(Clock(a))); Wr.PutText(stderr, "CornerSpinClock(a)= " ); Octf.PrintPairnl(stderr, Corner(Spin(Clock(a)))); Wr.PutText(stderr, "CornerTor(a)= " ); Octf.PrintPairnl(stderr, Corner(Tors(a))); Wr.PutText(stderr, "CornerSpinTors(a)= " ); Octf.PrintPairnl(stderr, Corner(Spin(Tors(a)))); END; END; END PrintCorner; PROCEDURE PrintCCorner() = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN FOR l := 1 TO 4 DO WITH a = Octf.MakeFacetEdge(), b = Mapi.MakeFacetEdge(l), fes = NARROW(b.facetedge, Mapi.FacetEdge), fet = a.facetedge DO fet.order := fes.order; fet.ca := fes.ca; Wr.PutText(stderr, "CCorner(a)= " ); Octf.PrintPairnl(stderr, CCorner(a)); Wr.PutText(stderr, "CCornerSpin(a)= " ); Octf.PrintPairnl(stderr, CCorner(Spin(a))); Wr.PutText(stderr, "CCornerSrot(a)= " ); Octf.PrintPairnl(stderr, CCorner(Srot(a))); Wr.PutText(stderr, "CCornerSpinSrot(a)= " ); Octf.PrintPairnl(stderr, CCorner(Spin(Srot(a)))); Wr.PutText(stderr, "CCornerClock(a)= " ); Octf.PrintPairnl(stderr, CCorner(Clock(a))); Wr.PutText(stderr, "CCornerSpinClock(a)= " ); Octf.PrintPairnl(stderr, CCorner(Spin(Clock(a)))); Wr.PutText(stderr, "CCornerTors(a)= " ); Octf.PrintPairnl(stderr, CCorner(Tors(a))); Wr.PutText(stderr, "CCornerSpinTors(a)= " ); Octf.PrintPairnl(stderr, CCorner(Spin(Tors(a)))); END; END; END PrintCCorner; PROCEDURE Teste() = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN FOR i := 1 TO 4 DO ca := Triangulation.MakeTetraTopo(i,i); Wr.PutText(stderr, "(" & Fmt.Int(i) & "," & Fmt.Int(i) & "):" & "\n" ); FOR k := 0 TO 7 DO Wr.PutText(stderr, "c[" & Fmt.Int(k) & "]= " ); Octf.PrintPairnl(stderr, ca[k],3); END END; END Teste; BEGIN PrintCorner(); PrintCCorner(); Teste(); END TestCorner. (**************************************************************************) (* *) (* Copyright (C) 1999 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) (**************************************************************************** (1,1): Corner(a)= 8:2:1 CornerSpin(a)= 5:2:0 CornerSrot(a)= 0:0:0 CornerSpinSrot(a)= 9:0:1 CornerClock(a)= 5:0:1 CornerSpinClock(a)= 8:0:0 CornerTor(a)= 9:2:0 CornerSpinTors(a)= 0:2:1 (2,2): Corner(a)= 17:2:1 CornerSpin(a)= 8:2:0 CornerSrot(a)= 0:0:0 CornerSpinSrot(a)= 27:0:1 CornerClock(a)= 23:0:1 CornerSpinClock(a)= 32:0:0 CornerTor(a)= 33:2:0 CornerSpinTors(a)= 3:2:1 (3,3): Corner(a)= 26:2:1 CornerSpin(a)= 11:2:0 CornerSrot(a)= 0:0:0 CornerSpinSrot(a)= 57:0:1 CornerClock(a)= 53:0:1 CornerSpinClock(a)= 68:0:0 CornerTor(a)= 69:2:0 CornerSpinTors(a)= 6:2:1 (4,4): Corner(a)= 35:2:1 CornerSpin(a)= 14:2:0 CornerSrot(a)= 0:0:0 CornerSpinSrot(a)= 99:0:1 CornerClock(a)= 95:0:1 CornerSpinClock(a)= 116:0:0 CornerTor(a)= 117:2:0 CornerSpinTors(a)= 9:2:1 (1,1): CCorner(a)= 5:2:1 CCornerSpin(a)= 8:2:0 CCornerSrot(a)= 9:0:0 CCornerSpinSrot(a)= 0:0:1 CCornerClock(a)= 8:0:1 CCornerSpinClock(a)= 5:0:0 CCornerTors(a)= 0:2:0 CCornerSpinTors(a)= 9:2:1 (2,2): CCorner(a)= 8:2:1 CCornerSpin(a)= 17:2:0 CCornerSrot(a)= 27:0:0 CCornerSpinSrot(a)= 0:0:1 CCornerClock(a)= 32:0:1 CCornerSpinClock(a)= 23:0:0 CCornerTors(a)= 3:2:0 CCornerSpinTors(a)= 33:2:1 (3,3): CCorner(a)= 11:2:1 CCornerSpin(a)= 26:2:0 CCornerSrot(a)= 57:0:0 CCornerSpinSrot(a)= 0:0:1 CCornerClock(a)= 68:0:1 CCornerSpinClock(a)= 53:0:0 CCornerTors(a)= 6:2:0 CCornerSpinTors(a)= 69:2:1 (4,4): CCorner(a)= 14:2:1 CCornerSpin(a)= 35:2:0 CCornerSrot(a)= 99:0:0 CCornerSpinSrot(a)= 0:0:1 CCornerClock(a)= 116:0:1 CCornerSpinClock(a)= 95:0:0 CCornerTors(a)= 9:2:0 CCornerSpinTors(a)= 117:2:1 (1,1): c[0]= 8:2:1 c[1]= 5:2:0 c[2]= 0:0:0 c[3]= 9:0:1 c[4]= 5:0:1 c[5]= 8:0:0 c[6]= 9:2:0 c[7]= 0:2:1 (2,2): c[0]= 17:2:1 c[1]= 8:2:0 c[2]= 0:0:0 c[3]= 27:0:1 c[4]= 23:0:1 c[5]= 32:0:0 c[6]= 33:2:0 c[7]= 3:2:1 (3,3): c[0]= 26:2:1 c[1]= 11:2:0 c[2]= 0:0:0 c[3]= 57:0:1 c[4]= 53:0:1 c[5]= 68:0:0 c[6]= 69:2:0 c[7]= 6:2:1 (4,4): c[0]= 35:2:1 c[1]= 14:2:0 c[2]= 0:0:0 c[3]= 99:0:1 c[4]= 95:0:1 c[5]= 116:0:0 c[6]= 117:2:0 c[7]= 9:2:1 ***************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/TestCornerFE.m3 MODULE TestCorner EXPORTS Main; IMPORT Triangulation, Octf, Stdio, Wr, Fmt, Thread, Map; FROM Octf IMPORT Clock, Spin, Srot, Tors; FROM Stdio IMPORT stderr; FROM Map IMPORT Corner, CCorner; TYPE Pair = Octf.Pair; VAR ca : ARRAY [0..7] OF Pair; PROCEDURE PrintCorner() = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN FOR l := 1 TO 4 DO WITH a = Map.MakeFacetEdge(l) DO (* Octf.PrintPair(stderr, a); Wr.PutText(stderr, "\n"); *) Wr.PutText(stderr, "(" & Fmt.Int(l) & "," & Fmt.Int(l) & "):" & "\n" ); Wr.PutText(stderr, "Corner(a)= " ); Octf.PrintPair(stderr, Corner(a)); Wr.PutText(stderr, "CornerSpin(a)= " ); Octf.PrintPair(stderr, Corner(Spin(a))); Wr.PutText(stderr, "CornerSrot(a)= " ); Octf.PrintPair(stderr, Corner(Srot(a))); Wr.PutText(stderr, "CornerSpinSrot(a)= " ); Octf.PrintPair(stderr, Corner(Spin(Srot(a)))); Wr.PutText(stderr, "CornerClock(a)= " ); Octf.PrintPair(stderr, Corner(Clock(a))); Wr.PutText(stderr, "CornerSpinClock(a)= " ); Octf.PrintPair(stderr, Corner(Spin(Clock(a)))); Wr.PutText(stderr, "CornerTor(a)= " ); Octf.PrintPair(stderr, Corner(Tors(a))); Wr.PutText(stderr, "CornerSpinTors(a)= " ); Octf.PrintPair(stderr, Corner(Spin(Tors(a)))); END; END; END PrintCorner; PROCEDURE PrintCCorner() = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN FOR l := 1 TO 4 DO WITH a = Map.MakeFacetEdge(l) DO Wr.PutText(stderr, "(" & Fmt.Int(l) & "," & Fmt.Int(l) & "):" & "\n" ); Wr.PutText(stderr, "CCorner(a)= " ); Octf.PrintPair(stderr, CCorner(a)); Wr.PutText(stderr, "CCornerSpin(a)= " ); Octf.PrintPair(stderr, CCorner(Spin(a))); Wr.PutText(stderr, "CCornerSrot(a)= " ); Octf.PrintPair(stderr, CCorner(Srot(a))); Wr.PutText(stderr, "CCornerSpinSrot(a)= " ); Octf.PrintPair(stderr, CCorner(Spin(Srot(a)))); Wr.PutText(stderr, "CCornerClock(a)= " ); Octf.PrintPair(stderr, CCorner(Clock(a))); Wr.PutText(stderr, "CCornerSpinClock(a)= " ); Octf.PrintPair(stderr, CCorner(Spin(Clock(a)))); Wr.PutText(stderr, "CCornerTors(a)= " ); Octf.PrintPair(stderr, CCorner(Tors(a))); Wr.PutText(stderr, "CCornerSpinTors(a)= " ); Octf.PrintPair(stderr, CCorner(Spin(Tors(a)))); END; END; END PrintCCorner; PROCEDURE Teste() = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN FOR i := 1 TO 4 DO ca := Triangulation.MakeTetraTopo(i,i); Wr.PutText(stderr, "(" & Fmt.Int(i) & "," & Fmt.Int(i) & "):" & "\n" ); FOR k := 0 TO 7 DO Wr.PutText(stderr, "c[" & Fmt.Int(k) & "]= " ); Octf.PrintPair(stderr, ca[k],3); END END; END Teste; BEGIN PrintCorner(); PrintCCorner(); Teste(); END TestCorner. (**************************************************************************** (1,1): Corner(a)= 8:2:1 CornerSpin(a)= 5:2:0 CornerSrot(a)= 0:0:0 CornerSpinSrot(a)= 9:0:1 CornerClock(a)= 5:0:1 CornerSpinClock(a)= 8:0:0 CornerTor(a)= 9:2:0 CornerSpinTors(a)= 0:2:1 (2,2): Corner(a)= 17:2:1 CornerSpin(a)= 8:2:0 CornerSrot(a)= 0:0:0 CornerSpinSrot(a)= 27:0:1 CornerClock(a)= 23:0:1 CornerSpinClock(a)= 32:0:0 CornerTor(a)= 33:2:0 CornerSpinTors(a)= 3:2:1 (3,3): Corner(a)= 26:2:1 CornerSpin(a)= 11:2:0 CornerSrot(a)= 0:0:0 CornerSpinSrot(a)= 57:0:1 CornerClock(a)= 53:0:1 CornerSpinClock(a)= 68:0:0 CornerTor(a)= 69:2:0 CornerSpinTors(a)= 6:2:1 (4,4): Corner(a)= 35:2:1 CornerSpin(a)= 14:2:0 CornerSrot(a)= 0:0:0 CornerSpinSrot(a)= 99:0:1 CornerClock(a)= 95:0:1 CornerSpinClock(a)= 116:0:0 CornerTor(a)= 117:2:0 CornerSpinTors(a)= 9:2:1 (1,1): CCorner(a)= 5:2:1 CCornerSpin(a)= 8:2:0 CCornerSrot(a)= 9:0:0 CCornerSpinSrot(a)= 0:0:1 CCornerClock(a)= 8:0:1 CCornerSpinClock(a)= 5:0:0 CCornerTors(a)= 0:2:0 CCornerSpinTors(a)= 9:2:1 (2,2): CCorner(a)= 8:2:1 CCornerSpin(a)= 17:2:0 CCornerSrot(a)= 27:0:0 CCornerSpinSrot(a)= 0:0:1 CCornerClock(a)= 32:0:1 CCornerSpinClock(a)= 23:0:0 CCornerTors(a)= 3:2:0 CCornerSpinTors(a)= 33:2:1 (3,3): CCorner(a)= 11:2:1 CCornerSpin(a)= 26:2:0 CCornerSrot(a)= 57:0:0 CCornerSpinSrot(a)= 0:0:1 CCornerClock(a)= 68:0:1 CCornerSpinClock(a)= 53:0:0 CCornerTors(a)= 6:2:0 CCornerSpinTors(a)= 69:2:1 (4,4): CCorner(a)= 14:2:1 CCornerSpin(a)= 35:2:0 CCornerSrot(a)= 99:0:0 CCornerSpinSrot(a)= 0:0:1 CCornerClock(a)= 116:0:1 CCornerSpinClock(a)= 95:0:0 CCornerTors(a)= 9:2:0 CCornerSpinTors(a)= 117:2:1 (1,1): c[0]= 8:2:1 c[1]= 5:2:0 c[2]= 0:0:0 c[3]= 9:0:1 c[4]= 5:0:1 c[5]= 8:0:0 c[6]= 9:2:0 c[7]= 0:2:1 (2,2): c[0]= 17:2:1 c[1]= 8:2:0 c[2]= 0:0:0 c[3]= 27:0:1 c[4]= 23:0:1 c[5]= 32:0:0 c[6]= 33:2:0 c[7]= 3:2:1 (3,3): c[0]= 26:2:1 c[1]= 11:2:0 c[2]= 0:0:0 c[3]= 57:0:1 c[4]= 53:0:1 c[5]= 68:0:0 c[6]= 69:2:0 c[7]= 6:2:1 (4,4): c[0]= 35:2:1 c[1]= 14:2:0 c[2]= 0:0:0 c[3]= 99:0:1 c[4]= 95:0:1 c[5]= 116:0:0 c[6]= 117:2:0 c[7]= 9:2:1 ***************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/TestCornerQE.m3 MODULE testeCantos EXPORTS Main ; IMPORT Triang, Oct, Stdio, Wr, Fmt, Thread, Map; FROM Octf IMPORT Splice, S, Onext, Oprev, Flip, Tor, Rot; FROM Stdio IMPORT stderr; FROM Triang IMPORT Org; FROM Map IMPORT Corner, CCorner, Middle; TYPE Arc = Oct.Arc; Topology = Triang.Topology; Count = Triang.Count; AdjacencyMatrix = Triang.AdjacencyMatrix; VAR ca : ARRAY [0..7] OF Arc; PROCEDURE PrintCorner() = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN FOR l := 1 TO 4 DO WITH a = Map.MakeEdge(l) DO (* Oct.PrintArc(Stdio.stderr, a); Wr.PutText(Stdio.stderr, "\n"); *) Wr.PutText(Stdio.stderr, "(" & Fmt.Int(l) & "," & Fmt.Int(l) & "):" & "\n" ); Wr.PutText(Stdio.stderr, "Corner(a)= " ); Oct.PrintArc(stderr, Corner(a)); Wr.PutText(Stdio.stderr, "CornerFlip(a)= " ); Oct.PrintArc(stderr, Corner(Flip(a))); Wr.PutText(Stdio.stderr, "CornerRot(a)= " ); Oct.PrintArc(stderr, Corner(Rot(a))); Wr.PutText(Stdio.stderr, "CornerFlipRot(a)= " ); Oct.PrintArc(stderr, Corner(Flip(Rot(a)))); Wr.PutText(Stdio.stderr, "CornerSym(a)= " ); Oct.PrintArc(stderr, Corner(Sym(a))); Wr.PutText(Stdio.stderr, "CornerFlipSym(a)= " ); Oct.PrintArc(stderr, Corner(Flip(Sym(a)))); Wr.PutText(Stdio.stderr, "CornerTor(a)= " ); Oct.PrintArc(stderr, Corner(Tor(a))); Wr.PutText(Stdio.stderr, "CornerFlipTor(a)= " ); Oct.PrintArc(stderr, Corner(Flip(Tor(a)))); END; END; END PrintCorner; PROCEDURE PrintCCorner() = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN FOR l := 1 TO 4 DO WITH a = Map.MakeEdge(l) DO Wr.PutText(Stdio.stderr, "(" & Fmt.Int(l) & "," & Fmt.Int(l) & "):" & "\n" ); Wr.PutText(Stdio.stderr, "CCorner(a)= " ); Oct.PrintArc(stderr, CCorner(a)); Wr.PutText(Stdio.stderr, "CCornerFlip(a)= " ); Oct.PrintArc(stderr, CCorner(Flip(a))); Wr.PutText(Stdio.stderr, "CCornerRot(a)= " ); Oct.PrintArc(stderr, CCorner(Rot(a))); Wr.PutText(Stdio.stderr, "CCornerFlipRot(a)= " ); Oct.PrintArc(stderr, CCorner(Flip(Rot(a)))); Wr.PutText(Stdio.stderr, "CCornerSym(a)= " ); Oct.PrintArc(stderr, CCorner(Sym(a))); Wr.PutText(Stdio.stderr, "CCornerFlipSym(a)= " ); Oct.PrintArc(stderr, CCorner(Flip(Sym(a)))); Wr.PutText(Stdio.stderr, "CCornerTor(a)= " ); Oct.PrintArc(stderr, CCorner(Tor(a))); Wr.PutText(Stdio.stderr, "CCornerFlipTor(a)= " ); Oct.PrintArc(stderr, CCorner(Flip(Tor(a)))); END; END; END PrintCCorner; PROCEDURE Teste() = <* FATAL Wr.Failure, Thread.Alerted *> VAR ca: ARRAY [0..7] OF Arc; middle,c: Arc; t : Topology; edge : REF ARRAY OF Arc; NE : CARDINAL := 0; BEGIN WITH a = Map.MakeEdge(2) DO (* FOR l := 4 TO 4 DO ca := Triang.MakeGrid(l,l); FOR k := 0 TO 7 DO Wr.PutText(Stdio.stderr, "c[" & Fmt.Int(k) & "]= " ); Oct.PrintArc(Stdio.stderr, ca[k]); Wr.PutText(Stdio.stderr, "\n"); END; *) t := Triang.MakeTopology(a); FOR k := 0 TO 7 DO Wr.PutText(Stdio.stderr, "c[" & Fmt.Int(k) & "]= " ); Oct.PrintArc(Stdio.stderr, ca[k]); Wr.PutText(Stdio.stderr, "\n"); END; END; END Teste; BEGIN (* PrintCorner(); PrintCCorner(); PrintMiddle(); Teste(); *) MakeTorus(); END testeCantos. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/TestCurvature.m3 MODULE TestCurvature EXPORTS Main; (* This module generates two symetric random variations of a given ".st" file, for submit to the TestEnergy procedure. *) IMPORT Triangulation, LR4, Random, Thread, Wr, Stdio, ParseParams, Process, Text; FROM Triangulation IMPORT Topology, Coords; FROM Stdio IMPORT stderr; TYPE Options = RECORD inFileTp: TEXT; (* Input file name (topology) *) inFileSt: TEXT; (* Input file name (state) *) output: TEXT; (* Output file name prefix *) magnitude: TEXT; (* for indicate how constructs the random conf. *) jitter: REAL; (* Magnitude of random perturbation *) normalize: BOOLEAN; (* TRUE to normalize the vertex coordinates *) END; PROCEDURE DoIt() = BEGIN WITH o = GetOptions(), coins = NEW(Random.Default).init(TRUE), tc = Triangulation.ReadToMa(o.inFileTp), top = tc.top, rc = Triangulation.ReadState(o.inFileSt), cOld = rc^, cNew = NEW(REF Coords, top.NV)^, comments = " Random variation : " & o.magnitude & "\n" & " Randomizing from: " & o.inFileSt & ".st\n" & " Created by TestCurvature: " & o.output & ".st\n" DO IF o.normalize THEN Triangulation.NormalizeVertexDistance(top, cOld) END; cNew := cOld; PerturbCoords(top, cNew, coins, FLOAT(o.jitter, LONGREAL), o.magnitude); IF o.normalize THEN Triangulation.NormalizeVertexDistance(top, cNew) END; Triangulation.WriteState(o.output, top, cNew,comments); END END DoIt; PROCEDURE PerturbCoords( READONLY top: Topology; VAR c: Coords; coins: Random.T; jitter: LONGREAL; magnitude: TEXT; ) = BEGIN FOR i := 0 TO LAST(c) DO IF top.vertex[i].exists AND NOT top.vertex[i].fixed THEN WITH ci = c[i], p = LR4.T{ jitter * coins.longreal(-1.0d0, +1.0d0), jitter * coins.longreal(-1.0d0, +1.0d0), jitter * coins.longreal(-1.0d0, +1.0d0), jitter * coins.longreal(-1.0d0, +1.0d0) } DO IF Text.Equal(magnitude,"+") THEN ci := LR4.Add(ci, p); ELSE ci := LR4.Sub(ci, p); END END END END END PerturbCoords; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFileTp"); o.inFileTp := pp.getNext(); pp.getKeyword("-inFileSt"); o.inFileSt := pp.getNext(); pp.getKeyword("-output"); o.output := pp.getNext(); pp.getKeyword("-magnitude"); o.magnitude := pp.getNext(); o.normalize := pp.keywordPresent("-normalize"); IF pp.keywordPresent("-jitter") THEN o.jitter := pp.getNextReal(0.0); ELSE o.jitter := 1.0 END; pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: TestCurvature \\\n"); Wr.PutText(stderr, " -inFileTp -inFileSt \\\n"); Wr.PutText(stderr, " -output -magnitude < + | - > \\\n"); Wr.PutText(stderr, " [ -normalize ] [ -jitter ]\n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt() END TestCurvature. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/TestElasticity.m3 MODULE TestElasticity EXPORTS Main; IMPORT Stdio, Wr, Thread, LR3x3, LR3, Mis, LR4, Fmt, LR4x4; FROM Stdio IMPORT stderr; CONST A = LR3x3.T{ LR3.T{0.0d0, 1.0d0, 1.0d0}, LR3.T{1.0d0, 0.0d0, 1.0d0}, LR3.T{1.0d0, 1.0d0, 0.0d0} }; B = LR4x4.T{ LR4.T{0.0d0, 0.0d0, 0.0d0, 1.0d0}, LR4.T{0.0d0, 1.0d0, 1.0d0, 1.0d0}, LR4.T{1.0d0, 1.0d0, 0.0d0, 1.0d0}, LR4.T{1.0d0, 0.0d0, 1.0d0, 1.0d0} }; TYPE LR4x3 = ARRAY [0..3] OF LR3.T; LR3x4 = ARRAY [0..2] OF LR4.T; PROCEDURE Transpose_3x4(READONLY m: LR3x4): LR4x3 = (* Return the transpose of a matrix 3x4. *) VAR t : LR4x3; BEGIN t[0] := LR3.T{m[0,0], m[1,0], m[2,0]}; t[1] := LR3.T{m[0,1], m[1,1], m[2,1]}; t[2] := LR3.T{m[0,2], m[1,2], m[2,2]}; t[3] := LR3.T{m[0,3], m[1,3], m[2,3]}; RETURN t; END Transpose_3x4; PROCEDURE Transpose_4x3(READONLY m: LR4x3): LR3x4 = (* return the transpose of a matrix 3x3. *) VAR t : LR3x4; BEGIN t[0] := LR4.T{m[0,0], m[1,0], m[2,0], m[3,0]}; t[1] := LR4.T{m[0,1], m[1,1], m[2,1], m[3,1]}; t[2] := LR4.T{m[0,2], m[1,2], m[2,2], m[3,2]}; RETURN t; END Transpose_4x3; PROCEDURE Mul_4x3_3x3(READONLY a: LR4x3; READONLY b: LR3x3.T) : LR4x3 = (* Return the product of the matrix "a" 4x3 and matrix "b" 3x3. *) VAR c : LR4x3; BEGIN WITH a00 = a[0,0], a01 = a[0,1], a02 = a[0,2], a10 = a[1,0], a11 = a[1,1], a12 = a[1,2], a20 = a[2,0], a21 = a[2,1], a22 = a[2,2], a30 = a[3,0], a31 = a[3,1], a32 = a[3,2], b00 = b[0,0], b01 = b[0,1], b02 = b[0,2], b10 = b[1,0], b11 = b[1,1], b12 = b[1,2], b20 = b[2,0], b21 = b[2,1], b22 = b[2,2], c00 = a00 * b00 + a01 * b10 + a02 * b20, c01 = a00 * b01 + a01 * b11 + a02 * b21, c02 = a00 * b02 + a01 * b12 + a02 * b22, c10 = a10 * b00 + a11 * b10 + a12 * b20, c11 = a10 * b01 + a11 * b11 + a12 * b21, c12 = a10 * b02 + a11 * b12 + a12 * b22, c20 = a20 * b00 + a21 * b10 + a22 * b20, c21 = a20 * b01 + a21 * b11 + a22 * b21, c22 = a20 * b02 + a21 * b12 + a22 * b22, c30 = a30 * b00 + a31 * b10 + a32 * b20, c31 = a30 * b01 + a31 * b11 + a32 * b21, c32 = a30 * b02 + a31 * b12 + a32 * b22, c0 = LR3.T{c00,c01,c02}, c1 = LR3.T{c10,c11,c12}, c2 = LR3.T{c20,c21,c22}, c3 = LR3.T{c30,c31,c32} DO c[0] := c0; c[1] := c1; c[2] := c2; c[3] := c3; RETURN c; END END Mul_4x3_3x3; PROCEDURE Mul_3x4_4x3(READONLY a: LR3x4; READONLY b: LR4x3) : LR3x3.T = (* Return the product of the matrix "a" 3x4 and matrix "b" 4x3. *) BEGIN WITH a00 = a[0,0], a01 = a[0,1], a02 = a[0,2], a03 = a[0,3], a10 = a[1,0], a11 = a[1,1], a12 = a[1,2], a13 = a[1,3], a20 = a[2,0], a21 = a[2,1], a22 = a[2,2], a23 = a[2,3], b00 = b[0,0], b01 = b[0,1], b02 = b[0,2], b10 = b[1,0], b11 = b[1,1], b12 = b[1,2], b20 = b[2,0], b21 = b[2,1], b22 = b[2,2], b30 = b[3,0], b31 = b[3,1], b32 = b[3,2], c00 = a00 * b00 + a01 * b10 + a02 * b20 + a03 * b30, c01 = a00 * b01 + a01 * b11 + a02 * b21 + a03 * b31, c02 = a00 * b02 + a01 * b12 + a02 * b22 + a03 * b32, c10 = a10 * b00 + a11 * b10 + a12 * b20 + a13 * b30, c11 = a10 * b01 + a11 * b11 + a12 * b21 + a13 * b31, c12 = a10 * b02 + a11 * b12 + a12 * b22 + a13 * b32, c20 = a20 * b00 + a21 * b10 + a22 * b20 + a23 * b30, c21 = a20 * b01 + a21 * b11 + a22 * b21 + a23 * b31, c22 = a20 * b02 + a21 * b12 + a22 * b22 + a23 * b32, c0 = LR3.T{c00,c01,c02}, c1 = LR3.T{c10,c11,c12}, c2 = LR3.T{c20,c21,c22} DO RETURN LR3x3.T{c0,c1,c2}; END END Mul_3x4_4x3; PROCEDURE PrintMatrix_3x3(READONLY a: LR3x3.T ) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN FOR i := 0 TO 2 DO FOR j := 0 TO 2 DO Mis.WriteLong(stderr, a[i,j]); Wr.PutText(stderr, " "); END; Wr.PutText(stderr, "\n"); END; END PrintMatrix_3x3; PROCEDURE PrintMatrix_3x4(READONLY a: LR3x4 ) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN FOR i := 0 TO 2 DO FOR j := 0 TO 3 DO Mis.WriteLong(stderr, a[i,j]); Wr.PutText(stderr, " "); END; Wr.PutText(stderr, "\n"); END; END PrintMatrix_3x4; PROCEDURE PrintMatrix_4x3(READONLY a: LR4x3 ) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN FOR i := 0 TO 3 DO FOR j := 0 TO 2 DO Mis.WriteLong(stderr, a[i,j]); Wr.PutText(stderr, " "); END; Wr.PutText(stderr, "\n"); END; END PrintMatrix_4x3; PROCEDURE DoIt() = <* FATAL Wr.Failure, Thread.Alerted *> VAR B : LR4x3; BEGIN WITH b0 = LR3.T{10.0d0, 10.0d0, 10.0d0}, b1 = LR3.T{10.0d0, 10.0d0, 10.0d0}, b2 = LR3.T{10.0d0, 10.0d0, 10.0d0}, b3 = LR3.T{10.0d0, 10.0d0, 10.0d0} DO B[0] := b0; B[1] := b1; B[2] := b2; B[3] := b3; Wr.PutText(stderr, "\nMatrix A\n"); PrintMatrix_3x3(A); Wr.PutText(stderr, "\nMatrix B\n"); PrintMatrix_4x3(B); Wr.PutText(stderr, "\nMatrix A_1\n"); PrintMatrix_3x3(LR3x3.Inv(A)); Wr.PutText(stderr, "\nMatrix A* A_1\n"); PrintMatrix_3x3(LR3x3.Mul(A,LR3x3.Inv(A))); (* Wr.PutText(stderr, "\nMatrix B'\n"); PrintMatrix_3x4(Transpose_4x3(B)); Wr.PutText(stderr, "\nMatrix B''\n"); PrintMatrix_4x3(Transpose_3x4(Transpose_4x3(B))); Wr.PutText(stderr, "\nMatrix BxA\n"); PrintMatrix_4x3(Mul_4x3_3x3(B,A)); Wr.PutText(stderr, "\nMatrix B'xB\n"); PrintMatrix_3x3(Mul_3x4_4x3(Transpose_4x3(B),B)); *) Wr.PutText(stderr, "\nMatrix BxA_1\n"); PrintMatrix_4x3(Mul_4x3_3x3(B,LR3x3.Inv(A))); END END DoIt; BEGIN DoIt(); Wr.PutText(stderr, "volume :" & Fmt.LongReal(1.0d0/6.0d0*LR3x3.Det(A)) & "\n"); END TestElasticity. (**************************************************************************) (* *) (* Copyright (C) 1999 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) (* Testes Matrix A 1.00 0.00 0.00 0.00 1.00 0.00 0.00 0.00 1.00 Matrix B 1.00 0.00 0.00 0.00 2.00 0.00 0.00 0.00 3.00 1.00 1.00 1.00 Matrix B' 1.00 0.00 0.00 1.00 0.00 2.00 0.00 1.00 0.00 0.00 3.00 1.00 Matrix B'' 1.00 0.00 0.00 0.00 2.00 0.00 0.00 0.00 3.00 1.00 1.00 1.00 Matrix BxA 1.00 0.00 0.00 0.00 2.00 0.00 0.00 0.00 3.00 1.00 1.00 1.00 Matrix B'xB 2.00 1.00 1.00 1.00 5.00 1.00 1.00 1.00 10.00 *) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/TestEnergy.m3 MODULE TestEnergy EXPORTS Main; (* Last edited on 2001-05-12 02:13:06 by stolfi *) (* Tests an energy function. Takes as input two ".st" files with same topology but different coordinate vectors, and evaluates a given energy function for all configurations that interpolate between the two, at "nSteps" equal intervals. The output is a ".plot" file that can be examined with "gnuplot". Optionally, the program writes the ".st" file with minimum energy. *) IMPORT Triangulation, MixedEnergy, ParseEnergyParams; IMPORT LR4, Fmt, FileWr, OSError, ParseParams, Process, Wr, Thread; FROM Triangulation IMPORT Coords; FROM Stdio IMPORT stderr; TYPE BOOLS = ARRAY OF BOOLEAN; TYPE Options = RECORD tpFile: TEXT; (* Topology file (minus ".tp") *) aFile, bFile: TEXT; (* Configuration files (minus ".st") *) outFile: TEXT; (* Output file names (minus ".plot"/".st") *) eFunction: MixedEnergy.T; (* Energy function *) nSteps: CARDINAL; (* Number of steps to take *) showMin: BOOLEAN; (* TRUE to write interpolated ".st" files *) END; PROCEDURE DoIt() = <* FATAL Wr.Failure, Thread.Alerted, OSError.E *> VAR eMin: LONGREAL := LAST(LONGREAL); sMin: LONGREAL; BEGIN WITH o = GetOptions(), tpData = Triangulation.ReadToMa(o.tpFile), top = tpData.top, ac = Triangulation.ReadState(o.aFile)^, bc = Triangulation.ReadState(o.bFile)^, NV = top.NV, c = NEW(REF ARRAY OF LR4.T, top.NV)^, cDs = NEW(REF ARRAY OF LR4.T, top.NV)^, eDc = NEW(REF ARRAY OF LR4.T, top.NV)^, vTot = NEW(REF BOOLS, top.NV)^, vSome = NEW(REF BOOLS, top.NV)^, pwr = FileWr.Open(o.outFile & ".plot") DO <* ASSERT NUMBER(ac) = NV *> <* ASSERT NUMBER(bc) = NV *> WriteHeader(pwr); o.eFunction.defTop(top); Triangulation.GetVariableVertices(top, vTot); FOR i := 0 TO NV-1 DO cDs[i] := LR4.Sub(bc[i], ac[i]); vSome[i] := LR4.Norm(cDs[i]) # 0.0d0 END; GradTest("initial", o.eFunction, ac, vTot, eDc); GradTest("final", o.eFunction, bc, vTot, eDc); FOR i := 0 TO o.nSteps DO WITH s = FLOAT(i, LONGREAL)/FLOAT(o.nSteps, LONGREAL) DO Wr.PutText(pwr, " "); Wr.PutText(pwr, " " & FLR(s, 6, 4)); (* Define coordinates *) FOR i := 0 TO top.NV-1 DO c[i] := LR4.Mix(1.0d0 - s, ac[i], s, bc[i]) END; (* Evaluate with all or only some vertices variable: *) WITH eTot = EvalTest(pwr, o.eFunction, c, cDs, vTot, eDc), eSome = EvalTest(pwr, o.eFunction, c, cDs, vSome, eDc) DO (* Compare: *) Wr.PutText(pwr, " "); Wr.PutText(pwr, " " & ELR(eTot-eSome, 15, 8)); IF eTot < eMin THEN eMin := eTot; sMin := s END; END; Wr.PutText(pwr, "\n"); Wr.Flush(pwr); END END; Wr.Close(pwr); IF o.showMin THEN WITH name = o.outFile & "-min", comments = " Topology file = " & o.tpFile & "\n" & " Configuration files: " & o.aFile & ",\n " & o.bFile & "\n" & " Energy function to test: " & o.eFunction.name() & "\n" & " Minimum energy: " & FLR(eMin, 16, 8) & "\n" & " Position of minimum: " & Fmt.LongReal(sMin) DO FOR i := 0 TO NV-1 DO c[i] := LR4.Mix(1.0d0 - sMin, ac[i], sMin, bc[i]) END; Triangulation.WriteState(name, top, c, comments) END END; END END DoIt; PROCEDURE GradTest( cfgName: TEXT; (* Configuration name. *) eFunction: MixedEnergy.T; (* Energy function. *) VAR c: Coords; (* Vertex coordinates. *) READONLY v: BOOLS; (* Mutable vertices. *) VAR eDc: Coords; (* Work area for gradient. *) ) = <* FATAL Wr.Failure, Thread.Alerted *> VAR e, ep, cOld: LONGREAL; eDcNum: LR4.T; CONST DiffStep = 0.0001d0; BEGIN Wr.PutText(stderr, "Gradient test for " & cfgName & " configuration\n"); Wr.PutText(stderr, "\n"); WITH NV = NUMBER(c), eDcXXX = NEW(REF Coords, NV)^ (* Garbage gradient. *) DO <* ASSERT NUMBER(v) = NV *> eFunction.defVar(v); eFunction.eval(c, e, TRUE, eDc); Wr.PutText(stderr, " energy = " & FLR(e, 9, 4) & "\n"); Wr.PutText(stderr, " vNum V Gradient (algebrical) Gradient (numerical) Difference\n"); Wr.PutText(stderr, " ----- - ------------------------------------------- ------------------------------------------- ----------------\n"); (* Compute numerical gradient: *) FOR i := 0 TO NV-1 DO Wr.PutText(stderr, " " & Fmt.Pad(Fmt.Int(i), 5)); IF v[i] THEN Wr.PutText(stderr, " T"); Wr.PutText(stderr, " " & FLR4(eDc[i], 10,7)); FOR k := 0 TO 3 DO cOld := c[i][k]; c[i][k] := cOld + DiffStep; eFunction.eval(c, ep, FALSE, eDcXXX); eDcNum[k] := (ep - e)/DiffStep; c[i][k] := cOld END; Wr.PutText(stderr, " " & FLR4(eDcNum, 10,7)); Wr.PutText(stderr, " " & ELR(LR4.Dist(eDcNum, eDc[i]), 16,8)); ELSE Wr.PutText(stderr, " F"); Wr.PutText(stderr, " " & FLR4(eDc[i], 10,7)); END; Wr.PutText(stderr, "\n") END; END; END GradTest; PROCEDURE EvalTest( pwr: Wr.T; (* File ".plot" *) eFunction: MixedEnergy.T; (* Energy function *) VAR c: Coords; (* Coordinates *) READONLY cDs: Coords; (* Direction vector *) READONLY v: BOOLS; (* Which vertices are variable *) VAR eDc: Coords; (* Work area for gradient *) ): LONGREAL = <* FATAL Wr.Failure, Thread.Alerted *> VAR e, ep: LONGREAL; eDs: LONGREAL; (* Directional derivative *) CONST DiffStep = 0.0001d0; BEGIN WITH NV = NUMBER(c) DO <* ASSERT NUMBER(v) = NV *> eFunction.defVar(v); eFunction.eval(c, e, TRUE, eDc); Wr.PutText(pwr, " "); Wr.PutText(pwr, " " & FLR(e, 12, 7)); (* Compute directional derivative from gradient: *) eDs := 0.0d0; FOR i := 0 TO NV-1 DO eDs := eDs + LR4.Dot(eDc[i], cDs[i]) END; Wr.PutText(pwr, " " & FLR(eDs, 12, 7)); (* Check if setting "grad=FALSE" has any effect on "e": *) eFunction.eval(c, ep, FALSE, eDc); <* ASSERT ep = e *> (* Compute directional derivative numerically: *) WITH ds = DiffStep DO FOR i := 0 TO NV-1 DO c[i] := LR4.Mix(1.0d0, c[i], ds, cDs[i]) END; eFunction.eval(c, ep, FALSE, eDc); eDs := (ep - e)/ds END; Wr.PutText(pwr, " " & FLR(eDs, 12, 7)); END; RETURN e END EvalTest; PROCEDURE WriteHeader(pwr: Wr.T) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(pwr, "#"); Wr.PutText(pwr, " " & Fmt.Pad("s", 6)); Wr.PutText(pwr, " "); Wr.PutText(pwr, " " & Fmt.Pad("etot", 12)); Wr.PutText(pwr, " " & Fmt.Pad("etotDc*cDs", 12)); Wr.PutText(pwr, " " & Fmt.Pad("etotDs", 12)); Wr.PutText(pwr, " "); Wr.PutText(pwr, " " & Fmt.Pad("evar", 12)); Wr.PutText(pwr, " " & Fmt.Pad("evarDc*cDs", 12)); Wr.PutText(pwr, " " & Fmt.Pad("evarDs", 12)); Wr.PutText(pwr, " "); Wr.PutText(pwr, " " & Fmt.Pad("etot-evar", 15)); Wr.PutText(pwr, "\n"); Wr.PutText(pwr, "#"); Wr.PutText(pwr, " " & Fmt.Pad("", 6, '-', Fmt.Align.Right)); Wr.PutText(pwr, " "); Wr.PutText(pwr, " " & Fmt.Pad("", 12, '-', Fmt.Align.Right)); Wr.PutText(pwr, " " & Fmt.Pad("", 12, '-', Fmt.Align.Right)); Wr.PutText(pwr, " " & Fmt.Pad("", 12, '-', Fmt.Align.Right)); Wr.PutText(pwr, " "); Wr.PutText(pwr, " " & Fmt.Pad("", 12, '-', Fmt.Align.Right)); Wr.PutText(pwr, " " & Fmt.Pad("", 12, '-', Fmt.Align.Right)); Wr.PutText(pwr, " " & Fmt.Pad("", 12, '-', Fmt.Align.Right)); Wr.PutText(pwr, " "); Wr.PutText(pwr, " " & Fmt.Pad("", 15, '-', Fmt.Align.Right)); Wr.PutText(pwr, "\n"); END WriteHeader; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-tpFile"); o.tpFile := pp.getNext(); pp.getKeyword("-aFile"); o.aFile := pp.getNext(); pp.getKeyword("-bFile"); o.bFile := pp.getNext(); pp.getKeyword("-outFile"); o.outFile := pp.getNext(); IF pp.keywordPresent("-nSteps") THEN o.nSteps := pp.getNextInt(1, 1000); ELSE o.nSteps := 100; END; o.eFunction := ParseEnergyParams.Parse(pp); IF o.eFunction = NIL THEN pp.error("\"-energy\" not specified") END; o.showMin := pp.keywordPresent("-showMin"); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: TestEnergy \\\n"); Wr.PutText(stderr, " -tpFile NAME -aFile NAME -bFile NAME \\\n"); Wr.PutText(stderr, " -outFile \\\n"); Wr.PutText(stderr, " [ -nSteps ] \\\n"); Wr.PutText(stderr, " [ -showMin ] \\\n"); Wr.PutText(stderr, ParseEnergyParams.Help); Wr.PutText(stderr, "\n"); Process.Exit (1); END END; RETURN o END GetOptions; PROCEDURE FLR(x: LONGREAL; wd, pr: CARDINAL): TEXT = BEGIN RETURN Fmt.Pad(Fmt.LongReal(x, Fmt.Style.Fix, pr), wd) END FLR; PROCEDURE ELR(x: LONGREAL; wd, pr: CARDINAL): TEXT = BEGIN RETURN Fmt.Pad(Fmt.LongReal(x, Fmt.Style.Sci, pr), wd) END ELR; PROCEDURE FLR4(x: LR4.T; wd, pr: CARDINAL): TEXT = BEGIN RETURN Fmt.Pad(Fmt.LongReal(x[0], Fmt.Style.Fix, pr), wd) & " " & Fmt.Pad(Fmt.LongReal(x[1], Fmt.Style.Fix, pr), wd) & " " & Fmt.Pad(Fmt.LongReal(x[2], Fmt.Style.Fix, pr), wd) & " " & Fmt.Pad(Fmt.LongReal(x[3], Fmt.Style.Fix, pr), wd) END FLR4; BEGIN DoIt(); END TestEnergy. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/TestGeomDege.m3 MODULE TestGeomDege EXPORTS Main; (* Program to find degenerations on the topologies to builds by several "Make" programs. Created by L. Lozada (see notice of copyright at the end of this file). Last modification: 19-01-2000 *) IMPORT Triangulation, Stdio, Wr, Thread, Process, ParseParams, Mis, Fmt, Octf; FROM Stdio IMPORT stderr; FROM Octf IMPORT Clock, Enext; FROM Triangulation IMPORT OrgV; TYPE Options = RECORD inFile: TEXT; (* Initial guess file name (minus ".tp") *) edge : BOOLEAN; face : BOOLEAN; all : BOOLEAN; END; PROCEDURE DoIt() = <* FATAL Thread.Alerted, Wr.Failure *> VAR e1,e2,f1,f2: REF ARRAY OF INTEGER; v : REF ARRAY OF BOOLEAN; BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToMa(o.inFile), top = tc.top DO IF o.edge OR o.all THEN Mis.WriteCommentsJS(stderr, "\nTest of Edges\n" & "\n",'|'); FOR i := 0 TO top.NE-1 DO FOR j := i+1 TO top.NE-1 DO WITH ei = top.edge[i].pa, ej = top.edge[j].pa, ei0 = OrgV(ei).num, ei1 = OrgV(Clock(ei)).num, ej0 = OrgV(ej).num, ej1 = OrgV(Clock(ej)).num DO e1 := NEW(REF ARRAY OF INTEGER, 2); e1[0] := ei0; e1[1] := ei1; Mis.InsertionSort(1,e1); e2 := NEW(REF ARRAY OF INTEGER, 2); e2[0] := ej0; e2[1] := ej1; Mis.InsertionSort(1,e2); IF (e1[0] = e2[0]) AND (e1[1] = e2[1]) THEN Wr.PutText(stderr, "Failed Test Of Edges\n"); Wr.PutText(stderr,Fmt.Int(e1[0]) & " "& Fmt.Int(e1[1]) & "\n"); Process.Exit(1); END END END END END; IF o.face OR o.all THEN Mis.WriteCommentsJS(stderr, "\nTest of Faces\n" & "\n",'|'); FOR i := 0 TO top.NF-1 DO FOR j := i+1 TO top.NF-1 DO WITH fi = top.face[i], fj = top.face[j], pi = fi.pa, pj = fj.pa, ri = Octf.DegreeEdgeRing(pi), rj = Octf.DegreeEdgeRing(pj) DO IF ri = rj THEN f1 := NEW(REF ARRAY OF INTEGER, ri); f2 := NEW(REF ARRAY OF INTEGER, ri); FOR k := 0 TO ri-1 DO f1[k] := OrgV(pi).num; pi := Enext(pi); f2[k] := OrgV(pj).num; pj := Enext(pj); END; Mis.InsertionSort(ri-1,f1); Mis.InsertionSort(ri-1,f2); v := NEW(REF ARRAY OF BOOLEAN, ri); FOR k := 0 TO ri-1 DO v[k] := (f1[k] = f2[k]); END; VAR n: INTEGER := 0; BEGIN FOR k := 0 TO ri-1 DO IF v[k] THEN INC(n) END; END; IF n = ri THEN Wr.PutText(stderr, "Failed Test Of Faces\n"); FOR k := 0 TO ri-1 DO Wr.PutText(stderr,Fmt.Int(f1[k]) & " "); END; Wr.PutText(stderr,"\n"); Process.Exit(1); END END END END END END END END END DoIt; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFile"); o.inFile := pp.getNext(); o.edge := pp.keywordPresent("-edge"); o.face := pp.keywordPresent("-face"); o.all := pp.keywordPresent("-all"); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: TestGeomDege -inFile \\\n"); Wr.PutText(stderr, " [ -edge | -face | -all ]\n"); Process.Exit(1); END END; RETURN o END GetOptions; BEGIN DoIt() END TestGeomDege. (**************************************************************************) (* *) (* Copyright (C) 2001 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/TestRootElements.m3 MODULE TestRootElements EXPORTS Main; (* This program serves as the base for the implementation of the "curvature" energies: Curv2D and Curv1D. Revision: 06-06-2000 by lozada: Optimized the collect of the "children" elements. *) IMPORT Triangulation, Fmt, Stdio, Wr, Thread, Process, ParseParams, Stat, Text; FROM Stdio IMPORT stderr; FROM Triangulation IMPORT Face, Edge; CONST IniStackSize = 100000; (* Types *) TYPE StackF = REF ARRAY OF Face; StackE = REF ARRAY OF Edge; Element = {Edge, Face}; FACES = ARRAY OF Face; EDGES = ARRAY OF Edge; Options = RECORD inFileTp: TEXT; (* Initial guess file name (minus ".tp") *) element: Element; elename: TEXT; END; Number = RECORD nre : INTEGER; (* number of "root" elements. *) nce : CARDINAL; (* number of "children" elements inside each "root" element. *) END; VAR str,stc: Stat.T; (* statistical accumulators to the number of "root" elements and the number of "children" elements inside each "root" element. *) PROCEDURE DoIt() = <* FATAL Thread.Alerted, Wr.Failure *> VAR num: Number; BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToTaMa(o.inFileTp), tp = tc.top DO IF o.element = Element.Face THEN num := FaceStatistics(tp); Wr.PutText(stderr, Fmt.Int(num.nre) & " " & Fmt.Int(num.nce) & "\n"); WITH cf = CropChilFaces(tp,num) DO Wr.PutText(stderr,"Children faces of the root face \n"); FOR i := 0 TO num.nre-1 DO Wr.PutText(stderr, Fmt.Pad(Fmt.Int(i),3) & ": "); FOR j := 0 TO num.nce-1 DO Wr.PutText(stderr, Fmt.Pad(Fmt.Int(cf[i,j].num), 5) & " "); END; Wr.PutText(stderr,"\n"); END END ELSE num := EdgeStatistics(tp); Wr.PutText(stderr, Fmt.Int(num.nre) & " " & Fmt.Int(num.nce) & "\n"); WITH ce = CropChilEdges(tp,num) DO Wr.PutText(stderr,"Children edges of the root edge \n"); FOR i := 0 TO num.nre-1 DO Wr.PutText(stderr, Fmt.Pad(Fmt.Int(i),3) & ": "); FOR j := 0 TO num.nce-1 DO Wr.PutText(stderr, Fmt.Pad(Fmt.Int(ce[i,j].num), 5) & " "); END; Wr.PutText(stderr,"\n"); END END END END END DoIt; PROCEDURE CropChilFaces( READONLY top: Triangulation.Topology; READONLY num: Number; ) : REF ARRAY OF StackF = VAR topi : REF ARRAY OF CARDINAL; (* Crop the "children" faces for each "root" face. *) BEGIN (* initialize the "top" indexes for each of the "num.nre" stacks of faces. *) topi := NEW(REF ARRAY OF CARDINAL, num.nre); FOR k := 0 TO num.nre-1 DO topi[k] := 0 END; WITH t = NEW(REF ARRAY OF StackF, num.nre) DO FOR k := 0 TO num.nre-1 DO t[k] := NEW(REF ARRAY OF Face, IniStackSize); END; FOR j := 0 TO top.NF-1 DO WITH f = top.face[j], fr = f.root DO IF fr # -1 THEN SaveF(t[fr],topi[fr],f) END; END END; RETURN t; END; END CropChilFaces; PROCEDURE CropChilEdges( READONLY top: Triangulation.Topology; READONLY num: Number; ): REF ARRAY OF StackE = (* Crop the "children" edges for each "root" edge. *) VAR topj : REF ARRAY OF CARDINAL; BEGIN (* initialize the "top" indexes for each of the "num.nre" stacks of edges. *) topj := NEW(REF ARRAY OF CARDINAL, num.nre); FOR k := 0 TO num.nre-1 DO topj[k] := 0 END; WITH t = NEW(REF ARRAY OF StackE, num.nre) DO FOR k := 0 TO num.nre-1 DO t[k] := NEW(REF ARRAY OF Edge, IniStackSize); END; FOR j := 0 TO top.NE-1 DO WITH e = top.edge[j], er = e.root DO IF er # -1 THEN SaveE(t[er],topj[er],e) END; END END; RETURN t; END; END CropChilEdges; PROCEDURE FaceStatistics(READONLY top: Triangulation.Topology) : Number = (* Compute the number of "root" faces and the number of "children" faces. *) VAR num: Number; BEGIN FOR i:= 0 TO top.NF-1 DO WITH f = top.face[i], fr = FLOAT(f.root,REAL) DO Stat.Accum(str,fr); IF fr = 0.0 THEN Stat.Accum(stc,fr) END; END END; num.nre := FLOOR(str.maximum)+1; num.nce := FLOOR(stc.num); RETURN num; END FaceStatistics; PROCEDURE EdgeStatistics(READONLY top: Triangulation.Topology) : Number = (* Compute the number of "root" edges and the number of "children" edges. *) VAR num: Number; BEGIN FOR i := 0 TO top.NE-1 DO WITH e = top.edge[i], er = FLOAT(e.root,REAL) DO Stat.Accum(str,er); IF er = 0.0 THEN Stat.Accum(stc,er) END; END END; num.nre := FLOOR(str.maximum)+1; num.nce := FLOOR(stc.num); RETURN num; END EdgeStatistics; PROCEDURE SaveF( VAR Stack : StackF; VAR top: CARDINAL; VAR face : Face; ) = (* Save the face "face" on the stack "Stack" *) BEGIN Stack[top] := face; top := top +1 END SaveF; PROCEDURE SaveE( VAR Stack : StackE; VAR top: CARDINAL; VAR edge: Edge; ) = (* Save the edge "edge" on the stack "Stack" *) BEGIN Stack[top] := edge; top := top +1 END SaveE; <* UNUSED *> PROCEDURE CollectChilEdges( READONLY top: Triangulation.Topology; READONLY num: Number; ): REF ARRAY OF EDGES = VAR NT: CARDINAL; BEGIN WITH t = NEW(REF ARRAY OF EDGES, num.nre, num.nce) DO FOR i := 0 TO num.nre-1 DO NT := 0; FOR j := 0 TO top.NE-1 DO WITH e = top.edge[j], er = e.root DO IF er = i THEN t[i,NT] := e; INC(NT) END; END END END; RETURN t; END; END CollectChilEdges; <* UNUSED *> PROCEDURE CollectChilFaces( READONLY top: Triangulation.Topology; READONLY num: Number; ) : REF ARRAY OF FACES = VAR NT: CARDINAL; BEGIN WITH t = NEW(REF ARRAY OF FACES, num.nre, num.nce) DO FOR i := 0 TO num.nre-1 DO NT := 0; FOR j := 0 TO top.NF-1 DO WITH f = top.face[j], fr = f.root DO IF fr = i THEN t[i,NT] := f; INC(NT) END; END END END; RETURN t; END; END CollectChilFaces; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFileTp"); o.inFileTp := pp.getNext(); pp.getKeyword("-element"); o.elename := pp.getNext(); IF Text.Equal(o.elename, "edge") THEN o.element := Element.Edge ELSIF Text.Equal(o.elename, "face") THEN o.element := Element.Face ELSE pp.error("bad element \"" & pp.getNext() & "\"\n") END; pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: TestRootElements " ); Wr.PutText(stderr, " -inFileTp \\\n"); Wr.PutText(stderr, " -element { edge | face }\n" ); Process.Exit (1); END; END; RETURN o END GetOptions; BEGIN DoIt() END TestRootElements. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/TestSubdivideEdge.m3 MODULE TestSubdivideEdge EXPORTS Main; (* This program subdivides an edge and propagates the subdivision for the star of this edge. Teste with success in the subdivision of bipyramids and in the Refine- Triang program. *) IMPORT Triangulation, Stdio, Wr, Thread, Process, ParseParams, Octf, Squared, R3; FROM Stdio IMPORT stderr; FROM Triangulation IMPORT Pair, Org, MakeTopology, MakeFacetEdge, MakeVertex, SetOrg, SetAllOrgs, Pneg, SetAllPneg, Node, Vertex; FROM Octf IMPORT Fnext, Clock, Enext, Enext_1, SetEnext, SetEdgeAll, SetFaceAll, SetFnext; FROM Squared IMPORT MakeTriangle; VAR NVE: CARDINAL := 0; TYPE Options = RECORD inFile: TEXT; (* Initial guess file name (minus ".tp") *) outFile: TEXT; (* Output file name prefix *) END; PROCEDURE DoIt() = BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToMa(o.inFile), top = tc.top, e = top.edge[0], a = e.pa, dfr = Octf.DegreeFaceRing(a) DO SubdivideEdge(a,dfr,top); WITH newtop = MakeTopology(a), nc = Triangulation.GenCoords(newtop)^, comments = " " DO Triangulation.WriteTopology(o.outFile, newtop, comments); Triangulation.WriteState(o.outFile, newtop, nc, comments); Triangulation.WriteMaterials(o.outFile, newtop, comments); END END END DoIt; PROCEDURE SubdivideEdge( an: Pair; n: CARDINAL; READONLY top: Triangulation.Topology; ) = VAR x: Node; a,bn,m1,m2,m3,t0,t1,t2: REF ARRAY OF Pair; wn,p: REF ARRAY OF Node; BEGIN a := NEW(REF ARRAY OF Pair,n); bn := NEW(REF ARRAY OF Pair,n); m1 := NEW(REF ARRAY OF Pair,n); m2 := NEW(REF ARRAY OF Pair,n); m3 := NEW(REF ARRAY OF Pair,n); t0 := NEW(REF ARRAY OF Pair,n); t1 := NEW(REF ARRAY OF Pair,n); t2 := NEW(REF ARRAY OF Pair,n); (* save the pairs *) a := NEW(REF ARRAY OF Pair,n); a[0] := an; WITH f = a[0].facetedge.face, e = a[0].facetedge.edge, ee = Enext(a[0]).facetedge.edge, ee_ = Enext_1(a[0]).facetedge.edge DO IF top.face[f.num].exists THEN f.exists := TRUE; ELSE f.exists := FALSE; END; f.color := top.face[f.num].color; f.transp := top.face[f.num].transp; IF top.edge[e.num].exists THEN e.exists := TRUE; ELSE e.exists := FALSE; END; e.color := top.edge[e.num].color; e.transp := top.edge[e.num].transp; e.radius := top.edge[e.num].radius; IF top.edge[ee.num].exists THEN ee.exists := TRUE; ELSE ee.exists := FALSE; END; ee.color := top.edge[ee.num].color; ee.transp := top.edge[ee.num].transp; ee.radius := top.edge[ee.num].radius; IF top.edge[ee_.num].exists THEN ee_.exists := TRUE; ELSE ee_.exists := FALSE; END; ee_.color := top.edge[ee_.num].color; ee_.transp := top.edge[ee_.num].transp; ee_.radius := top.edge[ee_.num].radius; END; FOR i := 1 TO n-1 DO a[i] := Fnext(a[i-1]); WITH f = a[i].facetedge.face, ee = Enext(a[i]).facetedge.edge, ee_ = Enext_1(a[i]).facetedge.edge DO IF top.face[f.num].exists THEN f.exists := TRUE; ELSE f.exists := FALSE; END; f.color := top.face[f.num].color; f.transp := top.face[f.num].transp; IF top.edge[ee.num].exists THEN ee.exists := TRUE; ELSE ee.exists := FALSE; END; ee.color := top.edge[ee.num].color; ee.transp := top.edge[ee.num].transp; ee.radius := top.edge[ee.num].radius; IF top.edge[ee_.num].exists THEN ee_.exists := TRUE; ELSE ee_.exists := FALSE; END; ee_.color := top.edge[ee_.num].color; ee_.transp := top.edge[ee_.num].transp; ee_.radius := top.edge[ee_.num].radius; END END; (* save the vertices *) wn := NEW(REF ARRAY OF Node,n); FOR i := 0 TO n-1 DO wn[i] := Org(Enext_1(a[i])); END; (* save the tetrahedra *) p := NEW(REF ARRAY OF Node,n); FOR i := 0 TO n-1 DO p[i] := Pneg(a[i]); END; (* save other pairs *) bn := NEW(REF ARRAY OF Pair,n); FOR i := 0 TO n-1 DO bn[i] := Clock(Enext_1(Fnext(Enext_1(a[i])))); WITH e = bn[i].facetedge.edge, f = bn[i].facetedge.face DO IF top.edge[e.num].exists THEN e.exists := TRUE; ELSE e.exists := FALSE; END; e.color := top.edge[e.num].color; e.transp := top.edge[e.num].transp; e.radius := top.edge[e.num].radius; IF top.face[f.num].exists THEN f.exists := TRUE; ELSE f.exists := FALSE; END; f.color := top.face[f.num].color; f.transp := top.face[f.num].transp; END END; (* insert facetedges and edges *) FOR i := 0 TO n-1 DO m1[i] := MakeFacetEdge(); m2[i] := MakeFacetEdge(); m3[i] := MakeFacetEdge(); t0[i] := MakeTriangle(); t1[i] := Enext(t0[i]); t2[i] := Enext(t1[i]); WITH f = t0[i].facetedge.face, e0 = t0[i].facetedge.edge, e1 = t1[i].facetedge.edge, e2 = t2[i].facetedge.edge DO f.exists := FALSE; f.transp := R3.T{1.0,1.0,1.0}; e1.exists := FALSE; e2.exists := FALSE; e1.radius := 0.003; e1.transp := R3.T{1.0,1.0,1.0}; e2.radius := 0.003; e2.transp := R3.T{1.0,1.0,1.0}; IF bn[i].facetedge.edge.exists THEN e0.exists := TRUE; ELSE e0.exists := FALSE; END END END; (* Now, subdivide edge and extend the subdivision on the edge's stars *) x := MakeVertex(); WITH v = NARROW(x, Vertex) DO v.label := "VE"; IF a[0].facetedge.edge.exists THEN v.radius := a[0].facetedge.edge.radius; v.color := a[0].facetedge.edge.color; v.transp := a[0].facetedge.edge.transp; ELSE v.radius := 0.00; v.color := R3.T{1.0,1.0,1.0}; v.transp := R3.T{1.0,1.0,1.0}; END; v.num := NVE; INC(NVE); END; FOR j := 0 TO n-1 DO WITH b = Enext(a[j]), be = b.facetedge.edge, c = Enext(b), ce = c.facetedge.edge, u = Org(a[j]), v = Org(b), w = Org(c), (* save the attributes of the edge-face component of the pair a[j] *) f = a[j].facetedge.face, fe = f.exists, fc = f.color, ft = f.transp, g = m3[j].facetedge.face, ge = g.exists, gc = g.color, gt = g.transp, h = m3[j].facetedge.edge DO SetEnext(a[j],m1[j]); SetEnext(m1[j],c); SetEnext(m2[j],m3[j]); SetEnext(m3[j],Clock(b)); SetOrg(a[j], u); SetOrg(Clock(a[j]), x); SetOrg(m2[j],v); SetOrg(Clock(m2[j]), x); SetOrg(m3[j], x); SetOrg(Clock(m3[j]), w); SetOrg(m1[j], x); SetOrg(Clock(m1[j]), w); SetFnext(m1[j],m3[j]); (* set the attributes for the face component *) SetFaceAll(a[j],f); SetFaceAll(m3[j],g); IF fe THEN ge := TRUE; ELSE ge := FALSE; END; gc := fc; gt := ft; SetEdgeAll(m3[j],h); SetEdgeAll(b,be); SetEdgeAll(c,ce); SetFaceAll(bn[j],bn[j].facetedge.face); SetFaceAll(Fnext(bn[j]),Fnext(bn[j]).facetedge.face); END END; FOR j := 0 TO n-1 DO SetFnext(Clock(m2[j]),Clock(m2[(j+1) MOD n])); END; WITH k = m2[0].facetedge.edge, e = a[0].facetedge.edge, ee = e.exists, er = e.radius, ec = e.color, et = e.transp, ke = k.exists, kr = k.radius, kc = k.color, kt = k.transp DO IF ee THEN ke := TRUE; ELSE ke := FALSE; END; kr := er; kc := ec; kt := et; SetEdgeAll(a[0],e); SetEdgeAll(m2[0],k); END; FOR j := 0 TO n-1 DO WITH cn = Fnext(bn[j]), e1 = t1[j].facetedge.edge, e2 = t2[j].facetedge.edge, cnf = cn.facetedge.face, cne = cn.facetedge.edge DO IF top.face[cnf.num].exists THEN cnf.exists := TRUE; ELSE cnf.exists := FALSE; END; cnf.color := top.face[cnf.num].color; cnf.transp := top.face[cnf.num].transp; IF top.edge[cne.num].exists THEN cne.exists := TRUE; ELSE cne.exists := FALSE; END; cne.color := top.edge[cne.num].color; cne.transp := top.edge[cne.num].transp; cne.radius := top.edge[cne.num].radius; (* set the origins *) SetAllOrgs(t0[j],wn[j]); SetAllOrgs(t1[j],wn[(j+1) MOD n]); SetAllOrgs(t2[j],x); SetFnext(bn[j], t0[j]); SetFnext(t0[j],cn); SetFnext(m1[j],t2[j]); SetFnext(t2[j],m3[j]); SetFnext(Clock(m1[(j+1) MOD n]), t1[j]); SetFnext(t1[j],Clock(m3[(j+1) MOD n])); SetEdgeAll(t0[j],cn.facetedge.edge); SetEdgeAll(t1[j],e1); SetEdgeAll(t2[j],e2); END END; (* insert polyhedra *) FOR j := 0 TO n-1 DO WITH q = Triangulation.MakePolyhedron() DO SetAllPneg(a[j],p[j]); SetAllPneg(m2[j],q); END END END SubdivideEdge; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFile"); o.inFile := pp.getNext(); pp.getKeyword("-outFile"); o.outFile := pp.getNext(); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: TestSubdivideEdge" ); Wr.PutText(stderr, " -inFile -outFile \n" ); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt() END TestSubdivideEdge. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/TestSubdivideFace.m3 MODULE TestSubdivideFace EXPORTS Main; (* Testing the SubdivideFace procedure. *) IMPORT Triangulation, Stdio, Wr, Thread, Process, ParseParams, Octf, Squared, R3, Mis; FROM Stdio IMPORT stderr; FROM Triangulation IMPORT Pair, Org, MakeTopology, Node, Vertex, MakePolyhedron, MakeFacetEdge, MakeVertex, SetAllOrgs, SetAllPneg, PnegP, PposP; FROM Octf IMPORT Fnext, Clock, Enext, Enext_1, Fnext_1, SetEnext, SetEdgeAll, SetFaceAll, SetFnext; FROM Squared IMPORT MakeTriangle; VAR NVF := 0; TYPE Options = RECORD inFile: TEXT; (* Initial guess file name (minus ".tp") *) outFile: TEXT; (* Output file name prefix *) END; PROCEDURE DoIt() = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToMa(o.inFile), top = tc.top DO (* Subdivision of degenerative faces *) Wr.PutText(stderr, "Eliminating degenerative faces\n"); FOR j := 0 TO top.NF-1 DO WITH f = top.face[j], a = f.pa DO IF((PnegP(a) # NIL) AND (PposP(a) #NIL)) THEN SubdivideFace(a,top); END; END; END; WITH newtop = MakeTopology(top.facetedge[0]), nc = Triangulation.GenCoords(newtop)^, comments = "Created by Selective Subdivision of : " & o.outFile DO Triangulation.WriteTopology(o.outFile, newtop, comments & ".tp\n" & "on " & Mis.Today() ); Triangulation.WriteState(o.outFile,newtop, nc, comments & ".st\n" & "on " & Mis.Today() ); Triangulation.WriteMaterials(o.outFile, newtop, comments & ".ma\n" & "on " & Mis.Today() ); END END END DoIt; PROCEDURE SubdivideFace(a: Pair; READONLY top: Triangulation.Topology) = (* Subdivide a degenerative triangular face in three new faces through the insertion of a new medial vertex of type "VF" and six face-edge pairs. Then, expand this subdivision on the face's star. *) VAR x: Node; BEGIN (* Create the medial vertex "VF" *) x := MakeVertex(); WITH v = NARROW(x, Vertex) DO v.label := "VF"; v.radius := 0.000; v.transp := R3.T{1.0,1.0,1.0}; v.color := R3.T{1.0,1.0,1.0}; v.num := NVF; INC(NVF); END; WITH fa = a.facetedge.face, ea = a.facetedge.edge, b = Enext(a), eb = b.facetedge.edge, c = Enext_1(a), ec = c.facetedge.edge, af = Fnext(a), bf = Fnext(b), cf = Fnext(c), af_ = Fnext_1(a), bf_ = Fnext_1(b), cf_ = Fnext_1(c), eaf = Enext_1(af).facetedge.edge, eaf_ = Enext_1(af_).facetedge.edge, faf = af.facetedge.face, faf_ = af_.facetedge.face, ebf = Enext_1(bf).facetedge.edge, ebf_ = Enext_1(bf_).facetedge.edge, fbf = bf.facetedge.face, fbf_ = bf_.facetedge.face, ecf = Enext_1(cf).facetedge.edge, ecf_ = Enext_1(cf_).facetedge.edge, fcf = cf.facetedge.face, fcf_ = cf_.facetedge.face, u = Org(a), v = Org(b), w = Org(c), d = MakeFacetEdge(), e = MakeFacetEdge(), f = MakeFacetEdge(), g = MakeFacetEdge(), h = MakeFacetEdge(), i = MakeFacetEdge(), df = d.facetedge.face, ff = f.facetedge.face, hf = h.facetedge.face, (* new faces to insert on the face's star *) f1 = MakeTriangle(), f2 = MakeTriangle(), f3 = MakeTriangle(), f4 = MakeTriangle(), f5 = MakeTriangle(), f6 = MakeTriangle(), q1 = MakePolyhedron(), q2 = MakePolyhedron(), q3 = MakePolyhedron(), q4 = MakePolyhedron(), q5 = MakePolyhedron(), q6 = MakePolyhedron() DO IF top.face[fa.num].exists THEN df.exists := TRUE; ff.exists := TRUE; hf.exists := TRUE; ELSE df.exists := FALSE; ff.exists := FALSE; hf.exists := FALSE; END; df.color := top.face[fa.num].color; df.transp := top.face[fa.num].transp; ff.color := top.face[fa.num].color; ff.transp := top.face[fa.num].transp; hf.color := top.face[fa.num].color; hf.transp := top.face[fa.num].transp; (* first link connecting the pair "a" *) SetEnext(a,d); SetEnext(d,e); SetEnext(e,a); SetFaceAll(d,df); (* second link connecting the pair "b" *) SetEnext(b,f); SetEnext(f,g); SetEnext(g,b); SetFaceAll(f,ff); (* third link connecting the pair "c" *) SetEnext(c,h); SetEnext(h,i); SetEnext(i,c); SetFaceAll(h,hf); (* save information about the original edge "a.facetedge.edge": "ea" *) ea.exists := top.edge[ea.num].exists; ea.color := top.edge[ea.num].color; ea.transp := top.edge[ea.num].transp; ea.radius := top.edge[ea.num].radius; (* save information about the original edge "b.facetedge.edge": "eb" *) eb.exists := top.edge[eb.num].exists; eb.color := top.edge[eb.num].color; eb.transp := top.edge[eb.num].transp; eb.radius := top.edge[eb.num].radius; (* save information about the original edge "c.facetedge.edge": "ec" *) ec.exists := top.edge[ec.num].exists; ec.color := top.edge[ec.num].color; ec.transp := top.edge[ec.num].transp; ec.radius := top.edge[ec.num].radius; (* save information about the face "af.facetedge.face" : "faf" *) faf.exists := top.face[faf.num].exists; faf.color := top.face[faf.num].color; faf.transp := top.face[faf.num].transp; (* save information about the edge "af.facetedge.edge" : "eaf" *) eaf.exists := top.edge[eaf.num].exists; eaf.color := top.edge[eaf.num].color; eaf.transp := top.edge[eaf.num].transp; eaf.radius := top.edge[eaf.num].radius; (* save information about the face "af_.facetedge.face" : "faf_" *) faf_.exists := top.face[faf_.num].exists; faf_.color := top.face[faf_.num].color; faf_.transp:= top.face[faf_.num].transp; (* save information about the edge "af_.facetedge.edge" : "eaf_" *) eaf_.exists := top.edge[eaf_.num].exists; eaf_.color := top.edge[eaf_.num].color; eaf_.transp := top.edge[eaf_.num].transp; eaf_.radius := top.edge[eaf_.num].radius; (* save information about the face "bf.facetedge.face" : "fbf" *) fbf.exists := top.face[fbf.num].exists; fbf.color := top.face[fbf.num].color; fbf.transp:= top.face[fbf.num].transp; (* save information about the edge "bf.facetedge.edge" : "ebf" *) ebf.exists := top.edge[ebf.num].exists; ebf.color := top.edge[ebf.num].color; ebf.transp := top.edge[ebf.num].transp; ebf.radius := top.edge[ebf.num].radius; (* save information about the face "bf_.facetedge.face" : "fbf_" *) fbf_.exists:= top.face[fbf_.num].exists; fbf_.color := top.face[fbf_.num].color; fbf_.transp:= top.face[fbf_.num].transp; (* save information about the edge "bf_.facetedge.edge" : "ebf_" *) ebf_.exists := top.edge[ebf_.num].exists; ebf_.color := top.edge[ebf_.num].color; ebf_.transp := top.edge[ebf_.num].transp; ebf_.radius := top.edge[ebf_.num].radius; (* save information about the face "cf.facetedge.face" : "fcf" *) fcf.exists := top.face[fcf.num].exists; fcf.color := top.face[fcf.num].color; fcf.transp:= top.face[fcf.num].transp; (* save information about the edge "cf.facetedge.edge" : "ecf" *) ecf.exists := top.edge[ecf.num].exists; ecf.color := top.edge[ecf.num].color; ecf.transp := top.edge[ecf.num].transp; ecf.radius := top.edge[ecf.num].radius; (* save information about the face "cf_.facetedge.face" : "fcf_" *) fcf_.exists := top.face[fcf_.num].exists; fcf_.color := top.face[fcf_.num].color; fcf_.transp:= top.face[fcf_.num].transp; (* save information about the edge "cf_.facetedge.edge" : "ecf_" *) ecf_.exists := top.edge[ecf_.num].exists; ecf_.color := top.edge[ecf_.num].color; ecf_.transp := top.edge[ecf_.num].transp; ecf_.radius := top.edge[ecf_.num].radius; (* set the attributes for the internal faces *) f1.facetedge.face.exists := FALSE; f2.facetedge.face.exists := FALSE; f3.facetedge.face.exists := FALSE; f4.facetedge.face.exists := FALSE; f5.facetedge.face.exists := FALSE; f6.facetedge.face.exists := FALSE; f1.facetedge.face.color := R3.T{1.0,1.0,1.0}; f2.facetedge.face.color := R3.T{1.0,1.0,1.0}; f3.facetedge.face.color := R3.T{1.0,1.0,1.0}; f4.facetedge.face.color := R3.T{1.0,1.0,1.0}; f5.facetedge.face.color := R3.T{1.0,1.0,1.0}; f6.facetedge.face.color := R3.T{1.0,1.0,1.0}; f1.facetedge.face.transp := R3.T{1.0,1.0,1.0}; f2.facetedge.face.transp := R3.T{1.0,1.0,1.0}; f3.facetedge.face.transp := R3.T{1.0,1.0,1.0}; f4.facetedge.face.transp := R3.T{1.0,1.0,1.0}; f5.facetedge.face.transp := R3.T{1.0,1.0,1.0}; f6.facetedge.face.transp := R3.T{1.0,1.0,1.0}; (* Now make the connections in the interior of face *) SetFnext(g,Clock(d)); SetFnext(i,Clock(f)); SetFnext(e,Clock(h)); (* Now subdivide the "Ppos(a)" tetrahedron ( the superior tetrahedron in my plan *) (* first we, insert f1 *) SetFnext(d, Clock(f1)); SetFnext(Clock(f1), Clock(g)); <* ASSERT Fnext(Clock(g)) = d *> SetFnext(Enext(f1),Enext(af)); SetFnext(Clock(Enext_1(bf)), Enext(f1)); (* now, we insert f2 *) SetFnext(f, Clock(f2)); SetFnext(Clock(f2), Clock(i)); <* ASSERT Fnext(Clock(i)) = f *> SetFnext(Enext(f2),Enext(bf)); SetFnext(Clock(Enext_1(cf)), Enext(f2)); (* now, we insert f3 *) SetFnext(h, Clock(f3)); SetFnext(Clock(f3), Clock(e)); <* ASSERT Fnext(Clock(e)) = h *> SetFnext(Enext(f3),Enext(cf)); SetFnext(Clock(Enext_1(af)), Enext(f3)); (* now make connections between the internal faces inserted *) SetFnext(Enext_1(f1),Enext_1(f3)); SetFnext(Enext_1(f3),Enext_1(f2)); <* ASSERT Fnext(Enext_1(f2)) = Enext_1(f1) *> (* set the superior axial edge *) SetEdgeAll(Enext_1(f1), Enext_1(f1).facetedge.edge); (* OK *) Enext_1(f1).facetedge.edge.exists := FALSE; Enext_1(f1).facetedge.edge.color := R3.T{1.0,1.0,1.0}; Enext_1(f1).facetedge.edge.transp := R3.T{1.0,1.0,1.0}; Enext_1(f1).facetedge.edge.radius := 0.004; (* Now subdivide the "Pneg(a)" tetrahedron ( the inferior tetrahedron in my plan *) (* now, we insert f4 *) SetFnext(Clock(g), Clock(f4)); <* ASSERT Fnext(Clock(f4)) = d *> SetFnext(Enext(af_), Enext(f4)); SetFnext(Enext(f4), Clock(Enext_1(bf_))); (* now, we insert f5 *) SetFnext(Clock(i), Clock(f5)); <* ASSERT Fnext(Clock(f5)) = f *> SetFnext(Enext(bf_), Enext(f5)); SetFnext(Enext(f5), Clock(Enext_1(cf_))); (* now, we insert f6 *) SetFnext(Clock(e), Clock(f6)); <* ASSERT Fnext(Clock(f6)) = h *> SetFnext(Enext(cf_), Enext(f6)); SetFnext(Enext(f6), Clock(Enext_1(af_))); (* now make connections between the internal faces inserted *) SetFnext(Enext_1(f4),Enext_1(f5)); SetFnext(Enext_1(f5),Enext_1(f6)); <* ASSERT Fnext(Enext_1(f6)) = Enext_1(f4) *> (* set the inferior axial edge *) SetEdgeAll(Enext_1(f4), Enext_1(f4).facetedge.edge); (* OK *) Enext_1(f4).facetedge.edge.exists := FALSE; Enext_1(f4).facetedge.edge.color := R3.T{1.0,1.0,1.0}; Enext_1(f4).facetedge.edge.transp := R3.T{1.0,1.0,1.0}; Enext_1(f4).facetedge.edge.radius := 0.004; (* set the origins *) SetAllOrgs(f1, x); SetAllOrgs(a, u); SetAllOrgs(b, v); SetAllOrgs(c, w); SetAllOrgs(Enext_1(f1), Org(Enext_1(af))); SetAllOrgs(Enext_1(f4), Org(Enext_1(af_))); (* set the new internal edges *) SetEdgeAll(f1,f1.facetedge.edge); f1.facetedge.edge.exists := FALSE; f1.facetedge.edge.color := R3.T{1.0,1.0,1.0}; f1.facetedge.edge.transp := R3.T{1.0,1.0,1.0}; f1.facetedge.edge.radius := 0.004; SetEdgeAll(f2,f2.facetedge.edge); f2.facetedge.edge.exists := FALSE; f2.facetedge.edge.color := R3.T{1.0,1.0,1.0}; f2.facetedge.edge.transp := R3.T{1.0,1.0,1.0}; f2.facetedge.edge.radius := 0.004; SetEdgeAll(f3,f3.facetedge.edge); f3.facetedge.edge.exists := FALSE; f3.facetedge.edge.color := R3.T{1.0,1.0,1.0}; f3.facetedge.edge.transp := R3.T{1.0,1.0,1.0}; f3.facetedge.edge.radius := 0.004; (* set the original edges and faces in the superior level *) SetEdgeAll(Enext_1(af),eaf); SetEdgeAll(Enext_1(bf),ebf); SetEdgeAll(Enext_1(cf),ecf); SetFaceAll(af,faf); SetFaceAll(bf,fbf); SetFaceAll(cf,fcf); (* set the original edges and faces in the inferior label *) SetEdgeAll(Enext_1(af_),eaf_); SetEdgeAll(Enext_1(bf_),ebf_); SetEdgeAll(Enext_1(cf_),ecf_); SetFaceAll(af_,faf_); SetFaceAll(bf_,fbf_); SetFaceAll(cf_,fcf_); (* set the original edges in the half label *) SetEdgeAll(a,ea); SetEdgeAll(b,eb); SetEdgeAll(c,ec); SetAllPneg(Clock(Enext_1(f1)),q1); SetAllPneg(Clock(Enext_1(f2)),q2); SetAllPneg(Clock(Enext_1(f3)),q3); SetAllPneg(Enext_1(f4),q4); SetAllPneg(Enext_1(f5),q5); SetAllPneg(Enext_1(f6),q6); END END SubdivideFace; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFile"); o.inFile := pp.getNext(); pp.getKeyword("-outFile"); o.outFile := pp.getNext(); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: TestSubdivideFace \\\n" ); Wr.PutText(stderr, " -inFile -outFile \\\n" ); Process.Exit (1); END END; RETURN o END GetOptions; <* UNUSED *> PROCEDURE NumInternalFaces(READONLY top: Triangulation.Topology) : CARDINAL = VAR number: CARDINAL := 0; BEGIN FOR j := 0 TO top.NF-1 DO WITH a = top.face[j].pa DO IF (PposP(a) # NIL) AND (PnegP(a) # NIL) THEN INC(number); END END END; RETURN number; END NumInternalFaces; BEGIN DoIt() END TestSubdivideFace. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/TestSubdivideTetra.m3 MODULE TestSubdivideTetra EXPORTS Main; (* Testing The SubdivideTetrahedron procedure. *) IMPORT Triangulation, Stdio, Wr, Thread, Process, ParseParams, Octf, Squared, R3, Mis, LR4; FROM Stdio IMPORT stderr; FROM Triangulation IMPORT Pair, Org, MakeTopology, Node,Vertex,MakePolyhedron, MakeVertex, SetAllOrgs, SetAllPneg, Topology, Coords, OrgV, Pneg, Ppos; FROM Octf IMPORT Fnext, Clock, Enext, Enext_1, Fnext_1, Spin, SetEdgeAll, SetFaceAll, SetFnext, Tors; FROM Squared IMPORT MakeTriangle; VAR NVP: CARDINAL := 0; X : REF ARRAY OF LR4.T; oldtopology : Topology; TYPE Options = RECORD inFile: TEXT; (* Initial guess file name (minus ".tp") *) outFile: TEXT; (* Output file name prefix *) END; PROCEDURE DoIt() = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToMa(o.inFile), top = tc.top, rc = Triangulation.ReadState(o.inFile), c = rc^, nc = NEW(REF Coords, top.NV+top.NP)^, comments = "Created by Selective Subdivision of : " & o.outFile DO (* Subdivision of degenerative tetrahedra *) Wr.PutText(stderr, "Eliminating degenerative tetrahedra\n"); FOR j := 0 TO top.NP-1 DO WITH r = top.region[j], a = Tors(r) DO SubdivideTetrahedron(a,top,c,nc); END END; WITH newtop = MakeTopology(top.facetedge[1]) DO Triangulation.WriteTopology(o.outFile, newtop, comments & ".tp\n" & "on " & Mis.Today() ); Triangulation.WriteState(o.outFile,newtop, nc, comments & ".st\n" & "on " & Mis.Today() ); Triangulation.WriteMaterials(o.outFile, newtop, comments & ".ma\n" & "on " & Mis.Today() ); END END END DoIt; PROCEDURE SubdivideTetrahedron(a: Pair; READONLY top: Topology; READONLY co: Coords; VAR nc: Coords) = (* Subdivide a degenerative tetrahedron in four new tetrahedra through the insertion of a new medial vertex of type "VP" more six faces and three edges. *) VAR y: Node; BEGIN (* Create the medial vertex "VP" *) y := MakeVertex(); WITH vv = NARROW(y, Vertex), b = Fnext_1(a), c = Enext_1(b), d = Fnext(c), e = Enext_1(a), f = Fnext_1(e), g = Enext_1(f), h = Fnext(g), fa = a.facetedge.face, fb = b.facetedge.face, fg = g.facetedge.face, fh = h.facetedge.face, ea = a.facetedge.edge, ec = c.facetedge.edge, ee = e.facetedge.edge, eh = h.facetedge.edge, eeb =Enext(b).facetedge.edge, eea =Enext(a).facetedge.edge, i = Enext(a), j = Fnext_1(i), k = Enext(b), l = Fnext(k), u = OrgV(a), v = OrgV(Clock(a)), w = OrgV(c), x = OrgV(e), f1 = MakeTriangle(), f2 = MakeTriangle(), f3 = MakeTriangle(), f4 = MakeTriangle(), f5 = MakeTriangle(), f6 = MakeTriangle(), q1 = MakePolyhedron(), q2 = MakePolyhedron(), q3 = MakePolyhedron(), q4 = MakePolyhedron() DO vv.label := "VP"; vv.radius := 0.0001; vv.transp := R3.T{1.0,1.0,1.0}; vv.color := R3.T{1.0,1.0,1.0}; vv.num := NVP; INC(NVP); nc[u.num] := co[u.num]; nc[v.num] := co[v.num]; nc[w.num] := co[w.num]; nc[x.num] := co[x.num]; nc[vv.num] := LR4.Scale(0.25d0, LR4.Add(co[u.num], LR4.Add(LR4.Add(co[v.num],co[w.num]),co[x.num]))); (* save attributes for the original faces: "fa", "fb", "fg", "fh". *) fa.exists := top.face[fa.num].exists; fa.color := top.face[fa.num].color; fa.transp := top.face[fa.num].transp; fb.exists := top.face[fb.num].exists; fb.color := top.face[fb.num].color; fb.transp := top.face[fb.num].transp; fg.exists := top.face[fg.num].exists; fg.color := top.face[fg.num].color; fg.transp := top.face[fg.num].transp; fh.exists := top.face[fh.num].exists; fh.color := top.face[fh.num].color; fh.transp := top.face[fh.num].transp; (* save attributes for the original edges: "ea", "ec", "ee", "eh", "eeb", and "eea". *) ea.exists := top.edge[ea.num].exists; ea.color := top.edge[ea.num].color; ea.transp := top.edge[ea.num].transp; ea.radius := top.edge[ea.num].radius; ec.exists := top.edge[ec.num].exists; ec.color := top.edge[ec.num].color; ec.transp := top.edge[ec.num].transp; ec.radius := top.edge[ec.num].radius; ee.exists := top.edge[ee.num].exists; ee.color := top.edge[ee.num].color; ee.transp := top.edge[ee.num].transp; ee.radius := top.edge[ee.num].radius; eh.exists := top.edge[eh.num].exists; eh.color := top.edge[eh.num].color; eh.transp := top.edge[eh.num].transp; eh.radius := top.edge[eh.num].radius; eea.exists := top.edge[eea.num].exists; eea.color := top.edge[eea.num].color; eea.transp := top.edge[eea.num].transp; eea.radius := top.edge[eea.num].radius; eeb.exists := top.edge[eeb.num].exists; eeb.color := top.edge[eeb.num].color; eeb.transp := top.edge[eeb.num].transp; eeb.radius := top.edge[eeb.num].radius; (* set the attributes for the new internal faces *) f1.facetedge.face.exists := FALSE; f2.facetedge.face.exists := FALSE; f3.facetedge.face.exists := FALSE; f4.facetedge.face.exists := FALSE; f5.facetedge.face.exists := FALSE; f6.facetedge.face.exists := FALSE; f1.facetedge.face.color := R3.T{1.0,1.0,1.0}; f2.facetedge.face.color := R3.T{1.0,1.0,1.0}; f3.facetedge.face.color := R3.T{1.0,1.0,1.0}; f4.facetedge.face.color := R3.T{1.0,1.0,1.0}; f5.facetedge.face.color := R3.T{1.0,1.0,1.0}; f6.facetedge.face.color := R3.T{1.0,1.0,1.0}; f1.facetedge.face.transp := R3.T{1.0,1.0,1.0}; f2.facetedge.face.transp := R3.T{1.0,1.0,1.0}; f3.facetedge.face.transp := R3.T{1.0,1.0,1.0}; f4.facetedge.face.transp := R3.T{1.0,1.0,1.0}; f5.facetedge.face.transp := R3.T{1.0,1.0,1.0}; f6.facetedge.face.transp := R3.T{1.0,1.0,1.0}; (* insert f1 *) SetFnext(b,f1); SetFnext(f1,a); (* insert f2 *) SetFnext(c,f2); SetFnext(f2,d); (* insert f3 *) SetFnext(f,f3); SetFnext(f3,e); (* set the relations among f1,f2 and f3 *) SetFnext(Clock(Enext(f2)),Enext_1(f1)); SetFnext(Enext_1(f1),Clock(Enext(f3))); SetFnext(Clock(Enext(f3)),Clock(Enext(f2))); SetEdgeAll(Enext_1(f1), Enext_1(f1).facetedge.edge); Enext_1(f1).facetedge.edge.exists := FALSE; Enext_1(f1).facetedge.edge.color := R3.T{1.0,1.0,1.0}; Enext_1(f1).facetedge.edge.transp := R3.T{1.0,1.0,1.0}; Enext_1(f1).facetedge.edge.radius := 0.004; (* insert f4 *) SetFnext(j,f4); SetFnext(f4,i); (* insert f5 *) SetFnext(k,f5); SetFnext(f5,l); (* insert f6 *) SetFnext(g,f6); SetFnext(f6,h); (* set the internal relations along edge "yv" *) SetFnext(Enext_1(f5),Enext_1(f4)); SetFnext(Enext_1(f4),Clock(Enext(f1))); SetFnext(Clock(Enext(f1)), Enext_1(f5)); SetEdgeAll(Clock(Enext(f1)),Clock(Enext(f1)).facetedge.edge); Enext(f1).facetedge.edge.exists := FALSE; Enext(f1).facetedge.edge.color := R3.T{1.0,1.0,1.0}; Enext(f1).facetedge.edge.transp := R3.T{1.0,1.0,1.0}; Enext(f1).facetedge.edge.radius := 0.004; (* set the internal relations along edge "wy" *) SetFnext(Enext(f5),Clock(Enext_1(f6))); SetFnext(Clock(Enext_1(f6)),Clock(Enext_1(f2))); SetFnext(Clock(Enext_1(f2)),Enext(f5)); SetEdgeAll(Enext(f5),Enext(f5).facetedge.edge); Enext(f5).facetedge.edge.exists := FALSE; Enext(f5).facetedge.edge.color := R3.T{1.0,1.0,1.0}; Enext(f5).facetedge.edge.transp := R3.T{1.0,1.0,1.0}; Enext(f5).facetedge.edge.radius := 0.004; (* set the internal relations along edge "xy" *) SetFnext(Enext(f6), Enext(f4)); SetFnext(Enext(f4), Clock(Enext_1(f3))); SetFnext(Clock(Enext_1(f3)), Enext(f6)); SetEdgeAll(Enext(f4), Enext(f4).facetedge.edge); Enext(f4).facetedge.edge.exists := FALSE; Enext(f4).facetedge.edge.color := R3.T{1.0,1.0,1.0}; Enext(f4).facetedge.edge.transp := R3.T{1.0,1.0,1.0}; Enext(f4).facetedge.edge.radius := 0.004; (* set the overall edge component *) SetEdgeAll(a, ea); SetEdgeAll(c, ec); SetEdgeAll(e, ee); SetEdgeAll(i, eea); SetEdgeAll(k, eeb); SetEdgeAll(h, eh); SetFaceAll(a, fa); SetFaceAll(b, fb); SetFaceAll(g, fg); SetFaceAll(h, fh); (* set the origins *) SetAllOrgs(a,u); SetAllOrgs(Clock(a),v); SetAllOrgs(c,w); SetAllOrgs(e,x); SetAllOrgs(Enext_1(f1),y); (* set the polyhedrons *) SetAllPneg(a,q1); SetAllPneg(Spin(b),q2); SetAllPneg(Spin(g),q3); SetAllPneg(Spin(f6),q4); END; END SubdivideTetrahedron; (* PROCEDURE FixaTetrahedron(a: Pair; READONLY c: Coords; VAR nc: Coords) = (* *) BEGIN <* ASSERT NOT (Pneg(a) # NIL AND Ppos(a) # NIL ) *> WITH u = OrgV(a), v = OrgV(Clock(a)), x = OrgV(Enext_1(a)), w = OrgV(Enext_1(Fnext(a))), y = OrgV(Enext_1(Fnext_1(a))) DO Mis.WriteInt(stderr, u.num); Mis.WriteInt(stderr, v.num); Mis.WriteInt(stderr, w.num); Mis.WriteInt(stderr, x.num); Mis.WriteInt(stderr, y.num); Wr.PutText(stderr, y.label); END; END FixaTetrahedron; *) PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFile"); o.inFile := pp.getNext(); pp.getKeyword("-outFile"); o.outFile := pp.getNext(); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: TestSubdivideTetra \\\n" ); Wr.PutText(stderr, " -inFile -outFile \\\n" ); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt() END TestSubdivideTetra. (**************************************************************************) (* *) (* Copyright (C) 2001 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/TestSubdivideTetrahedron.m3 MODULE TestSubdivideTetrahedron EXPORTS Main; (* Testing The SubdivideTetrahedron procedure. *) IMPORT Triangulation, Stdio, Wr, Thread, Process, ParseParams, Octf, Squared, R3, Mis; FROM Stdio IMPORT stderr; FROM Triangulation IMPORT Pair, Org, MakeTopology, Node,Vertex,MakePolyhedron, MakeVertex, SetAllOrgs, SetAllPneg, Topology; FROM Octf IMPORT Fnext, Clock, Enext, Enext_1, Fnext_1, Spin, SetEdgeAll, SetFaceAll, SetFnext, Tors; FROM Squared IMPORT MakeTriangle; VAR NVP: CARDINAL := 0; TYPE Options = RECORD inFile: TEXT; (* Initial guess file name (minus ".tp") *) outFile: TEXT; (* Output file name prefix *) END; PROCEDURE DoIt() = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToMa(o.inFile), top = tc.top DO (* Subdivision of degenerative tetrahedra *) Wr.PutText(stderr, "Eliminating degenerative tetrahedra\n"); FOR j := 0 TO top.NP-1 DO WITH r = top.region[j], a = Tors(r) DO SubdivideTetrahedron(a,top); END END; WITH newtop = MakeTopology(top.facetedge[1],1), nc = Triangulation.GenCoords(newtop)^, comments = "Created by Selective Subdivision of : " & o.outFile DO Triangulation.WriteTopology(o.outFile, newtop, comments & ".tp\n" & "on " & Mis.Today() ); Triangulation.WriteState(o.outFile,newtop, nc, comments & ".st\n" & "on " & Mis.Today() ); Triangulation.FindDegeneracies(newtop); Triangulation.WriteMaterials(o.outFile, newtop, comments & ".ma\n" & "on " & Mis.Today() ); END END END DoIt; PROCEDURE SubdivideTetrahedron(a: Pair; READONLY top: Topology) = (* Subdivide a degenerative tetrahedron in four new tetrahedra through the insertion of a new medial vertex of type "VP" more six faces and three edges. *) VAR y: Node; BEGIN (* Create the medial vertex "VP" *) y := MakeVertex(); WITH v = NARROW(y, Vertex) DO v.label := "VP"; v.radius := 0.00; v.transp := R3.T{1.0,1.0,1.0}; v.color := R3.T{1.0,1.0,1.0}; v.num := NVP; INC(NVP); END; WITH b = Fnext_1(a), c = Enext_1(b), d = Fnext(c), e = Enext_1(a), f = Fnext_1(e), g = Enext_1(f), h = Fnext(g), fa = a.facetedge.face, fb = b.facetedge.face, fg = g.facetedge.face, fh = h.facetedge.face, ea = a.facetedge.edge, ec = c.facetedge.edge, ee = e.facetedge.edge, eh = h.facetedge.edge, eeb =Enext(b).facetedge.edge, eea =Enext(a).facetedge.edge, i = Enext(a), j = Fnext_1(i), k = Enext(b), l = Fnext(k), u = Org(a), v = Org(Clock(a)), w = Org(c), x = Org(e), f1 = MakeTriangle(), f2 = MakeTriangle(), f3 = MakeTriangle(), f4 = MakeTriangle(), f5 = MakeTriangle(), f6 = MakeTriangle(), q1 = MakePolyhedron(), q2 = MakePolyhedron(), q3 = MakePolyhedron(), q4 = MakePolyhedron() DO (* save attributes for the original faces: "fa", "fb", "fg", "fh". *) fa.exists := top.face[fa.num].exists; fa.color := top.face[fa.num].color; fa.transp := top.face[fa.num].transp; fb.exists := top.face[fb.num].exists; fb.color := top.face[fb.num].color; fb.transp := top.face[fb.num].transp; fg.exists := top.face[fg.num].exists; fg.color := top.face[fg.num].color; fg.transp := top.face[fg.num].transp; fh.exists := top.face[fh.num].exists; fh.color := top.face[fh.num].color; fh.transp := top.face[fh.num].transp; (* save attributes for the original edges: "ea", "ec", "ee", "eh", "eeb", and "eea". *) ea.exists := top.edge[ea.num].exists; ea.color := top.edge[ea.num].color; ea.transp := top.edge[ea.num].transp; ea.radius := top.edge[ea.num].radius; ec.exists := top.edge[ec.num].exists; ec.color := top.edge[ec.num].color; ec.transp := top.edge[ec.num].transp; ec.radius := top.edge[ec.num].radius; ee.exists := top.edge[ee.num].exists; ee.color := top.edge[ee.num].color; ee.transp := top.edge[ee.num].transp; ee.radius := top.edge[ee.num].radius; eh.exists := top.edge[eh.num].exists; eh.color := top.edge[eh.num].color; eh.transp := top.edge[eh.num].transp; eh.radius := top.edge[eh.num].radius; eea.exists := top.edge[eea.num].exists; eea.color := top.edge[eea.num].color; eea.transp := top.edge[eea.num].transp; eea.radius := top.edge[eea.num].radius; eeb.exists := top.edge[eeb.num].exists; eeb.color := top.edge[eeb.num].color; eeb.transp := top.edge[eeb.num].transp; eeb.radius := top.edge[eeb.num].radius; (* set the attributes for the new internal faces *) f1.facetedge.face.exists := FALSE; f2.facetedge.face.exists := FALSE; f3.facetedge.face.exists := FALSE; f4.facetedge.face.exists := FALSE; f5.facetedge.face.exists := FALSE; f6.facetedge.face.exists := FALSE; f1.facetedge.face.color := R3.T{1.0,1.0,1.0}; f2.facetedge.face.color := R3.T{1.0,1.0,1.0}; f3.facetedge.face.color := R3.T{1.0,1.0,1.0}; f4.facetedge.face.color := R3.T{1.0,1.0,1.0}; f5.facetedge.face.color := R3.T{1.0,1.0,1.0}; f6.facetedge.face.color := R3.T{1.0,1.0,1.0}; f1.facetedge.face.transp := R3.T{1.0,1.0,1.0}; f2.facetedge.face.transp := R3.T{1.0,1.0,1.0}; f3.facetedge.face.transp := R3.T{1.0,1.0,1.0}; f4.facetedge.face.transp := R3.T{1.0,1.0,1.0}; f5.facetedge.face.transp := R3.T{1.0,1.0,1.0}; f6.facetedge.face.transp := R3.T{1.0,1.0,1.0}; (* insert f1 *) SetFnext(b,f1); SetFnext(f1,a); (* insert f2 *) SetFnext(c,f2); SetFnext(f2,d); (* insert f3 *) SetFnext(f,f3); SetFnext(f3,e); (* set the relations among f1,f2 and f3 *) SetFnext(Clock(Enext(f2)),Enext_1(f1)); SetFnext(Enext_1(f1),Clock(Enext(f3))); SetFnext(Clock(Enext(f3)),Clock(Enext(f2))); SetEdgeAll(Enext_1(f1), Enext_1(f1).facetedge.edge); Enext_1(f1).facetedge.edge.exists := FALSE; Enext_1(f1).facetedge.edge.color := R3.T{1.0,1.0,1.0}; Enext_1(f1).facetedge.edge.transp := R3.T{1.0,1.0,1.0}; Enext_1(f1).facetedge.edge.radius := 0.004; (* insert f4 *) SetFnext(j,f4); SetFnext(f4,i); (* insert f5 *) SetFnext(k,f5); SetFnext(f5,l); (* insert f6 *) SetFnext(g,f6); SetFnext(f6,h); (* set the internal relations along edge "yv" *) SetFnext(Enext_1(f5),Enext_1(f4)); SetFnext(Enext_1(f4),Clock(Enext(f1))); SetFnext(Clock(Enext(f1)), Enext_1(f5)); SetEdgeAll(Clock(Enext(f1)),Clock(Enext(f1)).facetedge.edge); Enext(f1).facetedge.edge.exists := FALSE; Enext(f1).facetedge.edge.color := R3.T{1.0,1.0,1.0}; Enext(f1).facetedge.edge.transp := R3.T{1.0,1.0,1.0}; Enext(f1).facetedge.edge.radius := 0.004; (* set the internal relations along edge "wy" *) SetFnext(Enext(f5),Clock(Enext_1(f6))); SetFnext(Clock(Enext_1(f6)),Clock(Enext_1(f2))); SetFnext(Clock(Enext_1(f2)),Enext(f5)); SetEdgeAll(Enext(f5),Enext(f5).facetedge.edge); Enext(f5).facetedge.edge.exists := FALSE; Enext(f5).facetedge.edge.color := R3.T{1.0,1.0,1.0}; Enext(f5).facetedge.edge.transp := R3.T{1.0,1.0,1.0}; Enext(f5).facetedge.edge.radius := 0.004; (* set the internal relations along edge "xy" *) SetFnext(Enext(f6), Enext(f4)); SetFnext(Enext(f4), Clock(Enext_1(f3))); SetFnext(Clock(Enext_1(f3)), Enext(f6)); SetEdgeAll(Enext(f4), Enext(f4).facetedge.edge); Enext(f4).facetedge.edge.exists := FALSE; Enext(f4).facetedge.edge.color := R3.T{1.0,1.0,1.0}; Enext(f4).facetedge.edge.transp := R3.T{1.0,1.0,1.0}; Enext(f4).facetedge.edge.radius := 0.004; (* set the overall edge component *) SetEdgeAll(a, ea); SetEdgeAll(c, ec); SetEdgeAll(e, ee); SetEdgeAll(i, eea); SetEdgeAll(k, eeb); SetEdgeAll(h, eh); SetFaceAll(a, fa); SetFaceAll(b, fb); SetFaceAll(g, fg); SetFaceAll(h, fh); (* set the origins *) SetAllOrgs(a,u); SetAllOrgs(Clock(a),v); SetAllOrgs(c,w); SetAllOrgs(e,x); SetAllOrgs(Enext_1(f1),y); (* set the polyhedrons *) SetAllPneg(a,q1); SetAllPneg(Spin(b),q2); SetAllPneg(Spin(g),q3); SetAllPneg(Spin(f6),q4); END; END SubdivideTetrahedron; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFile"); o.inFile := pp.getNext(); pp.getKeyword("-outFile"); o.outFile := pp.getNext(); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: TestSubdivideTetrahedron\\\n" ); Wr.PutText(stderr, " -inFile -outFile \\\n" ); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt() END TestSubdivideTetrahedron. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/TestTopology.m3 MODULE TestTopology EXPORTS Main; (* This program to test the characteristics of the Star and Link for all vertex, as well as, if every vertex is internal and if every face if internal (The input file must be contain one Triangulation not degene- rate. Also include some procedures for tests if every polyhedron on the star for one vertex are differents as well as every polyhedron is contained on the list of polyhedron of ".top" topology. Created by L. P. Lozada (see the copyright and authorship futher down). Last modification: 27-08-99 *) IMPORT Triangulation, Stdio, Wr, Thread, Process, ParseParams, Mis, Text, Scan, FloatMode, Lex, Fmt; FROM Stdio IMPORT stderr; FROM Triangulation IMPORT OrgV, PposP, PnegP, Org; TYPE Options = RECORD inFile: TEXT; (* Initial guess file name (minus ".top") *) listStar: BOOLEAN; (* For enumerate the polyhedron list belong of the star for every vertex. *) END; TYPE Pair = Triangulation.Pair; Quad = ARRAY [0..3] OF Vertex; Tri = ARRAY [0..2] OF CARDINAL; EndPoint = ARRAY [0..1] OF CARDINAL; Bi = ARRAY [0..2] OF EndPoint; Topology = Triangulation.Topology; Vertex = Triangulation.Vertex; <* UNUSED *> PROCEDURE Order(name: TEXT): INTEGER = <* FATAL FloatMode.Trap, Lex.Error *> BEGIN WITH n = Text.FindChar(name, '-'), o = Scan.Int(Text.Sub(name, n+1, 2)) DO RETURN o END END Order; <* UNUSED *> PROCEDURE TestePolyDif(READONLY top : Topology) = <* FATAL Wr.Failure, Thread.Alerted *> VAR p,q : REF ARRAY OF INTEGER; BEGIN FOR i := 0 TO top.NV-1 DO WITH a = top.out[i], poly = Triangulation.StarOfVertex(a,top) DO FOR j := 0 TO LAST(poly^) DO p := NEW(REF ARRAY OF INTEGER, 4); p[0] := poly[j][0].num; p[1] := poly[j][1].num; p[2] := poly[j][2].num; p[3] := poly[j][3].num; Mis.InsertionSort(3,p); FOR i := j+1 TO LAST(poly^) DO q := NEW(REF ARRAY OF INTEGER, 4); q[0] := poly[i][0].num; q[1] := poly[i][1].num; q[2] := poly[i][2].num; q[3] := poly[i][3].num; Mis.InsertionSort(3,q); IF (p[0]=q[0]) AND (p[1]=q[1]) AND (p[2]=q[2]) AND (p[3]=q[3]) THEN Wr.PutText(stderr, "ERRO ESTA NA LISTA<===\n"); END END END END END END TestePolyDif; <* UNUSED *> PROCEDURE TestePolyExist(READONLY top : Topology) = VAR saiu : BOOLEAN := FALSE; p : REF ARRAY OF INTEGER; BEGIN (* realiza teste si poliedro esta na lista *) FOR i := 0 TO top.NV-1 DO WITH a = top.out[i], poly = Triangulation.StarOfVertex(a,top) DO FOR j := 0 TO LAST(poly^) DO p := NEW(REF ARRAY OF INTEGER, 4); p[0] := poly[j][0].num; p[1] := poly[j][1].num; p[2] := poly[j][2].num; p[3] := poly[j][3].num; Mis.InsertionSort(3,p); WHILE NOT saiu DO FOR l := 0 TO top.NP-1 DO WITH q = top.polyhedron[l], q1 = q.vertex[0].num, q2 = q.vertex[1].num, q3 = q.vertex[2].num, q4 = q.vertex[3].num DO IF (p[0]=q1) AND (p[1]=q2) AND (p[2]=q3) AND (p[3]=q4) THEN saiu := TRUE; END END END END END END END END TestePolyExist; PROCEDURE DoIt() = <* FATAL Wr.Failure, Thread.Alerted *> VAR v: REF ARRAY OF INTEGER; BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToMa(o.inFile), top = tc.top DO FOR i := 0 TO top.NV-1 DO WITH a = top.out[i], poly = Triangulation.StarOfVertex(a,top), dg = Triangulation.DegreeOfVertex(a), np = Triangulation.NumberPolyOfStar(poly), nvs = dg, nfs = np, nes = EdgesOnTheLink(a,poly,np) DO (* ==> (2) condition : For All "v", degree(v) <= NV.top *) <* ASSERT dg <= top.NV *> (* ==> (3) condition : Test the property (ii) of combinatorics description of 3-manifolds without boundary, i.e: All 0-simplex in the triangulation K is a internal vertex: One internal vertex is every 0-simplex that have one link homeomorphic to sphere S^{2}, so must to perform the euler's formula: nv-ne+nf = 2. *) IF top.bdr = 0 AND (top.NV-top.NE+top.NF-top.NP = 0) THEN <* ASSERT nvs-nes+nfs = 2 *> END; (* ==> (4) condition : Test the property (i) of combinatorics description of 3-manifolds without boundary, i.e: All 2-simplex in the triangulation K is a internal face: One internal face is every 2-simplex that incident in exactly two 3-simplex. *) IF top.bdr = 0 THEN FOR i := 0 TO top.NF-1 DO WITH f = top.face[i], a = f.pa, p1 = PposP(a), p2 = PnegP(a) DO <* ASSERT p1 # p2 *> END END END; IF o.listStar THEN WITH star = Triangulation.Neighbors(a,top), nv = Triangulation.NumberNeighborVertex(star) DO <* ASSERT nv = dg *> Wr.PutText(stderr, "Org.num: " & Fmt.Int(Org(a).num) & " "); Wr.PutText(stderr, " Degree : " & Fmt.Int(dg) & "\n"); Wr.PutText(stderr, "Vertices belong to star of vertex: " & Fmt.Int(OrgV(a).num) & ":\n" ); v := NEW(REF ARRAY OF INTEGER, nv); FOR k := 0 TO nv-1 DO v[k] := star[k].num; END; (*Mis.InsertionSort(nv-1,v);*) FOR k := 0 TO nv-1 DO Wr.PutText(stderr, Fmt.Int(v[k]) & " " ); END; Wr.PutText(stderr, "\n" ); END; Wr.PutText(stderr, "\n" ); END END END; Wr.PutText(stderr, "Condition 2 OK\n"); IF top.bdr = 0 THEN Wr.PutText(stderr, "Condition 3 OK\n"); Wr.PutText(stderr, "Condition 4 OK\n"); END END; END DoIt; PROCEDURE EdgesOnTheLink( a : Pair; READONLY poly: REF ARRAY OF Quad; READONLY np : CARDINAL; ) : CARDINAL = CONST IniStackSize = 10000; VAR c : CARDINAL; tri : REF ARRAY OF Tri; bi : REF ARRAY OF Bi; stack := NEW(REF ARRAY OF EndPoint, IniStackSize); nstack : CARDINAL := 0; PROCEDURE Present(c: EndPoint) : BOOLEAN = (* retorna verdadeiro se "c" esta na pilha, FALSE c.c *) VAR nstack1 : CARDINAL := nstack; BEGIN WHILE nstack1 > 0 DO nstack1 := nstack1 - 1; IF stack[nstack1] = c THEN RETURN TRUE END; END; RETURN FALSE; END Present; BEGIN tri := NEW(REF ARRAY OF Tri, np); bi := NEW(REF ARRAY OF Bi, np); (* As arestas da cinta do vertice *) FOR i := 0 TO LAST(poly^) DO c := 0; FOR j := 0 TO 3 DO IF poly[i][j].num # OrgV(a).num THEN tri[i,c] := poly[i][j].num; INC(c); END; END; (* As arestas para cada face, ordenadas *) FOR l := 0 TO 2 DO IF tri[i,l] < tri[i,(l+1) MOD 3] THEN bi[i,l,0] := tri[i,l]; bi[i,l,1] := tri[i,(l+1) MOD 3]; ELSE bi[i,l,0] := tri[i,(l+1) MOD 3]; bi[i,l,1] := tri[i,l]; END; END; END; (* Achando o numero de arestas sob a superficie da vizinhanca *) FOR j := 0 TO LAST(poly^) DO FOR l := 0 TO 2 DO IF NOT Present(bi[j,l]) THEN stack[nstack] := bi[j,l]; INC(nstack); END; END; END; RETURN nstack; END EdgesOnTheLink; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFile"); o.inFile := pp.getNext(); o.listStar := pp.keywordPresent("-listStar"); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: TestTopology" ); Wr.PutText(stderr, " -inFile " ); Wr.PutText(stderr, " [ -listStar ]\n" ); Wr.PutText(stderr, "\n"); Process.Exit (1); END; END; RETURN o END GetOptions; BEGIN DoIt() END TestTopology. (**************************************************************************) (* *) (* Copyright (C) 1999 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/TesteElasticity.m3 MODULE TesteElasticity EXPORTS Main; IMPORT Stdio, Wr, Thread, LR3x3, LR3, Mis, LR4, Fmt, LR4x4; FROM Stdio IMPORT stderr; CONST A = LR3x3.T{ LR3.T{0.0d0, 1.0d0, 1.0d0}, LR3.T{1.0d0, 0.0d0, 1.0d0}, LR3.T{1.0d0, 1.0d0, 0.0d0} }; B = LR4x4.T{ LR4.T{0.0d0, 0.0d0, 0.0d0, 1.0d0}, LR4.T{0.0d0, 1.0d0, 1.0d0, 1.0d0}, LR4.T{1.0d0, 1.0d0, 0.0d0, 1.0d0}, LR4.T{1.0d0, 0.0d0, 1.0d0, 1.0d0} }; TYPE LR4x3 = ARRAY [0..3] OF LR3.T; LR3x4 = ARRAY [0..2] OF LR4.T; PROCEDURE Transpose_3x4(READONLY m: LR3x4): LR4x3 = (* Return the transpose of a matrix 3x4. *) VAR t : LR4x3; BEGIN t[0] := LR3.T{m[0,0], m[1,0], m[2,0]}; t[1] := LR3.T{m[0,1], m[1,1], m[2,1]}; t[2] := LR3.T{m[0,2], m[1,2], m[2,2]}; t[3] := LR3.T{m[0,3], m[1,3], m[2,3]}; RETURN t; END Transpose_3x4; PROCEDURE Transpose_4x3(READONLY m: LR4x3): LR3x4 = (* return the transpose of a matrix 3x3. *) VAR t : LR3x4; BEGIN t[0] := LR4.T{m[0,0], m[1,0], m[2,0], m[3,0]}; t[1] := LR4.T{m[0,1], m[1,1], m[2,1], m[3,1]}; t[2] := LR4.T{m[0,2], m[1,2], m[2,2], m[3,2]}; RETURN t; END Transpose_4x3; PROCEDURE Mul_4x3_3x3(READONLY a: LR4x3; READONLY b: LR3x3.T) : LR4x3 = (* Return the product of the matrix "a" 4x3 and matrix "b" 3x3. *) VAR c : LR4x3; BEGIN WITH a00 = a[0,0], a01 = a[0,1], a02 = a[0,2], a10 = a[1,0], a11 = a[1,1], a12 = a[1,2], a20 = a[2,0], a21 = a[2,1], a22 = a[2,2], a30 = a[3,0], a31 = a[3,1], a32 = a[3,2], b00 = b[0,0], b01 = b[0,1], b02 = b[0,2], b10 = b[1,0], b11 = b[1,1], b12 = b[1,2], b20 = b[2,0], b21 = b[2,1], b22 = b[2,2], c00 = a00 * b00 + a01 * b10 + a02 * b20, c01 = a00 * b01 + a01 * b11 + a02 * b21, c02 = a00 * b02 + a01 * b12 + a02 * b22, c10 = a10 * b00 + a11 * b10 + a12 * b20, c11 = a10 * b01 + a11 * b11 + a12 * b21, c12 = a10 * b02 + a11 * b12 + a12 * b22, c20 = a20 * b00 + a21 * b10 + a22 * b20, c21 = a20 * b01 + a21 * b11 + a22 * b21, c22 = a20 * b02 + a21 * b12 + a22 * b22, c30 = a30 * b00 + a31 * b10 + a32 * b20, c31 = a30 * b01 + a31 * b11 + a32 * b21, c32 = a30 * b02 + a31 * b12 + a32 * b22, c0 = LR3.T{c00,c01,c02}, c1 = LR3.T{c10,c11,c12}, c2 = LR3.T{c20,c21,c22}, c3 = LR3.T{c30,c31,c32} DO c[0] := c0; c[1] := c1; c[2] := c2; c[3] := c3; RETURN c; END END Mul_4x3_3x3; PROCEDURE Mul_3x4_4x3(READONLY a: LR3x4; READONLY b: LR4x3) : LR3x3.T = (* Return the product of the matrix "a" 3x4 and matrix "b" 4x3. *) BEGIN WITH a00 = a[0,0], a01 = a[0,1], a02 = a[0,2], a03 = a[0,3], a10 = a[1,0], a11 = a[1,1], a12 = a[1,2], a13 = a[1,3], a20 = a[2,0], a21 = a[2,1], a22 = a[2,2], a23 = a[2,3], b00 = b[0,0], b01 = b[0,1], b02 = b[0,2], b10 = b[1,0], b11 = b[1,1], b12 = b[1,2], b20 = b[2,0], b21 = b[2,1], b22 = b[2,2], b30 = b[3,0], b31 = b[3,1], b32 = b[3,2], c00 = a00 * b00 + a01 * b10 + a02 * b20 + a03 * b30, c01 = a00 * b01 + a01 * b11 + a02 * b21 + a03 * b31, c02 = a00 * b02 + a01 * b12 + a02 * b22 + a03 * b32, c10 = a10 * b00 + a11 * b10 + a12 * b20 + a13 * b30, c11 = a10 * b01 + a11 * b11 + a12 * b21 + a13 * b31, c12 = a10 * b02 + a11 * b12 + a12 * b22 + a13 * b32, c20 = a20 * b00 + a21 * b10 + a22 * b20 + a23 * b30, c21 = a20 * b01 + a21 * b11 + a22 * b21 + a23 * b31, c22 = a20 * b02 + a21 * b12 + a22 * b22 + a23 * b32, c0 = LR3.T{c00,c01,c02}, c1 = LR3.T{c10,c11,c12}, c2 = LR3.T{c20,c21,c22} DO RETURN LR3x3.T{c0,c1,c2}; END END Mul_3x4_4x3; PROCEDURE PrintMatrix_3x3(READONLY a: LR3x3.T ) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN FOR i := 0 TO 2 DO FOR j := 0 TO 2 DO Mis.WriteLong(stderr, a[i,j]); Wr.PutText(stderr, " "); END; Wr.PutText(stderr, "\n"); END; END PrintMatrix_3x3; PROCEDURE PrintMatrix_3x4(READONLY a: LR3x4 ) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN FOR i := 0 TO 2 DO FOR j := 0 TO 3 DO Mis.WriteLong(stderr, a[i,j]); Wr.PutText(stderr, " "); END; Wr.PutText(stderr, "\n"); END; END PrintMatrix_3x4; PROCEDURE PrintMatrix_4x3(READONLY a: LR4x3 ) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN FOR i := 0 TO 3 DO FOR j := 0 TO 2 DO Mis.WriteLong(stderr, a[i,j]); Wr.PutText(stderr, " "); END; Wr.PutText(stderr, "\n"); END; END PrintMatrix_4x3; PROCEDURE DoIt() = <* FATAL Wr.Failure, Thread.Alerted *> VAR B : LR4x3; BEGIN WITH b0 = LR3.T{10.0d0, 10.0d0, 10.0d0}, b1 = LR3.T{10.0d0, 10.0d0, 10.0d0}, b2 = LR3.T{10.0d0, 10.0d0, 10.0d0}, b3 = LR3.T{10.0d0, 10.0d0, 10.0d0} DO B[0] := b0; B[1] := b1; B[2] := b2; B[3] := b3; Wr.PutText(stderr, "\nMatrix A\n"); PrintMatrix_3x3(A); Wr.PutText(stderr, "\nMatrix B\n"); PrintMatrix_4x3(B); Wr.PutText(stderr, "\nMatrix A_1\n"); PrintMatrix_3x3(LR3x3.Inv(A)); Wr.PutText(stderr, "\nMatrix A* A_1\n"); PrintMatrix_3x3(LR3x3.Mul(A,LR3x3.Inv(A))); (* Wr.PutText(stderr, "\nMatrix B'\n"); PrintMatrix_3x4(Transpose_4x3(B)); Wr.PutText(stderr, "\nMatrix B''\n"); PrintMatrix_4x3(Transpose_3x4(Transpose_4x3(B))); Wr.PutText(stderr, "\nMatrix BxA\n"); PrintMatrix_4x3(Mul_4x3_3x3(B,A)); Wr.PutText(stderr, "\nMatrix B'xB\n"); PrintMatrix_3x3(Mul_3x4_4x3(Transpose_4x3(B),B)); *) Wr.PutText(stderr, "\nMatrix BxA_1\n"); PrintMatrix_4x3(Mul_4x3_3x3(B,LR3x3.Inv(A))); END END DoIt; BEGIN DoIt(); Wr.PutText(stderr, "volume :" & Fmt.LongReal(1.0d0/6.0d0*LR3x3.Det(A)) & "\n"); END TesteElasticity. (**************************************************************************) (* *) (* Copyright (C) 1999 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) (* Testes Matrix A 1.00 0.00 0.00 0.00 1.00 0.00 0.00 0.00 1.00 Matrix B 1.00 0.00 0.00 0.00 2.00 0.00 0.00 0.00 3.00 1.00 1.00 1.00 Matrix B' 1.00 0.00 0.00 1.00 0.00 2.00 0.00 1.00 0.00 0.00 3.00 1.00 Matrix B'' 1.00 0.00 0.00 0.00 2.00 0.00 0.00 0.00 3.00 1.00 1.00 1.00 Matrix BxA 1.00 0.00 0.00 0.00 2.00 0.00 0.00 0.00 3.00 1.00 1.00 1.00 Matrix B'xB 2.00 1.00 1.00 1.00 5.00 1.00 1.00 1.00 10.00 *)~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/TesteOpGeo.m3 (* Programa para testar os procedientos Geometricos no R4 Created by L. P. Lozada *) MODULE TesteOpGeo EXPORTS Main; IMPORT Triangulation, Fmt, Stdio, Wr, Thread, Process, ParseParams, LR4, Mis, Octf; FROM Stdio IMPORT stdout, stderr; FROM Triangulation IMPORT Vertex, Polyhedron, Org, OrgV, Node, PnegP, PposP, Pneg; FROM Octf IMPORT Srot, Fnext, Tors, Enext, Fnext_1, Clock, Enext_1; TYPE RowT = ARRAY [1..4] OF LONGREAL; FacetEdge = Triangulation.FacetEdge; Pair = Triangulation.Pair; TYPE Options = RECORD inFile: TEXT; (* Initial guess file name (minus ".top") *) END; <* UNUSED *> PROCEDURE PrtFnext(a: Pair) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(stdout, "a: "); Octf.PrintPair(stdout, a); Wr.PutText(stdout, " Fnext(a): "); Octf.PrintPair(stdout, Fnext(a)); Wr.PutText(stdout, "\n"); END PrtFnext; <* UNUSED *> PROCEDURE Poly(a: Pair) = <* FATAL Wr.Failure, Thread.Alerted *> VAR p : Node; BEGIN Octf.PrintPair(stdout, a, 5); Wr.PutText(stdout, " " ); p := Pneg(a); Wr.PutText(Stdio.stdout, "Pneg.num: " & Fmt.Pad(Fmt.Int(p.num),2) & "\n"); END Poly; PROCEDURE DoIt() = <* FATAL Thread.Alerted, Wr.Failure *> VAR iso : BOOLEAN; b,nb,vn,n : LR4.T; mvd, mel, n1, n2 : LONGREAL; d : CARDINAL; v : REF ARRAY OF LR4.T; BEGIN WITH o = GetOptions(), tc = Triangulation.Read(o.inFile), top = tc.top, comments = tc.comments, c = tc.c^ DO (* FOR j := 0 TO 5 DO WITH a = top.face[j].pa^, p1 = PnegP(a).num, p2 = PposP(a).num, t = top.region[p1], a = Tors(t), t1 = Clock(Enext_1(t)), a1 = Tors(t1), un = OrgV(a).num, vn = OrgV(Enext(a)).num, wn = OrgV(Enext_1(a)).num, xn = OrgV(Enext_1(a1)).num, tt = top.region[p2], aa = Tors(tt), tt1 = Clock(Enext_1(tt)), aa1 = Tors(tt1), u1n = OrgV(aa).num, v1n = OrgV(Enext(aa)).num, w1n = OrgV(Enext_1(aa)).num, x1n = OrgV(Enext_1(aa1)).num DO Wr.PutText(stdout, Fmt.Pad(Fmt.Int(un), 5) & " "); Wr.PutText(stdout, Fmt.Pad(Fmt.Int(vn), 5) & " "); Wr.PutText(stdout, Fmt.Pad(Fmt.Int(wn), 5) & " "); Wr.PutText(stdout, Fmt.Pad(Fmt.Int(xn), 5) & "\n"); Wr.PutText(stdout, Fmt.Pad(Fmt.Int(u1n), 5) & " "); Wr.PutText(stdout, Fmt.Pad(Fmt.Int(v1n), 5) & " "); Wr.PutText(stdout, Fmt.Pad(Fmt.Int(w1n), 5) & " "); Wr.PutText(stdout, Fmt.Pad(Fmt.Int(x1n), 5) & "\n"); Wr.PutText(stdout, "\n"); END; END; Wr.PutText(stdout, "\n"); FOR i := 0 TO top.NV-1 DO WITH poly1 = Triangulation.StarOfVertex(top.out[i],top) DO FOR i := 0 TO LAST(poly1^) DO Wr.PutText(Stdio.stdout, Fmt.Int(poly1[i][0].num) & " "); Wr.PutText(Stdio.stdout, Fmt.Int(poly1[i][1].num) & " "); Wr.PutText(Stdio.stdout, Fmt.Int(poly1[i][2].num) & " "); Wr.PutText(Stdio.stdout, Fmt.Int(poly1[i][3].num) & "\n"); END; END; Wr.PutText(stdout, "\n"); END; FOR i := 0 TO top.NV-1 DO WITH a = top.out[i] DO Wr.PutText(Stdio.stdout, " Org.num: " & Fmt.Int(Org(a).num) & " "); d := Triangulation.DegreeOfVertex(a); Wr.PutText(stdout, " Degree : " & Fmt.Int(d) & "\n"); d := Triangulation.NumberPolyOfStar(a,top); Wr.PutText(stdout, " Number of Poly on the star: " & Fmt.Int(d) & "\n"); Mis.WriteComments(stdout, "\nThe Vetor Normal is: "); vn := Triangulation.VertexNormal(a, c, top); Mis.WritePoint(vn); n2 := LR4.Norm(vn); Wr.PutText(Stdio.stdout, ", Their norm is : "); Wr.PutText(Stdio.stdout, Fmt.LongReal(n2, Fmt.Style.Fix, prec := 3) & "\n"); nb := Triangulation.NeighborBarycenter(a,c); Mis.WriteComments(stdout, "\nThe Neighbor Baricenter is: "); Mis.WritePoint(nb); Wr.PutText(stdout, "\n"); END; END; Wr.PutText(stdout, "\n"); Mis.WriteComments(stdout, "\nThe All Vertex Normal are: "); v := Triangulation.ComputeAllVertexNormals(top,c); FOR i := 0 TO top.NV-1 DO Mis.WritePoint(v[i]); n2 := LR4.Norm(v[i]); Wr.PutText(Stdio.stdout, ", Their norm is : "); Wr.PutText(Stdio.stdout, Fmt.LongReal(n2, Fmt.Style.Fix, prec := 3) & "\n"); END; Wr.PutText(stdout, "\n"); Mis.WriteComments(stdout, "\nThe All Edge Normal are: "); v := Triangulation.ComputeAllEdgeNormals(top,c); FOR i := 0 TO top.NE-1 DO Mis.WritePoint(v[i]); n2 := LR4.Norm(v[i]); Wr.PutText(Stdio.stdout, ", Their norm is : "); Wr.PutText(Stdio.stdout, Fmt.LongReal(n2, Fmt.Style.Fix, prec := 3) & "\n"); END; Wr.PutText(stdout, "\n"); Mis.WriteComments(stdout, "\nThe All Face Normal are: "); v := Triangulation.ComputeAllFaceNormals(top,c); FOR i := 0 TO top.NF-1 DO Mis.WritePoint(v[i]); n2 := LR4.Norm(v[i]); Wr.PutText(Stdio.stdout, ", Their norm is : "); Wr.PutText(Stdio.stdout, Fmt.LongReal(n2, Fmt.Style.Fix, prec := 3) & "\n"); END; Mis.WriteComments(stdout, "\nThe All Polyhedron Normal are: "); v := Triangulation.ComputeAllPolyhedronNormals(top,c); FOR i := 0 TO top.NP-1 DO Mis.WritePoint(v[i]); n2 := LR4.Norm(v[i]); Wr.PutText(Stdio.stdout, ", Their norm is : "); Wr.PutText(Stdio.stdout, Fmt.LongReal(n2, Fmt.Style.Fix, prec := 3) & "\n"); END; FOR i := 0 TO 0 DO Octf.EnumFacetEdges(top.facetedge[0], PrtFnext, FALSE); END; Mis.WriteComments(stdout, "\nTests of of geometric tools procedures " & "and the procedure Read\n" & "\n"); b := Triangulation.Barycenter(top,c); Mis.WriteComments(stdout, "\n" & "The Baricenter is: \n"); Wr.PutText(stdout, "ola\n"); *) Mis.WriteComments(stdout, "\nThe vertex coordenates\n" & "\n"); FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i] DO Mis.WritePoint(Stdio.stdout, c[v.num]); Wr.PutText(Stdio.stdout, "\n"); END; END; b := Triangulation.Barycenter(top,c); Mis.WriteComments(stdout, "\n" & "The Baricenter is: \n"); mvd := Triangulation.MeanVertexDistance(top,c); Mis.WriteComments(stdout, "\nThe Average distance of vertices is: " & Fmt.LongReal(mvd, Fmt.Style.Fix, prec := 4) & "\n"); (* mel := Triangulation.MeanEdgeLength(top,c); Mis.WriteComments(stdout, "\nThe Average length of edges is: " & Fmt.LongReal(mel, Fmt.Style.Fix, prec := 4) & "\n"); Triangulation.Displace(top,RowT{5.0d0,5.0d0,5.0d0,5.0d0},c); Mis.WriteComments(stdout, "\nThe vertex coordenates displace" & " 5.0d0,5.0d0,5.0d0,5.0d0\n"); FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i] DO Mis.WritePoint(Stdio.stdout, c[v.num]); Wr.PutText(Stdio.stdout, "\n"); END; END; mvd := Triangulation.MeanVertexDistance(top,c); Mis.WriteComments(stdout, "\nThe Average distance of vertices is: " & Fmt.LongReal(mvd, Fmt.Style.Fix, prec := 4) & "\n"); *) Triangulation.NormalizeVertexDistance(top,c); (* Mis.WriteComments(stdout, "\nThe Normalize Vertex Distance\n"); FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i] DO Mis.WritePoint(Stdio.stdout,c[v.num]); Wr.PutText(Stdio.stdout, "\n"); END; END; mvd := Triangulation.MeanVertexDistance(top,c); Mis.WriteComments(stdout, "\nThe Average distance of vertices is: " & Fmt.LongReal(mvd, Fmt.Style.Fix, prec := 4) & "\n"); Triangulation.Scale(top,10.0d0,c); Mis.WriteComments(stdout, "\nThe vertex coordenates scale 10.0d0\n" & "\n"); FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i] DO Mis.WritePoint(Stdio.stdout,c[v.num]); Wr.PutText(Stdio.stdout, "\n"); END; END; Triangulation.NormalizeVertexDistance(top,c); Mis.WriteComments(stdout, "\nThe Normalize Vertex Distance\n"); FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i] DO Mis.WritePoint(Stdio.stdout,c[v.num]); Wr.PutText(Stdio.stdout, "\n"); END; END; *) mvd := Triangulation.MeanVertexDistance(top,c); Mis.WriteComments(stdout, "\nThe Average distance of vertices is: " & Fmt.LongReal(mvd, Fmt.Style.Fix, prec := 4) & "\n"); b := Triangulation.Barycenter(top,c); Mis.WriteComments(stdout, "\n" & "The Baricenter is: \n"); (* Triangulation.NormalizeVertexDistance(top,c); mvd := Triangulation.MeanVertexDistance(top,c); Mis.WriteComments(stdout, "\nThe Average distance of vertices normalized is: " & Fmt.LongReal(mvd, Fmt.Style.Fix, prec := 4) & "\n"); Triangulation.NormalizeEdgeLengths(top,c); mel := Triangulation.MeanEdgeLength(top,c); Mis.WriteComments(stdout, "\nThe Average length of edges normalized is: " & Fmt.LongReal(mel, Fmt.Style.Fix, prec := 4) & "\n"); FOR i := 0 TO top.NE-1 DO WITH a = top.edge[i].pa^ DO a.facetedge.edge.exists := TRUE; d := Octf.DegreeRingFacets(a); Wr.PutText(Stdio.stdout, " Degree Ring Facet is: "); Wr.PutText(Stdio.stdout, Fmt.Int(d) & "\n"); n := Triangulation.EdgeNormal(a,c); Mis.WriteComments(stdout, "\nThe Edge Normal is: "); Mis.WritePoint(n); n1 := LR4.Norm(n); Wr.PutText(Stdio.stdout, ", Their Norma is: "); Wr.PutText(Stdio.stdout, Fmt.LongReal(n1, Fmt.Style.Fix, prec := 3) & "\n"); END; END; Mis.WriteComments(stdout, "\nThe Vetor Cross is: "); vn := Triangulation.VertexCross(a, c); Mis.WritePoint(vn); n1 := LR4.Norm(vn); Wr.PutText(Stdio.stdout, ", Their Norma is: "); Wr.PutText(Stdio.stdout, Fmt.LongReal(n1, Fmt.Style.Fix, prec := 3) & "\n"); Mis.WriteComments(stdout, "\nThe Vetor Normal is: "); vn := Triangulation.VertexNormal(a, c); Mis.WritePoint(vn); n2 := LR4.Norm(vn); Wr.PutText(Stdio.stdout, ", Their norm is : "); Wr.PutText(Stdio.stdout, Fmt.LongReal(n2, Fmt.Style.Fix, prec := 3) & "\n"); Mis.WriteComments(stdout, "\nThe All Vertex Normal are: "); v := Triangulation.ComputeAllVertexNormals(top,c); FOR i := 0 TO top.NV-1 DO WITH a = top.out[i] DO d := Triangulation.DegreeOfVertex(a); Mis.WriteComments(stdout, "\n" & "The Degree of Origin the pair Spin(ac1) is: " & Fmt.Int(d) & "\n"); END; END; FOR i := 0 TO top.NV-1 DO Mis.WritePoint(v[i]); n2 := LR4.Norm(vn); Wr.PutText(Stdio.stdout, ", Their norm is : "); Wr.PutText(Stdio.stdout, Fmt.LongReal(n2, Fmt.Style.Fix, prec := 3) & "\n"); END; END; END; Mis.WriteComments(stdout, "\nThe All Face Normal are: "); FOR i := 0 TO top.NF-1 DO WITH a = top.face[i].pa^ DO vn := Triangulation.FaceNormal(a,c); Mis.WritePoint(vn); n2 := LR4.Norm(vn); Wr.PutText(Stdio.stdout, ", Their norm is : "); Wr.PutText(Stdio.stdout, Fmt.LongReal(n2, Fmt.Style.Fix, prec := 3) & "\n"); END; END; END; iso := Triangulation.TriviallyIsomorphic(top, top); IF NOT iso THEN Mis.WriteComments(stdout, "Complexes are not isomorphic\n"); ELSE Mis.WriteComments(stdout, "Complexes are isomorphic\n"); END; Mis.WriteComments(stdout, "\nThe out register\n" & "\n"); FOR i := 0 TO top.NV-1 DO WITH v = top.out[i] DO Wr.PutText(stdout, " top.out[" & Fmt.Int(i) & "]:"); Octf.PrintPair(stdout, v,4); Wr.PutText(Stdio.stdout, "\n"); END; END; Mis.WriteComments(stdout, "\nThe region register\n" & "\n"); FOR i := 0 TO top.NP-1 DO WITH p = top.region[i] DO Wr.PutText(stdout," top.region[" & Fmt.Pad(Fmt.Int(i),2) & "]:"); Octf.PrintPair(stdout, p,4); Wr.PutText(Stdio.stdout, "\n"); END; END; Mis.WriteComments(stdout, "\nTests of Procedure Read\n"); Mis.WriteComments(stdout, comments); Wr.PutText(stdout, "Read.NV: " & Fmt.Int(top.NV) & "\n"); Wr.PutText(stdout, "Read.NE: " & Fmt.Int(top.NE) & "\n"); Wr.PutText(stdout, "Read.NF: " & Fmt.Int(top.NF) & "\n"); Wr.PutText(stdout, "Read.NP: " & Fmt.Int(top.NP) & "\n"); Wr.PutText(stdout, "Read.NFE: " & Fmt.Int(top.NFE) & "\n"); Wr.PutText(stdout, o.inFile & "\n"); Mis.WriteComments(stdout, "\nVertex data by Read\n" & "\n"); FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i] DO (* Wr.PutText(stdout, Fmt.Pad(Fmt.Int(v.num),2) & " "); IF v.exists THEN Wr.PutText(stdout, "T" & " "); ELSE Wr.PutText(stdout, "F" & " "); END; IF v.fixed THEN Wr.PutText(stdout, "T" & " "); ELSE Wr.PutText(stdout, "F" & " "); END; Mis.WritePoint(c[v.num]); Mis.WriteColor(v.color); Wr.PutText(stdout, " " & Fmt.Real(v.radius) & "\n"); Wr.PutText(stdout, "\n"); END; END; Mis.WriteComments(stdout, "\nEdge data by Read\n" & "\n"); FOR i := 0 TO top.NE-1 DO WITH e = top.edge[i] DO Wr.PutText(stdout, Fmt.Pad(Fmt.Int(e.num),2) & " "); Octf.PrintPair(stdout, e.pa^, 4); IF e.exists THEN Wr.PutText(stdout, " T" & " "); ELSE Wr.PutText(stdout, " F" & " "); END; IF e.spring THEN Wr.PutText(stdout, " T" & " "); ELSE Wr.PutText(stdout, " F" & " "); END; Mis.WriteColor(e.color); Wr.PutText(stdout, " " & Fmt.Real(e.radius) & "\n"); END; END; Mis.WriteComments(stdout, "\nFace data by Read\n" & "\n"); FOR i := 0 TO top.NF-1 DO WITH f = top.face[i] DO Wr.PutText(stdout, Fmt.Pad(Fmt.Int(f.num),2) & " "); IF f.exists THEN Wr.PutText(stdout, " T" & " "); ELSE Wr.PutText(stdout, " F" & " "); END; Mis.WriteColor(f.color); Wr.PutText(stdout, " "); Mis.WriteColor(f.transp); Wr.PutText(stdout, "\n"); END; END; Mis.WriteComments(stdout, "\nPolyhedron data by Read\n" & "\n" ); FOR i := 0 TO top.NP-1 DO WITH p = top.polyhedron[i] DO Wr.PutText(stdout, Fmt.Pad(Fmt.Int(p.num),2) & " "); IF p.exists THEN Wr.PutText(stdout, " T" & " "); ELSE Wr.PutText(stdout, " F" & " "); END; Mis.WriteColor(p.color); Wr.PutText(stdout, " "); Mis.WriteColor(p.transp); Wr.PutText(stdout, "\n"); END; END; Mis.WriteComments(stdout, "\nFacetEdge data by Read\n" & "\n"); FOR i := 0 TO top.NFE-1 DO WITH fe = NARROW(top.facetedge[i].facetedge, FacetEdge) DO Wr.PutText(stdout, Fmt.Pad(Fmt.Int(fe.num),4) & " "); Octf.PrintFacetEdge(stdout,fe,5); Wr.PutText(stdout, " "); VAR sa: Pair := top.facetedge[i]; BEGIN FOR j := 0 TO 3 DO WITH n = Org(sa) DO TYPECASE n OF | NULL => <* ASSERT FALSE *> | Vertex(v) => Wr.PutText(stdout, Fmt.Pad(Fmt.Int(v.num), 2) & "v "); | Polyhedron(p) => Wr.PutText(stdout, Fmt.Pad(Fmt.Int(p.num), 2) & "p "); ELSE <* ASSERT FALSE *> END; END; sa := Srot(sa); END; END; IF fe.exists THEN Wr.PutText(stdout, " T" & " "); ELSE Wr.PutText(stdout, " F" & " "); END; Wr.PutText(stdout, "\n"); END; END; Mis.WriteComments(stdout, "\nAnother informations\n" & "\n"); FOR i := 0 TO top.NFE-1 DO VAR sa: Pair := top.facetedge[i]; BEGIN FOR j := 0 TO 3 DO WITH n = Org(sa) DO TYPECASE n OF | NULL => <* ASSERT FALSE *> | Vertex(v) => Wr.PutText(stdout, " top.out[" & Fmt.Int(v.num) & "]:"); Octf.PrintPair(stdout, top.out[v.num], 4); | Polyhedron(p) => Wr.PutText(stdout," top.region[" & Fmt.Pad(Fmt.Int(p.num),2) & "]:"); Octf.PrintPair(stdout, top.region[p.num], 4); ELSE <* ASSERT FALSE *> END; END; sa := Srot(sa); END; Wr.PutText(stdout, "\n"); END; END; FOR i := 0 TO top.NP-1 DO Wr.PutText(Stdio.stdout, "Polyhedron: " & Fmt.Pad(Fmt.Int(i),2) & "==>"); WITH v = top.region[i], a = Tors(v) DO WITH ae = Enext(a), aee = Enext(ae), aff = Fnext_1(a), k = OrgV(a).num, l = OrgV(ae).num, m = OrgV(aee).num, n = OrgV(Enext_1(aff)).num DO <* ASSERT Pneg(a).num = i *> <* ASSERT Pneg(Clock(aff)) = Pneg(a) *> Wr.PutText(stdout, Fmt.Pad(Fmt.Int(k), 5) & " "); Wr.PutText(stdout, Fmt.Pad(Fmt.Int(l), 5) & " "); Wr.PutText(stdout, Fmt.Pad(Fmt.Int(m), 5) & " "); Wr.PutText(stdout, Fmt.Pad(Fmt.Int(n), 5) & "\n"); END; END; END; FOR i := 0 TO top.NP-1 DO WITH p = top.polyhedron[i], p1 = p.vertex[0].num, p2 = p.vertex[1].num, p3 = p.vertex[2].num, p4 = p.vertex[3].num DO Wr.PutText(stdout, Fmt.Pad(Fmt.Int(p1), 2) & " "); Wr.PutText(stdout, Fmt.Pad(Fmt.Int(p2), 2) & " "); Wr.PutText(stdout, Fmt.Pad(Fmt.Int(p3), 2) & " "); Wr.PutText(stdout, Fmt.Pad(Fmt.Int(p4), 2) & "\n"); END; END; Mis.WriteComments(stdout, "\nVertex data by Read\n" & "\n"); FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i] DO Mis.WritePoint(c[v.num]); Wr.PutText(stdout, "\n"); END; END; END; *) END DoIt; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFile"); o.inFile := pp.getNext(); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: Read" ); Wr.PutText(stderr, " -inFile " ); Wr.PutText(stderr, "\n"); Process.Exit (1); END; END; RETURN o END GetOptions; BEGIN DoIt() END TesteOpGeo. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/TestePolyTopology.m3 MODULE TestePolyTopology EXPORTS Main; IMPORT Triangulation, Stdio, Wr, Thread, Process, ParseParams, Fmt, Mis; FROM Stdio IMPORT stderr; FROM Triangulation IMPORT MakePolyhedronTopology, Pneg, Org, OrgV; TYPE Options = RECORD inFile: TEXT; END; PROCEDURE DoIt() = <* FATAL Wr.Failure, Thread.Alerted *> VAR ov,oe,of : REF ARRAY OF INTEGER; BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToMa(o.inFile), top = tc.top DO FOR i := 0 TO top.NP-1 DO WITH a = top.region[i], tp = MakePolyhedronTopology(a), pn = Org(a) DO Wr.PutText(stderr, "Polyhedron: " & Fmt.Int(i) & "\n"); Wr.PutText(stderr, " nv : " & Fmt.Int(tp.NV) & "\n"); Wr.PutText(stderr, " ne : " & Fmt.Int(tp.NE) & "\n"); Wr.PutText(stderr, " nf : " & Fmt.Int(tp.NF) & "\n"); <* ASSERT tp.NV-tp.NE+tp.NF=2 *> Wr.PutText(stderr, " Vertices:\n"); Wr.PutText(stderr, " "); ov := NEW(REF ARRAY OF INTEGER, tp.NV); FOR j := 0 TO tp.NV-1 DO WITH ver = tp.vRef[j] DO <* ASSERT Pneg(tp.vRef[j]) = pn *> ov[j] := OrgV(ver).num; END END; Mis.InsertionSort(tp.NV-1,ov); FOR j := 0 TO tp.NV-1 DO Wr.PutText(stderr, Fmt.Pad(Fmt.Int(ov[j]),2) & " "); END; Wr.PutText(stderr, "\n"); oe := NEW(REF ARRAY OF INTEGER, tp.NE); FOR j := 0 TO tp.NE-1 DO WITH eer = tp.eRef[j] DO <* ASSERT Pneg(tp.eRef[j]) = pn *> oe[j] := eer.facetedge.edge.num; END END; Mis.InsertionSort(tp.NE-1,oe); Wr.PutText(stderr, " Edges:\n"); Wr.PutText(stderr, " "); FOR j := 0 TO tp.NE-1 DO IF j = 24 THEN Wr.PutText(stderr, "\n" & " ") END; Wr.PutText(stderr, Fmt.Pad(Fmt.Int(oe[j]),2) & " "); END; Wr.PutText(stderr, "\n"); of := NEW(REF ARRAY OF INTEGER, tp.NF); FOR j := 0 TO tp.NF-1 DO WITH fer = tp.fRef[j] DO <* ASSERT Pneg(tp.fRef[j]) = pn *> of[j] := fer.facetedge.face.num; END END; Mis.InsertionSort(tp.NF-1,of); Wr.PutText(stderr, " Faces:\n"); Wr.PutText(stderr, " "); FOR j := 0 TO tp.NF-1 DO Wr.PutText(stderr, Fmt.Pad(Fmt.Int(of[j]),2) & " "); END; Wr.PutText(stderr, "\n"); END END END; END DoIt; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFile"); o.inFile := pp.getNext(); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: Teste" ); Wr.PutText(stderr, " -inFile " ); Wr.PutText(stderr, "\n"); Process.Exit (1); END; END; RETURN o END GetOptions; BEGIN DoIt() END TestePolyTopology. (**************************************************************************) (* *) (* Copyright (C) 2001 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/TriangToGeom.m3 MODULE TriangToGeom EXPORTS Main; (* Writes an arbitrary topology (triangulation or not) in the OOGL formats "skel" (collections of points and polylines) or "off" (collections of planar polygons with possibly shared vertices. If "all" is present, then writes all faces, else writes only faces with the attribute "exists=TRUE". Revisions: 08-07-2000: Added the silhouette faces. 21-07-2000: More color and opacity index for the silhouette faces. 08-10-2000: Standarized the WriteFace procedures equal to the TriangToX3D module, such don't more use the OrgV().num information for compute the extremum vertices of the face. *) IMPORT Triangulation, ParseParams, Process, Wr, Thread, OSError, FileWr, Mis, Fmt, Tridimensional, Text, LR4, LR4Extras, R3, Octf; FROM Stdio IMPORT stderr; FROM Triangulation IMPORT Topology, Pair, TetraNegPosVertices, OrgV; FROM Octf IMPORT Enext; TYPE Format = {Skel, Off}; Quad = RECORD u, v, w, x: CARDINAL END; Options = RECORD inFileTp : TEXT; inFileSt3 : TEXT; outFile : TEXT; all : BOOLEAN; format : Format; formatName : TEXT; silhouette: BOOLEAN; (*TRUE draws the silhouette faces *) color: R3.T; (*attributes of color and opacity for silhouette *) opacity: REAL; (*faces,Transparent (opacity=1) Opaque (opacity=0)*) END; PROCEDURE Sign(d: LONGREAL) : BOOLEAN = (* Return TRUE iff the longreal value is positive, FALSE c.c. *) BEGIN <* ASSERT d # 0.0d0 *> IF d < 0.0d0 THEN RETURN FALSE ELSE RETURN TRUE END; END Sign; PROCEDURE DoIt() = BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToMa(o.inFileTp), rc3 = Tridimensional.ReadState3D(o.inFileSt3), top = tc.top, c3 = rc3^ DO IF o.format = Format.Skel THEN WriteSkelFile(top, c3, o); ELSIF o.format = Format.Off THEN WriteOffFile(top, c3, o); END END END DoIt; PROCEDURE WriteSkelFile( READONLY top: Topology; READONLY c3 : Tridimensional.Coords3D; READONLY o : Options; ) = <* FATAL Wr.Failure, Thread.Alerted, OSError.E *> BEGIN WITH wr = FileWr.Open(o.outFile & ".skel") DO Wr.PutText(wr, "appearance {shading csmooth linewidth 1}\n"); Wr.PutText(wr, "nSKEL 3\n"); WriteSkel(wr, top, c3, o); Wr.Close(wr) END END WriteSkelFile; PROCEDURE WriteOffFile( READONLY top: Topology; READONLY c3 : Tridimensional.Coords3D; READONLY o : Options; ) = <* FATAL Wr.Failure, Thread.Alerted, OSError.E *> BEGIN WITH wr = FileWr.Open(o.outFile & ".off") DO Wr.PutText(wr, "appearance {shading csmooth linewidth 1}\n"); Wr.PutText(wr, "OFF\n"); WriteOff(wr, top, c3, o); Wr.Close(wr) END END WriteOffFile; PROCEDURE WriteSkel( wr: Wr.T; READONLY top: Topology; READONLY c3 : Tridimensional.Coords3D; READONLY o : Options; ) = <* FATAL Wr.Failure, Thread.Alerted *> PROCEDURE FindOriR3(q: Quad) : LONGREAL = (* For each tetrahedron with extremus vertices numbers u,v,w,x compute us its orientation in R^{3} through the 4x4 determinant: _ _ | c3[q.u][0] c3[q.u][1] c3[q.u][2] 1.0d0 | B = | c3[q.v][0] c3[q.v][1] c3[q.v][2] 1.0d0 | | c3[q.w][0] c3[q.w][1] c3[q.w][2] 1.0d0 | | c3[q.x][0] c3[q.x][1] c3[q.x][2] 1.0d0 | - - *) BEGIN WITH a = LR4.T{c3[q.u][0], c3[q.u][1], c3[q.u][2], 1.0d0}, b = LR4.T{c3[q.v][0], c3[q.v][1], c3[q.v][2], 1.0d0}, c = LR4.T{c3[q.w][0], c3[q.w][1], c3[q.w][2], 1.0d0}, d = LR4.T{c3[q.x][0], c3[q.x][1], c3[q.x][2], 1.0d0} DO RETURN LR4Extras.Det(a,b,c,d); END END FindOriR3; PROCEDURE SilhouetteFaces(a: Pair) : BOOLEAN = (* Return TRUE iff the face associated to the pair "a" is a silhouette face, FALSE c.c. *) BEGIN WITH t = TetraNegPosVertices(a), un = t[0].num, vn = t[1].num, wn = t[2].num, xn = t[3].num, yn = t[4].num, t1 = Quad{un,vn,wn,xn}, t2 = Quad{un,vn,wn,yn}, d1 = FindOriR3(t1), d2 = FindOriR3(t2) DO IF (Sign(d1) AND Sign(d2)) OR ((NOT Sign(d1)) AND (NOT Sign(d2))) THEN RETURN TRUE ELSE RETURN FALSE END END END SilhouetteFaces; PROCEDURE WriteSkelFace( READONLY n : CARDINAL; READONLY f : Triangulation.Face; ) = (* This procedure writes a n-gon face *) VAR g : REF ARRAY OF INTEGER; a : Pair; BEGIN WITH vd = Mis.NumDigits(top.NV-1) DO g := NEW(REF ARRAY OF INTEGER, n); Wr.PutText(wr, Fmt.Int(n+1) & " "); a := f.pa; FOR i := 0 TO n-1 DO g[i] := OrgV(a).num; Wr.PutText(wr, Fmt.Pad(Fmt.Int(g[i]), vd) & " "); a := Enext(a); END; Wr.PutText(wr, Fmt.Pad(Fmt.Int(g[0]), vd) & " "); Wr.PutText(wr, " 0.00 0.00 0.00 "); (* color *) Wr.PutText(wr, " 1"); (* Index of opacity *) Wr.PutText(wr, "\n"); Wr.Flush(wr); END; END WriteSkelFace; VAR m: CARDINAL := 0; (* number of existing faces *) BEGIN FOR i := 0 TO top.NF-1 DO IF top.face[i].exists THEN INC(m); END; END; IF o.silhouette THEN FOR i := 0 TO top.NF-1 DO WITH f = top.face[i], a = f.pa DO IF SilhouetteFaces(a) AND (NOT f.exists) THEN INC(m); END; END END END; IF o.all THEN Wr.PutText(wr, Fmt.Int(top.NV) & " " & Fmt.Int(top.NF) & "\n"); Wr.PutText(wr, "\n"); ELSIF NOT o.silhouette THEN Wr.PutText(wr, Fmt.Int(top.NV) & " " & Fmt.Int(m) & "\n"); Wr.PutText(wr, "\n"); ELSIF o.silhouette THEN Wr.PutText(wr, Fmt.Int(top.NV) & " " & Fmt.Int(m) & "\n"); Wr.PutText(wr, "\n"); END; FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i] DO Mis.WritePoint3D(wr,c3[v.num]); Wr.PutText(wr, "\n"); END END; Wr.PutText(wr, "\n"); FOR i := 0 TO top.NF-1 DO WITH f = top.face[i] DO IF o.all OR top.face[i].exists THEN WriteSkelFace(NUMBER(f.vertex^),f); END END END; IF o.silhouette THEN FOR i := 0 TO top.NF-1 DO WITH f = top.face[i], a = f.pa DO IF SilhouetteFaces(a) AND (NOT f.exists) THEN WriteSkelFace(Octf.DegreeEdgeRing(a),f); END END END END; Wr.Close(wr); END WriteSkel; PROCEDURE WriteOff( wr: Wr.T; READONLY top: Topology; READONLY c3: Tridimensional.Coords3D; READONLY o : Options; ) = <* FATAL Wr.Failure, Thread.Alerted *> PROCEDURE FindOriR3(q: Quad) : LONGREAL = (* For each tetrahedron with extremus vertices numbers u,v,w,x compute us its orientation in R^{3} through the 4x4 determinant: _ _ | c3[q.u][0] c3[q.u][1] c3[q.u][2] 1.0d0 | B = | c3[q.v][0] c3[q.v][1] c3[q.v][2] 1.0d0 | | c3[q.w][0] c3[q.w][1] c3[q.w][2] 1.0d0 | | c3[q.x][0] c3[q.x][1] c3[q.x][2] 1.0d0 | - - *) BEGIN WITH a = LR4.T{c3[q.u][0], c3[q.u][1], c3[q.u][2], 1.0d0}, b = LR4.T{c3[q.v][0], c3[q.v][1], c3[q.v][2], 1.0d0}, c = LR4.T{c3[q.w][0], c3[q.w][1], c3[q.w][2], 1.0d0}, d = LR4.T{c3[q.x][0], c3[q.x][1], c3[q.x][2], 1.0d0} DO RETURN LR4Extras.Det(a,b,c,d); END END FindOriR3; PROCEDURE SilhouetteFaces(a: Pair) : BOOLEAN = (* Return TRUE iff the face associated to the pair "a" is a silhouette face, FALSE c.c. *) BEGIN WITH t = TetraNegPosVertices(a), un = t[0].num, vn = t[1].num, wn = t[2].num, xn = t[3].num, yn = t[4].num, t1 = Quad{un,vn,wn,xn}, t2 = Quad{un,vn,wn,yn}, d1 = FindOriR3(t1), d2 = FindOriR3(t2) DO IF (Sign(d1) AND Sign(d2)) OR ((NOT Sign(d1)) AND (NOT Sign(d2))) THEN RETURN TRUE ELSE RETURN FALSE END END END SilhouetteFaces; PROCEDURE WriteOffFace( READONLY n : CARDINAL; READONLY f : Triangulation.Face; diffuse : R3.T; transp : REAL; ) = (* This procedure writes a "n"-gon face, associated to the pair face-edge "a" with color "diffuse" and transparency "opacity" *) VAR g : REF ARRAY OF INTEGER; BEGIN WITH vd = Mis.NumDigits(top.NV-1) DO g := NEW(REF ARRAY OF INTEGER, n); Wr.PutText(wr, Fmt.Int(n) & " "); FOR i := 0 TO n-1 DO g[i] := f.vertex[i].num; Wr.PutText(wr, Fmt.Pad(Fmt.Int(g[i]), vd) & " "); END; Mis.WriteColor(wr,diffuse); Wr.PutText(wr, " "); Mis.WriteIntensity(wr,transp); Wr.PutText(wr, "\n"); Wr.Flush(wr); END; END WriteOffFace; VAR m: CARDINAL := 0; (* number of existing faces *) BEGIN FOR i := 0 TO top.NF-1 DO IF top.face[i].exists THEN INC(m); END; END; IF o.silhouette THEN FOR i := 0 TO top.NF-1 DO WITH f = top.face[i], a = f.pa DO IF SilhouetteFaces(a) AND (NOT f.exists) THEN INC(m); END; END END END; IF o.all THEN Wr.PutText(wr, Fmt.Int(top.NV) & " " & Fmt.Int(top.NF) & " " & Fmt.Int(top.NE) & "\n"); Wr.PutText(wr, "\n"); ELSIF NOT o.silhouette THEN Wr.PutText(wr, Fmt.Int(top.NV) & " " & Fmt.Int(m) & " " & Fmt.Int(top.NE) & "\n"); Wr.PutText(wr, "\n"); ELSIF o.silhouette THEN Wr.PutText(wr, Fmt.Int(top.NV) & " " & Fmt.Int(m) & " " & Fmt.Int(top.NE) & "\n"); Wr.PutText(wr, "\n"); END; FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i] DO Mis.WritePoint3D(wr,c3[v.num]); Wr.PutText(wr,"\n"); END END; Wr.PutText(wr, "\n"); FOR i := 0 TO top.NF-1 DO WITH f = top.face[i], fc = f.color, t3 = f.transp, tp = (t3[0] + t3[1] + t3[2]) / 3.0 DO IF o.all OR top.face[i].exists THEN WriteOffFace(NUMBER(f.vertex^),f,fc,tp); END END END; IF o.silhouette THEN FOR i := 0 TO top.NF-1 DO WITH f = top.face[i], a = f.pa, c = o.color, t = o.opacity DO IF SilhouetteFaces(a) AND (NOT f.exists) THEN WriteOffFace(NUMBER(f.vertex^),f,c,t); END END END END; Wr.Close(wr); END WriteOff; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFileTp"); o.inFileTp := pp.getNext(); pp.getKeyword("-inFileSt3"); o.inFileSt3 := pp.getNext(); IF pp.keywordPresent("-outFile") THEN o.outFile := pp.getNext() ELSE o.outFile := o.inFileTp END; o.all := pp.keywordPresent("-all"); pp.getKeyword("-format"); o.formatName := pp.getNext(); IF Text.Equal(o.formatName, "skel") THEN o.format := Format.Skel ELSIF Text.Equal(o.formatName, "off") THEN o.format := Format.Off ELSE pp.error("Bad format \"" & pp.getNext() & "\"\n") END; IF pp.keywordPresent("-silhouette") THEN o.silhouette := TRUE; IF pp.keywordPresent("-color") THEN FOR j := 0 TO 2 DO o.color[j] := pp.getNextReal(0.0,1.0); END; ELSE o.color := R3.T{1.0,1.0,0.75}; END; IF pp.keywordPresent("-opacity") THEN o.opacity := pp.getNextReal(0.0,1.0); ELSE o.opacity := 0.85; END END; pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr,"Usage: TriangToGeom \\\n"); Wr.PutText(stderr," -inFileTp -inFileSt3 \\\n"); Wr.PutText(stderr," [-outFile ] [-all] \\\n"); Wr.PutText(stderr," -format { skel | off }\n"); Wr.PutText(stderr," [ -silhouette [ -color | -opacity ] ]\n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt(); END TriangToGeom. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/TriangToPov.m3 MODULE TriangToPov EXPORTS Main; (* This program contain procedures to write configurations "3D" in POVray format (".inc"). See the copyright and authorship futher down. *) IMPORT Triangulation, FileWr, ParseParams, OSError, Process, Wr, Thread, Stdio, Tridimensional, R3, LR3, Fmt, Scan, Lex, FloatMode, Text; FROM Octf IMPORT Fnext, Enext, Clock; FROM Triangulation IMPORT Topology, Vertex, Edge, Face, Pair, OrgV, FaceIsBorder; FROM Stdio IMPORT stderr; FROM Tridimensional IMPORT Coords3D, EdgeWindingNumber, FaceIsSilhouette; FROM Pov IMPORT WritePOVCylinder, WritePOVSphere, WritePOVTriangle, WritePOVTriangleTex; TYPE BOOL = BOOLEAN; NAT = CARDINAL; FaceNums = ARRAY OF NAT; TYPE Options = RECORD inFileTp: TEXT; inFileSt3: TEXT; outFile: TEXT; all: BOOL; (* TRUE draws even non-existing triangles and edges. *) faces: REF FaceNums; (* List of faces to show (NIL = all). *) styles: REF StyleSpecs; (* Styles for various classes of elements. *) debug: BOOL; (* Print style info for all elements. *) END; TYPE ElemDim = [0..4]; (* Element dimension; "4" means "ANY". *) CONST AnyDim = 4; TYPE ElemType = BITS 32 FOR RECORD dim: BITS 8 FOR ElemDim; (* Dimension of element. *) momDim: BITS 8 FOR ElemDim; (* Dimension of mother element. *) bdr: BITS 1 FOR BOOL := FALSE; (* Element is part of the map's border. *) sil: BITS 1 FOR BOOL := FALSE; (* Element is part of silhouette surface. *) mwr: BITS 1 FOR BOOL := FALSE; (* Element is miswrapped vertex. *) mwn: BITS 1 FOR BOOL := FALSE; (* Element is part of miswound edge. *) END; ElemTypes = ARRAY OF ElemType; AllElementTypes = RECORD vType: REF ElemTypes; (* Indexed by vertex number. *) eType: REF ElemTypes; (* Indexed by edge number. *) fType: REF ElemTypes; (* Indexed by face number. *) pType: REF ElemTypes; (* Indexed by cell number. *) END; TYPE ElemStyle = RECORD (* Style attributes for faces. *) textured: BOOL; (* TRUE for textured face, FALSE for solid color. *) radius: REAL; (* Radius (for edges or vertices). *) color: R3.T; (* Color of element. *) transp: REAL; (* Transp (1=clear, 0=opaque). *) filtering: BOOL; (* TRUE for "filter" transparency, FALSE for "transmit". *) END; TYPE StyleSpec = RECORD (* Style specs for elements of a certain type *) typ: ElemType; (* Type of elements to which this style applies. *) sty: ElemStyle; (* Style to use for elements of this dimension and type. *) END; StyleSpecs = ARRAY OF StyleSpec; (* Style specs in decr. priority order. *) (* Let "e" be an element of the model, of dimension "e.dim" and belonging to a map element of dimension "e.momDim". To show this element, the "StyleSpecs" list is searched until an entry "t" has "t.typ.dim = e.dim", "t.typ.momDim = e.momDim", "t.typ.xxx <= e.xxx" for every other boolean attribute ("bdr", "sil", "mwn", and "mwr"). Thus specs for non-border, non-silhouette elements must follow those of border and/or silhouette ones. In StyleSpec records, the following conventions hold: positive color, transparency, and radius values are absolute, while negative ones (after change of sign) multiply the original values specified in the map files. Thus color = (1,1,1) means set color to white, while (-1,-1,-1) means keep the original color. In particulas, a face can be made invisible by specifying color = (1,1,1) and transp = 1; and edges and vertices can be made invisible by specifying radius = 0. *) CONST White = R3.T{1.0, 1.0, 1.0}; Black = R3.T{0.0, 0.0, 0.0}; Clear = 1.0; Opaque = 0.0; OriginalColor = R3.T{-1.0, -1.0, -1.0}; OriginalTransp = -1.0; OriginalRadius = -1.0; CONST OriginalElemStyle = ElemStyle{ textured := FALSE, radius := OriginalRadius, color := OriginalColor, transp := OriginalTransp, filtering := FALSE }; PROCEDURE DoIt() = BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToMa(o.inFileTp), rc3 = Tridimensional.ReadState3D(o.inFileSt3), top = tc.top, c3 = rc3^, atp = ComputeAllElementTypes(top, c3) DO IF o.faces # NIL THEN RemoveElements(tc.top, o.faces^) END; WritePOVFile(top, c3, atp, o); END END DoIt; PROCEDURE ComputeAllElementTypes( READONLY top: Topology; READONLY c3: Coords3D; ): AllElementTypes = CONST VVType = ElemType{dim := 0, momDim := 0}; VEType = ElemType{dim := 0, momDim := 1}; VFType = ElemType{dim := 0, momDim := 2}; VPType = ElemType{dim := 0, momDim := 3}; EEType = ElemType{dim := 1, momDim := 1}; EPType = ElemType{dim := 1, momDim := 3}; FFType = ElemType{dim := 2, momDim := 2}; FPType = ElemType{dim := 2, momDim := 3}; PPType = ElemType{dim := 3, momDim := 3}; VAR atp: AllElementTypes; BEGIN (* Initialize everybody as PType *) atp.vType := NEW(REF ElemTypes, top.NV); atp.eType := NEW(REF ElemTypes, top.NE); atp.fType := NEW(REF ElemTypes, top.NF); atp.pType := NEW(REF ElemTypes, top.NP); (* Mark vertices according to container in the original map, and wrapping number: *) WITH vtp = atp.vType^ DO FOR i := 0 TO LAST(vtp) DO WITH vi = OrgV(top.out[i]) DO IF Text.Equal(vi.label, "VV") THEN vtp[i] := VVType ELSIF Text.Equal(vi.label, "VE") THEN vtp[i] := VEType ELSIF Text.Equal(vi.label, "VF") THEN vtp[i] := VFType ELSIF Text.Equal(vi.label, "VP") THEN vtp[i] := VPType ELSE <* ASSERT FALSE *> END; IF ABS(VertexWrappingNumber(top.out[i], c3)) # 1 THEN vtp[i].mwr := TRUE END; END END END; (* Mark edges of original map, and m-fold edges: *) WITH etp = atp.eType^ DO FOR i := 0 TO LAST(etp) DO WITH ei = top.edge[i] DO IF ei.root # -1 THEN etp[i] := EEType ELSE etp[i] := EPType (* For now *) END; IF ABS(EdgeWindingNumber(top.edge[i].pa, c3)) # 1 THEN etp[i].mwn := TRUE END; END END END; (* Mark faces of the original map, border faces, and silhouette faces: *) WITH ftp = atp.fType^ DO FOR i := 0 TO LAST(ftp) DO WITH fi = top.face[i], ftpi = ftp[i] DO IF fi.root # -1 THEN ftpi := FFType ELSE ftpi := FPType END; IF FaceIsBorder(fi.pa) THEN ftpi.bdr := TRUE END; IF FaceIsSilhouette(fi.pa, c3) THEN ftpi.sil := TRUE END; END END END; (* Mark cells of original map (all of them): *) WITH ptp = atp.pType^ DO FOR i := 0 TO LAST(ptp) DO ptp[i] := PPType END END; (* Propagate attributes from faces to edges, and fix edge "momDim"s: *) WITH ftp = atp.fType^, etp = atp.eType^ DO FOR i := 0 TO LAST(ftp) DO WITH fi = top.face[i], ftpi = ftp[i] DO <* ASSERT ftpi.dim = 2 *> <* ASSERT ftpi.momDim >= 2 *> (* Enumerate bounding edges: *) VAR a := fi.pa; b := a; BEGIN REPEAT WITH eb = b.facetedge.edge, ebtp = etp[eb.num] DO (* Fix edge's "momDim": *) IF ebtp.momDim = 3 AND ftpi.momDim = 2 THEN (* Edge's mom was not an edge, so it must be the face's mom: *) ebtp.momDim := 2 END; (* Propagate border attributes: *) ebtp.bdr := ebtp.bdr OR ftpi.bdr; (* Propagate silhouette attribute: *) ebtp.sil := ebtp.sil OR ftpi.sil; <* ASSERT ebtp.momDim <= ftpi.momDim *> END; b := Enext(b) UNTIL b = a; END END END END; (* Propagate attributes from edge to vertex ("momDim"s should be OK): *) WITH etp = atp.eType^, vtp = atp.vType^ DO FOR i := 0 TO LAST(etp) DO WITH ei = top.edge[i], etpi = etp[i] DO <* ASSERT etpi.dim = 1 *> <* ASSERT etpi.momDim >= 1 *> (* Enumerate endpoints: *) WITH v0 = OrgV(ei.pa), v1 = OrgV(Clock(ei.pa)), v = ARRAY [0..1] OF Vertex{v0, v1} DO FOR i := 0 TO 1 DO WITH vi = v[i], vitp = vtp[vi.num] DO <* ASSERT vitp.momDim <= etpi.momDim *> (* Propagate border, silhouette, miswound attributes: *) vitp.bdr := vitp.bdr OR etpi.bdr; vitp.sil := vitp.sil OR etpi.sil; vitp.mwn := vitp.mwn OR etpi.mwn; END END END END END END; RETURN atp END ComputeAllElementTypes; PROCEDURE RemoveElements(READONLY top: Topology; READONLY faces: FaceNums) = (* Marks all vertices, edges, and faces of "top" as non-existing, except those that are incident to one of the specified faces of the original map. Assumes that cells are invisible in any case. *) BEGIN (* Remove all edges and vertices: *) FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i] DO v.exists := FALSE END; END; FOR i := 0 TO top.NE-1 DO WITH e = top.edge[i] DO e.exists := FALSE END; END; (* Put back edges and vertices of interesting faces, remove non-interesting ones: *) FOR i := 0 TO top.NF-1 DO WITH f = top.face[i] DO IF f.exists THEN IF FaceIsSelected(f, faces) THEN VAR a: Pair := f.pa; VAR b: Pair := a; BEGIN REPEAT OrgV(b).exists := TRUE; b.facetedge.edge.exists := TRUE; b := Enext(b) UNTIL b = a; END ELSE f.exists := FALSE END END END END; END RemoveElements; PROCEDURE FaceIsSelected(f: Face; READONLY faces: FaceNums): BOOL = (* Returns TRUE if the face "f" is part of one of the specified faces of the original map. *) BEGIN IF f.root = -1 THEN RETURN FALSE ELSE FOR k := 0 TO LAST(faces) DO IF f.root = faces[k] THEN RETURN TRUE END END; RETURN FALSE END; END FaceIsSelected; PROCEDURE WritePOVFile( READONLY top: Topology; READONLY c3: Coords3D; READONLY atp: AllElementTypes; READONLY o: Options; ) = <* FATAL Wr.Failure, Thread.Alerted, OSError.E *> BEGIN WITH name = o.outFile & ".inc", wr = FileWr.Open(name) DO Wr.PutText(stderr, "writing " & name & "\n"); Wr.PutText(wr, "// Include File: <" & o.outFile & ".inc>\n"); WritePOV(wr, top, c3, atp, o); Wr.Close(wr) END END WritePOVFile; PROCEDURE WritePOV( wr: Wr.T; READONLY top: Topology; READONLY c3: Coords3D; READONLY atp: AllElementTypes; READONLY o: Options; ) = <* FATAL Wr.Failure, Thread.Alerted *> PROCEDURE WriteElemComment(txt: TEXT; num: INTEGER) = BEGIN Wr.PutText(wr, " // "); Wr.PutText(wr, txt); Wr.PutText(wr, " "); Wr.PutText(wr, Fmt.Int(num)); Wr.PutText(wr, "\n"); END WriteElemComment; PROCEDURE WriteFace(f: Face; READONLY fs: ElemStyle) = (* Writes the POV representation of "f". *) PROCEDURE WriteTriangle(a: Pair) = (* Writes the POV representation of "a.face", which is assumed to be a triangle. *) BEGIN WITH b = Enext(a), c = Enext(b), un = OrgV(a).num, vn = OrgV(b).num, wn = OrgV(c).num DO IF fs.textured THEN WITH txName = "face_texture_" & Fmt.Pad(Fmt.Int(a.facetedge.face.num),6,'0') DO WritePOVTriangleTex(wr, c3[un], c3[vn], c3[wn], txName) END ELSE WritePOVTriangle(wr,c3[un],c3[vn],c3[wn], fs.color, fs.transp, fs.filtering); END END END WriteTriangle; PROCEDURE WritePolygon(a: Pair) = (* Writes the POV representation of "a.face", which is assumed to be a non-planar N-gon. *) VAR c: Pair; bar: LR3.T := LR3.T{0.0d0, ..}; ne: NAT := 0; BEGIN c := a; REPEAT WITH k = OrgV(c).num DO bar := LR3.Add(bar, c3[k]) END; c := Enext(c); INC(ne); UNTIL c = a; bar := LR3.Scale(1.0d0/FLOAT(ne,LONGREAL), bar); c := a; REPEAT WITH un = OrgV(c).num, vn = OrgV(Clock(c)).num DO IF fs.textured THEN WITH txName = "face_texture_" & Fmt.Pad(Fmt.Int(a.facetedge.face.num),6,'0') DO WritePOVTriangleTex(wr,c3[un],c3[vn],bar, txName) END ELSE WritePOVTriangle(wr,c3[un],c3[vn],bar, fs.color, fs.transp, fs.filtering); END END; c := Enext(c) UNTIL c = a; END WritePolygon; BEGIN IF fs.color # White OR fs.transp # Clear THEN WITH a = f.pa DO WriteElemComment("face", f.num); IF Enext(Enext(Enext(a))) = a THEN WriteTriangle(a) ELSE WritePolygon(a) END END END END WriteFace; PROCEDURE WriteEdge(e: Edge; READONLY es: ElemStyle) = BEGIN IF es.radius # 0.0 THEN WITH a = e.pa, b = Enext(a), un = OrgV(a).num, vn = OrgV(b).num DO WriteElemComment("edge", e.num); WritePOVCylinder(wr, c3[un], c3[vn], es.radius, es.color, es.transp, es.filtering) END END END WriteEdge; PROCEDURE WriteVertex(v: Vertex; READONLY vs: ElemStyle) = BEGIN IF vs.radius # 0.0 THEN WITH vn = v.num DO WriteElemComment("vertex", v.num); WritePOVSphere(wr, c3[vn], vs.radius, vs.color, vs.transp, vs.filtering) END END END WriteVertex; BEGIN (* Draw vertices *) FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i] DO IF v.exists OR o.all THEN WITH vs = GetVertexStyle(v, atp.vType[i], o.styles^, o.debug) DO WriteVertex(v, vs) END END END END; (* Draw edges *) FOR i := 0 TO top.NE-1 DO WITH e = top.edge[i] DO IF e.exists OR o.all THEN WITH es = GetEdgeStyle(e, atp.eType[i], o.styles^, o.debug) DO WriteEdge(e, es) END END END END; (* Draw faces *) FOR i := 0 TO top.NF-1 DO WITH f = top.face[i] DO IF f.exists OR o.all THEN WITH fs = GetFaceStyle(f, atp.fType[i], o.styles^, o.debug) DO WriteFace(f, fs) END END END END; Wr.Flush(wr); END WritePOV; PROCEDURE GetVertexStyle(v: Vertex; tp: ElemType; READONLY sty: StyleSpecs; db: BOOL): ElemStyle = BEGIN WITH s = GetElemStyle(sty, tp, v.radius, v.color, v.transp) DO IF db THEN DebugStyle("vertex", v.num, s) END; RETURN s END END GetVertexStyle; PROCEDURE GetEdgeStyle(e: Edge; tp: ElemType; READONLY sty: StyleSpecs; db: BOOL): ElemStyle = BEGIN WITH s = GetElemStyle(sty, tp, e.radius, e.color, e.transp) DO IF db THEN DebugStyle("edge", e.num, s) END; RETURN s END END GetEdgeStyle; PROCEDURE GetFaceStyle(f: Face; tp: ElemType; READONLY sty: StyleSpecs; db: BOOL): ElemStyle = BEGIN WITH s = GetElemStyle(sty, tp, 0.0, f.color, f.transp) DO IF db THEN DebugStyle("face", f.num, s) END; RETURN s END END GetFaceStyle; PROCEDURE DebugStyle(elName: TEXT; elNum: NAT; s: ElemStyle) = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Wr.PutText(stderr, elName & " " & Fmt.Int(elNum)); Wr.PutText(stderr, " style = " & FStyle(s) & "\n"); END DebugStyle; PROCEDURE FStyle(s: ElemStyle): TEXT = BEGIN RETURN "{" & "textured := " & FBool(s.textured) & ", " & "radius := " & Fmt.Real(s.radius) & ", " & "color := " & FColor(s.color) & ", " & "transp := " & Fmt.Real(s.transp) & ", " & "filtering := " & FBool(s.filtering) & "}" END FStyle; PROCEDURE FBool(x: BOOL): TEXT = BEGIN IF x THEN RETURN "T" ELSE RETURN "F" END END FBool; PROCEDURE FColor(x: R3.T): TEXT = BEGIN RETURN "(" & Fmt.Real(x[0], prec := 4, style := Fmt.Style.Fix) & "," & Fmt.Real(x[1], prec := 4, style := Fmt.Style.Fix) & "," & Fmt.Real(x[2], prec := 4, style := Fmt.Style.Fix) & ")" END FColor; PROCEDURE GetElemStyle( READONLY sty: StyleSpecs; tp: ElemType; radius: REAL; color: R3.T; transp3: R3.T; ): ElemStyle = BEGIN WITH transp = (transp3[0] + transp3[1] + transp3[2]) / 3.0 DO FOR i := 0 TO LAST(sty) DO WITH si = sty[i] DO IF tp.dim = si.typ.dim AND (tp.momDim = si.typ.momDim OR si.typ.momDim = AnyDim) AND tp.bdr >= si.typ.bdr AND tp.sil >= si.typ.sil AND tp.mwn >= si.typ.mwn AND tp.mwr >= si.typ.mwr THEN WITH s = si.sty DO RETURN ElemStyle{ textured := s.textured, radius := ModifyRadius(radius, s.radius), color := ModifyColor(color, s.color), transp := ModifyTransp(transp, s.transp), filtering := s.filtering } END END END END; RETURN ElemStyle{ textured := FALSE, radius := radius, color := color, transp := transp, filtering := TRUE } END END GetElemStyle; <*UNUSED*> PROCEDURE EdgeContainedInMapFace(a: Pair): BOOL = (* Return TRUE if the edge associated to the pair "a" belongs to an existing face of the map. Return FALSE c.c. *) VAR b: Pair := a; BEGIN REPEAT WITH f = b.facetedge.face DO IF f.root # -1 THEN RETURN TRUE END END; b := Fnext(b); UNTIL b = a; RETURN FALSE; END EdgeContainedInMapFace; PROCEDURE VertexWrappingNumber( <*UNUSED*> a: Pair; <*UNUSED*> READONLY c3: Coords3D ): INTEGER = (* Computes the wrapping number of the vertex "OrgV(a)". *) BEGIN RETURN 1 (* For now... *) END VertexWrappingNumber; PROCEDURE ModifyColor(READONLY orig, opt: R3.T): R3.T = (* Combines an option-specified color with the intrinsic one. *) VAR c: R3.T; BEGIN FOR i := 0 TO 2 DO IF opt[i] > 0.0 THEN c[i] := MIN(1.0, opt[i]) ELSE c[i] := MAX(0.0, MIN(1.0, ABS(opt[i])*orig[i])) END END; RETURN c END ModifyColor; PROCEDURE ModifyTransp(READONLY orig, opt: REAL): REAL = (* Combines an option-specified transparency with the intrinsic one. *) BEGIN IF opt > 0.0 THEN RETURN MIN(1.0, opt) ELSE RETURN MAX(0.0, MIN(1.0, ABS(opt) * orig)) END END ModifyTransp; PROCEDURE ModifyRadius(READONLY orig, opt: REAL): REAL = (* Combines an option-specified radius with the intrinsic one. *) BEGIN IF opt > 0.0 THEN RETURN opt ELSE RETURN MAX(0.0, ABS(opt) * orig) END END ModifyRadius; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFileTp"); o.inFileTp := pp.getNext(); pp.getKeyword("-inFileSt3"); o.inFileSt3 := pp.getNext(); IF pp.keywordPresent("-outFile") THEN o.outFile := pp.getNext() ELSE o.outFile := o.inFileTp END; IF pp.keywordPresent("-all") THEN o.all := TRUE; o.faces := NIL ELSIF pp.keywordPresent("-faces") THEN o.all := FALSE; o.faces := ParseFaceNums(pp.getNext()) ELSE o.all := FALSE; o.faces := NIL END; o.debug := pp.keywordPresent("-debug"); VAR styles := NEW(REF StyleSpecs, 10); nStyles: NAT := 0; BEGIN WHILE pp.keywordPresent("-style") DO IF NOT pp.testNext("of") THEN pp.error("\"of\" expected") END; WITH dim = ParseElemDimension(pp) DO WHILE pp.testNext("if") DO IF nStyles >= NUMBER(styles^) THEN WITH ns = NEW(REF StyleSpecs, 2*nStyles + 10) DO SUBARRAY(ns^,0,nStyles) := styles^; styles := ns END; END; styles[nStyles] := ParseStyleSpec(pp, dim); INC(nStyles); END END END; o.styles := NEW(REF StyleSpecs, nStyles); o.styles^ := SUBARRAY(styles^, 0, nStyles) END; pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr,"Usage: TriangToPov \\\n"); Wr.PutText(stderr," -inFileTp -inFileSt3 \\\n"); Wr.PutText(stderr," [ -outFile ] \\\n"); Wr.PutText(stderr," [ -all | -faces ,,..., ] \\\n"); Wr.PutText(stderr," [ -debug ] \\\n"); Wr.PutText(stderr," [ -style of { faces | edges | vertices } \\\n"); Wr.PutText(stderr," [ if [ border | silhouette | miswound | miswrapped | \\\n"); Wr.PutText(stderr," from { vertices | edges | faces | cells } ]... \\\n"); Wr.PutText(stderr," then \\\n"); Wr.PutText(stderr," [ invisible | textured | \\\n"); Wr.PutText(stderr," [ radius [=|×] ] \\\n"); Wr.PutText(stderr," [ color [=|×] ] \\\n"); Wr.PutText(stderr," [ {transmit | filter} [=|×] ] \\\n"); Wr.PutText(stderr," \\\n"); Wr.PutText(stderr," ]... \\\n"); Wr.PutText(stderr," ]...\n"); Wr.PutText(stderr," ]...\n"); Process.Exit (1); END END; RETURN o END GetOptions; PROCEDURE ParseStyleSpec( pp: ParseParams.T; dim: ElemDim; ): StyleSpec RAISES {ParseParams.Error} = VAR s := StyleSpec{ typ := ElemType{dim := dim, momDim := AnyDim}, sty := OriginalElemStyle }; BEGIN s.typ.bdr := FALSE; s.typ.sil := FALSE; s.typ.mwn := FALSE; s.typ.mwr := FALSE; LOOP IF pp.testNext("border") THEN s.typ.bdr := TRUE ELSIF pp.testNext("silhouette") THEN s.typ.sil := TRUE ELSIF pp.testNext("miswound") THEN s.typ.mwn := TRUE ELSIF pp.testNext("miswrapped") THEN s.typ.mwr := TRUE ELSIF pp.testNext("from") THEN IF NOT pp.testNext("map") THEN pp.error("\"map\" expected") END; s.typ.momDim := ParseElemDimension(pp); ELSE EXIT END END; IF NOT pp.testNext("then") THEN pp.error("\"then\" expected") END; s.sty := ParseElemStyle(pp); IF dim > s.typ.momDim THEN pp.error("invalid mom/child dimensions") END; RETURN s END ParseStyleSpec; PROCEDURE ParseElemDimension(pp: ParseParams.T): ElemDim RAISES {ParseParams.Error} = BEGIN IF pp.testNext("cells") THEN RETURN 3; ELSIF pp.testNext("faces") THEN RETURN 2; ELSIF pp.testNext("edges") THEN RETURN 1; ELSIF pp.testNext("vertices") THEN RETURN 0; ELSE pp.error("bad original map element"); <* ASSERT FALSE *> END; END ParseElemDimension; PROCEDURE ParseElemStyle(pp: ParseParams.T): ElemStyle RAISES {ParseParams.Error} = VAR s: ElemStyle := OriginalElemStyle; BEGIN IF pp.testNext("invisible") THEN s.textured := FALSE; s.radius := 0.0; s.color := White; s.transp := Clear; ELSIF pp.testNext("textured") THEN s.textured := TRUE; s.color := Black; s.transp := Opaque; ELSE s.textured := FALSE; LOOP IF pp.testNext("radius") THEN WITH negate = ParseOptionalMulOp(pp) DO s.radius := pp.getNextReal(0.0, 100.0); IF negate THEN s.radius := - s.radius END END ELSIF pp.testNext("color") THEN WITH negate = ParseOptionalMulOp(pp) DO FOR j := 0 TO 2 DO s.color[j] := pp.getNextReal(0.0,100.0); IF negate THEN s.color[j] := -s.color[j] END; END END ELSIF pp.testNext("transmit") THEN s.filtering := FALSE; WITH negate = ParseOptionalMulOp(pp) DO s.transp := pp.getNextReal(0.0,100.0); IF negate THEN s.transp := - s.transp END END ELSIF pp.testNext("filter") THEN s.filtering := TRUE; WITH negate = ParseOptionalMulOp(pp) DO s.transp := pp.getNextReal(0.0,100.0); IF negate THEN s.transp := - s.transp END END ELSE EXIT END END END; RETURN s END ParseElemStyle; PROCEDURE ParseOptionalMulOp(pp: ParseParams.T): BOOL = (* Parses an optional "=" or "×", returns TRUE if "×". *) BEGIN IF pp.testNext("=") THEN RETURN FALSE ELSIF pp.testNext("×") THEN RETURN TRUE ELSE RETURN FALSE END END ParseOptionalMulOp; PROCEDURE ParseFaceNums(txt: TEXT): REF FaceNums RAISES {ParseParams.Error} = VAR i, j, k: NAT; c: REF FaceNums := NEW(REF FaceNums, 10); BEGIN TRY WITH n = Text.Length(txt) DO i := 0; k := 0; WHILE i < n DO j := i+1; WHILE j < n AND Text.GetChar(txt,j) # ',' DO INC(j) END; IF c = NIL OR k >= NUMBER(c^) THEN WITH cNew = NEW(REF FaceNums, 2*k) DO IF c # NIL THEN SUBARRAY(cNew^, 0, k) := c^ END; c := cNew; END END; WITH tn = Text.Sub(txt,i,j-i) DO c[k] := Scan.Int(tn); END; INC(k); i := j+1; END; IF c = NIL THEN RETURN NIL ELSE WITH cTrim = NEW(REF FaceNums, k) DO cTrim^ := SUBARRAY(c^, 0, k); RETURN cTrim END END; END EXCEPT Lex.Error, FloatMode.Trap => RAISE ParseParams.Error; END END ParseFaceNums; BEGIN DoIt(); END TriangToPov. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (* Last edited on 2001-05-21 21:42:11 by stolfi *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/TriangToWire4.m3 MODULE TriangToWire4 EXPORTS Main; (* This module writes the configuration as expected by the "Wire4" - Interactive 4D Wireframe Display program (".w4"). Revisions: 08-07-2000: Added the silhouette faces. Note that the silhouette faces depending of the 4D->3D projection, so for any 3D rotation the silhouette faces are the same. But for any 4D rotation the 3D projection changes and consequently the silhouette faces also change. 07-08-2000: Included the "normalization" option by Stolfi. 04-11-2000: Last modification by Lozada. *) IMPORT Triangulation, ParseParams, Process, Wr, Thread, OSError, FileWr, Mis, LR4, Fmt, Octf, LR3, LR4Extras, Tridimensional, Text, Math, R3; FROM Stdio IMPORT stderr; FROM Triangulation IMPORT Topology, Coords, Pair, TetraNegPosVertices, OrgV; FROM Octf IMPORT Enext, Enext_1, Clock, Fnext; CONST IniStackSize = 100000; Epsilon = 0.0000000001d0; VAR nee,nfe: CARDINAL := 0; (* number of edges and faces existing *) estack := NEW(REF ARRAY OF CARDINAL, IniStackSize); (* stack for edges *) etop : CARDINAL := 0; (* top for the above stacks *) palette : ARRAY[0..5] OF Color; (* the palette colors for the original faces. *) fac : REF ARRAY OF Color; (* the face colors to use *) TYPE Row3I = ARRAY [0..2] OF INTEGER; Color = R3.T; Quad = RECORD u, v, w, x: CARDINAL END; PACK = RECORD belong: BOOLEAN; num: INTEGER END; Options = RECORD inFileTp: TEXT; inFileSt: TEXT; outFile : TEXT; normalize: LONGREAL; (* Normalize al vertices onto the S^3 with that radius. *) From4: LR4.T; To4: LR4.T; Up4: LR4.T; Over4: LR4.T; Vangle4: LONGREAL; From3: LR3.T; To3: LR3.T; Up3: LR3.T; Vangle3: LONGREAL; DepthCueLevels: INTEGER; all: BOOLEAN; silhouette : BOOLEAN; projectionName: TEXT; colored : BOOLEAN; (* coloring the original faces with a defined palete *) ordernet : CARDINAL; (* Order on the net for original faces of the map. *) END; PROCEDURE WriteColor(wr: Wr.T; READONLY c: Row3I) = (* Write colors in RGB mode *) <* FATAL Wr.Failure, Thread.Alerted *> BEGIN Mis.WriteInt(wr,c[0]); Wr.PutText(wr," "); Mis.WriteInt(wr,c[1]); Wr.PutText(wr," "); Mis.WriteInt(wr,c[2]); END WriteColor; PROCEDURE EdgeBelongsToOriginalFace(a: Pair; READONLY top:Topology): PACK = (* Returns TRUE if the edge component of "a" belongs to a face of the original map also accomplish the number of the original face. *) VAR b: Pair := a; pack: PACK; BEGIN IF top.edge[a.facetedge.edge.num].root # -1 THEN pack.belong := FALSE; pack.num := -1; RETURN pack; END; (* Check if any face incident to "a" belongs to a face of the original map. *) REPEAT IF top.face[b.facetedge.face.num].root # -1 THEN pack.belong := TRUE; pack.num := b.facetedge.face.num; RETURN pack; END; b := Fnext(b) UNTIL b = a; pack.belong := FALSE; pack.num := -1; RETURN pack; END EdgeBelongsToOriginalFace; PROCEDURE Sign(d: LONGREAL) : BOOLEAN = (* Return TRUE iff the longreal value is positive, FALSE c.c. *) BEGIN <* ASSERT d # 0.0d0 *> IF d < 0.0d0 THEN RETURN FALSE ELSE RETURN TRUE END; END Sign; PROCEDURE DoIt() = <* FATAL Wr.Failure, Thread.Alerted *> BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToMa(o.inFileTp), top = tc.top, rc = Triangulation.ReadState(o.inFileSt), rc3 = NEW(REF Tridimensional.Coords3D, top.NV), c = rc^, c3 = rc3^, comments = tc.comments & "\n Make by TriangToWire4: " & o.outFile & ".w4 on " & Mis.Today() & "\n" DO IF o.normalize > 0.0d0 THEN Wr.PutText(stderr, "projecting vertices onto the unit S^3\n"); NormalizeVertexCoords(c, o.normalize); END; ProjectTo3D(o, c, c3, top); WriteWire4File(o, top, c, c3, comments); END END DoIt; PROCEDURE NormalizeVertexCoords(VAR c: Coords; newR: LONGREAL) = BEGIN WITH b = Barycenter(c) DO FOR i := 0 TO LAST(c) DO WITH p = c[i], q = LR4.Sub(p, b), r = LR4.Norm(q) DO IF r > 0.0d0 THEN p := LR4.Scale(newR/r, q) END END END END END NormalizeVertexCoords; PROCEDURE Barycenter(READONLY c: Coords): LR4.T = VAR B: LR4.T := LR4.T{0.0d0, ..}; BEGIN FOR i := 0 TO LAST(c) DO B := LR4.Add(B, c[i]) END; RETURN LR4.Scale(1.0d0/FLOAT(NUMBER(c), LONGREAL), B) END Barycenter; PROCEDURE WriteWire4File( READONLY o : Options; READONLY top: Topology; READONLY c : Triangulation.Coords; READONLY c3 : Tridimensional.Coords3D; comments: TEXT; ) = <* FATAL Wr.Failure, Thread.Alerted, OSError.E *> BEGIN WITH wr = FileWr.Open(o.outFile & ".w4") DO Mis.WriteCommentsJS(wr,comments,'#'); Wr.PutText(wr, "\n"); WriteWire4(o, wr, top, c, c3); Wr.Close(wr) END END WriteWire4File; PROCEDURE WriteWire4( READONLY o: Options; wr: Wr.T; READONLY top: Topology; READONLY c: Coords; READONLY c3 : Tridimensional.Coords3D; ) = <* FATAL Wr.Failure, Thread.Alerted *> PROCEDURE FindOriR3(q: Quad) : LONGREAL = (* For each tetrahedron with extremus vertices numbers u,v,w,x compute us its orientation in R^{3} through the 4x4 determinant: _ _ | c3[q.u][0] c3[q.u][1] c3[q.u][2] 1.0d0 | B = | c3[q.v][0] c3[q.v][1] c3[q.v][2] 1.0d0 | | c3[q.w][0] c3[q.w][1] c3[q.w][2] 1.0d0 | | c3[q.x][0] c3[q.x][1] c3[q.x][2] 1.0d0 | - - *) BEGIN WITH a = LR4.T{c3[q.u][0], c3[q.u][1], c3[q.u][2], 1.0d0}, b = LR4.T{c3[q.v][0], c3[q.v][1], c3[q.v][2], 1.0d0}, c = LR4.T{c3[q.w][0], c3[q.w][1], c3[q.w][2], 1.0d0}, d = LR4.T{c3[q.x][0], c3[q.x][1], c3[q.x][2], 1.0d0} DO RETURN LR4Extras.Det(a,b,c,d); END END FindOriR3; PROCEDURE SilhouetteFaces(a: Pair) : BOOLEAN = (* Return TRUE iff the face associated to the pair "a" is a silhouette face, FALSE c.c. *) BEGIN WITH t = TetraNegPosVertices(a), un = t[0].num, vn = t[1].num, wn = t[2].num, xn = t[3].num, yn = t[4].num, t1 = Quad{un,vn,wn,xn}, t2 = Quad{un,vn,wn,yn}, d1 = FindOriR3(t1), d2 = FindOriR3(t2) DO IF (Sign(d1) AND Sign(d2)) OR ((NOT Sign(d1)) AND (NOT Sign(d2))) THEN RETURN TRUE ELSE RETURN FALSE END END END SilhouetteFaces; VAR cv, ce: Row3I; BEGIN PROCEDURE WriteCoord(x: LONGREAL) = BEGIN Wr.PutText(wr, Fmt.Pad(Fmt.LongReal(x, Fmt.Style.Fix, prec := 4), 7)); END WriteCoord; PROCEDURE WritePoint4D(READONLY c: LR4.T) = BEGIN WriteCoord(c[0]); Wr.PutText(wr, " "); WriteCoord(c[1]); Wr.PutText(wr, " "); WriteCoord(c[2]); Wr.PutText(wr, " "); WriteCoord(c[3]); END WritePoint4D; PROCEDURE WritePoint3D(READONLY c: LR3.T) = BEGIN WriteCoord(c[0]); Wr.PutText(wr, " "); WriteCoord(c[1]); Wr.PutText(wr, " "); WriteCoord(c[2]); END WritePoint3D; BEGIN WITH NV = top.NV, NE = top.NE, NF = top.NF, eWidth = Mis.NumDigits(NE-1) DO Wr.PutText(wr,"\nDepthCueLevels "); Mis.WriteInt(wr,o.DepthCueLevels); Wr.PutText(wr,"\n"); Wr.PutText(wr, "\nFrom4: "); WritePoint4D(o.From4); Wr.PutText(wr, "\nTo4 : "); WritePoint4D(o.To4); Wr.PutText(wr, "\nUp4 : "); WritePoint4D(o.Up4); Wr.PutText(wr, "\nOver4: "); WritePoint4D(o.Over4); Wr.PutText(wr, "\nVangle4: "); Mis.WriteLong(wr, o.Vangle4); Wr.PutText(wr, "\n"); Wr.PutText(wr, "\nFrom3: "); WritePoint3D(o.From3); Wr.PutText(wr, "\nTo3 : "); WritePoint3D(o.To3); Wr.PutText(wr, "\nUp3 : "); WritePoint3D(o.Up3); Wr.PutText(wr, "\nVangle3: "); Mis.WriteLong(wr, o.Vangle3); Wr.PutText(wr, "\n"); IF Text.Equal(o.projectionName,"Perspective") THEN Wr.PutText(wr, "\nProject4: Perspective"); ELSE Wr.PutText(wr, "\nProject4: Parallel"); END; (* vertices *) Wr.PutText(wr, "\n\nVertexList " & Fmt.Int(NV) & ":\n"); FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i] DO WritePoint4D(c[v.num]); Wr.PutText(wr, " : "); cv[0] := ROUND(v.color[0]*255.0); cv[1] := ROUND(v.color[1]*255.0); cv[2] := ROUND(v.color[2]*255.0); WriteColor(wr, cv); Wr.PutText(wr, " : "); Mis.WriteRadius(wr, v.radius); Wr.PutText(wr, "\n"); END END; Wr.PutText(wr, "\n"); (* EDGES *) FOR i := 0 TO NE-1 DO WITH e = top.edge[i] DO IF e.exists OR o.all THEN INC(nee) END END END; FOR i := 0 TO NF-1 DO WITH f = top.face[i] DO IF f.exists OR o.all THEN INC(nfe) END END END; IF o.colored THEN (* computing the original number faces *) VAR max : CARDINAL := 0; BEGIN FOR i := 0 TO top.NF-1 DO WITH f = top.face[i] DO IF f.exists THEN max := MAX(max,f.root); END END END; Wr.PutText(stderr,"The original number faces is " & Fmt.Int(max+1) & "\n"); fac := NEW(REF ARRAY OF Color,max+1); (* defining the palette colors with brightness aprox. 0.7 *) palette[0] := Color{1.00,0.50,1.00}; palette[1] := Color{0.00,1.00,1.00}; palette[2] := Color{0.80,0.80,0.00}; palette[3] := Color{1.00,0.60,0.60}; palette[4] := Color{0.25,1.00,0.25}; palette[5] := Color{0.70,0.70,1.00}; (* attribution of differents colors for each original face *) FOR j := 0 TO max DO fac[j] := palette[j MOD 6]; END END END; IF o.silhouette THEN FOR i := 0 TO top.NF-1 DO WITH f = top.face[i], a = f.pa, aen = a.facetedge.edge.num, b = Enext(a), ben = b.facetedge.edge.num, c = Enext_1(a), cen = c.facetedge.edge.num DO IF SilhouetteFaces(a) THEN IF NOT Present(estack, etop, aen) THEN INC(nee); Save(estack,etop,aen); END; IF NOT Present(estack, etop, ben) THEN INC(nee); Save(estack,etop,ben); END; IF NOT Present(estack, etop, cen) THEN INC(nee); Save(estack,etop,cen); END END END END END; (* Clean the stack *) WHILE etop > 0 DO etop := etop - 1; estack[etop] := 0; END; Wr.PutText(wr, "EdgeList " & Fmt.Int(nee) & ":\n"); FOR i := 0 TO NE-1 DO WITH e = top.edge[i], a = e.pa DO IF e.exists OR o.all THEN Wr.PutText(wr, Fmt.Pad(Fmt.Int(OrgV(a).num), eWidth) & " " & Fmt.Pad(Fmt.Int(OrgV(Clock(a)).num), eWidth)); Wr.PutText(wr, " : "); (* color *) IF NOT o.colored THEN ce[0] := ROUND(e.color[0]*255.0); ce[1] := ROUND(e.color[1]*255.0); ce[2] := ROUND(e.color[2]*255.0); END; IF o.colored THEN IF e.exists AND EdgeBelongsToOriginalFace(a,top).belong THEN (* is an edge on the net belonging to some original face *) WITH facc = EdgeBelongsToOriginalFace(a,top).num, froot = top.face[facc].root DO ce[0] := ROUND(fac[froot][0]*255.0); ce[1] := ROUND(fac[froot][1]*255.0); ce[2] := ROUND(fac[froot][2]*255.0); END ELSIF e.exists AND NOT EdgeBelongsToOriginalFace(a,top).belong THEN ce[0] := ROUND(e.color[0]*255.0); ce[1] := ROUND(e.color[1]*255.0); ce[2] := ROUND(e.color[2]*255.0); END END; WriteColor(wr, ce); Wr.PutText(wr, " : "); Mis.WriteRadius(wr, e.radius); Wr.PutText(wr, "\n"); END END END; IF o.silhouette THEN FOR i := 0 TO top.NF-1 DO WITH f = top.face[i], a = f.pa, ae = a.facetedge.edge, aen = ae.num, ea = top.edge[aen], b = Enext(a), be = b.facetedge.edge, ben = be.num, eb = top.edge[ben], c = Enext_1(a), cce = c.facetedge.edge, cen = cce.num, ec = top.edge[cen], cs = Row3I{0,255,255} (* color for the edges of the silhouette faces *) DO IF SilhouetteFaces(a) THEN IF NOT Present(estack, etop, aen) THEN Wr.PutText(wr, Fmt.Pad(Fmt.Int(OrgV(ea.pa).num), eWidth) & " " & Fmt.Pad(Fmt.Int(OrgV(Clock(ea.pa)).num), eWidth)); Wr.PutText(wr, " : "); (* color *) WriteColor(wr, cs); Wr.PutText(wr, " : "); Mis.WriteRadius(wr, ea.radius); Wr.PutText(wr, "\n"); Save(estack,etop,aen); END; IF NOT Present(estack, etop, ben) THEN Wr.PutText(wr, Fmt.Pad(Fmt.Int(OrgV(eb.pa).num), eWidth) & " " & Fmt.Pad(Fmt.Int(OrgV(Clock(eb.pa)).num), eWidth)); Wr.PutText(wr, " : "); (* color *) WriteColor(wr, cs); Wr.PutText(wr, " : "); Mis.WriteRadius(wr, eb.radius); Wr.PutText(wr, "\n"); Save(estack,etop,ben); END; IF NOT Present(estack, etop, cen) THEN Wr.PutText(wr, Fmt.Pad(Fmt.Int(OrgV(ec.pa).num), eWidth) & " " & Fmt.Pad(Fmt.Int(OrgV(Clock(ec.pa)).num), eWidth)); Wr.PutText(wr, " : "); (* color *) WriteColor(wr, cs); Wr.PutText(wr, " : "); Mis.WriteRadius(wr, ec.radius); Wr.PutText(wr, "\n"); Save(estack,etop,cen); END END END END END; Wr.Close(wr); END END END WriteWire4; PROCEDURE ProjectTo3D( READONLY o: Options; READONLY c: Coords; VAR c3: Tridimensional.Coords3D; READONLY top: Topology ) = <* FATAL Wr.Failure, Thread.Alerted *> PROCEDURE CalcV4Matrix() = (* This procedure computes the four basis vectors for the 4D viewing matrix, Wa,Wb,Wc, and Wd. Note that the Up vector transforms to Wb, the Over vector transforms to Wc, and the line of sight transforms to Wd. The Wa vector is then computed from Wb,Wc and Wd. *) BEGIN (* Calculate Wd, the 4th coordinate basis vector and line-of-sight. *) Wd := LR4.Sub(o.To4,o.From4); norm := LR4.Norm(Wd); IF norm < Epsilon THEN Wr.PutText(stderr,"4D To Point and From Point are the same\n"); Process.Exit(1); END; Wd := LR4.Scale(1.0d0/norm, Wd); (* Calculate Wa, the X-axis basis vector. *) Wa := LR4Extras.Cross(o.Up4,o.Over4,Wd); norm := LR4.Norm(Wa); IF norm < Epsilon THEN Wr.PutText(stderr, "4D up,over and view vectors are not perpendicular\n"); Process.Exit(1); END; Wa := LR4.Scale(1.0d0/norm, Wa); (* Calculate Wb, the perpendicularized Up vector. *) Wb := LR4Extras.Cross(o.Over4,Wd,Wa); norm := LR4.Norm(Wb); IF norm < Epsilon THEN Wr.PutText(stderr,"Invalid 4D over vector\n"); Process.Exit(1); END; Wb := LR4.Scale(1.0d0/norm, Wb); (* Calculate Wc, the perpendicularized Over vector. Note that the resulting vector is already normalized, since Wa, Wb and Wd are all unit vectors. *) Wc := LR4Extras.Cross(Wd,Wa,Wb); END CalcV4Matrix; VAR Tan2Vangle4, Data4Radius, pconst, rtemp, depth: LONGREAL; TempV : LR4.T; Wa,Wb,Wc,Wd : LR4.T; norm : LONGREAL; BEGIN WITH angle = o.Vangle4/2.0d0, angler = (FLOAT(Math.Pi,LONGREAL)*angle)/180.0d0 DO Tan2Vangle4 := Math.tan(angler); END; (* Find the radius of the 4D data. The radius of the 4D data is the radius of the smallest enclosing sphere, centered at the To point. Note that during the loop through the vertices, Data4Radius holds the squared radius value. *) Data4Radius := 0.0d0; FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i], Temp4 = LR4.Sub(c[v.num],o.To4), dist = LR4.Dot(Temp4,Temp4) DO IF dist > Data4Radius THEN Data4Radius := dist; END END END; Data4Radius := Math.sqrt(Data4Radius); Wr.PutText(stderr,"Data4Radius: "& Fmt.Pad(Fmt.LongReal(Data4Radius, Fmt.Style.Fix, prec := 4),8)&"\n"); CalcV4Matrix(); IF Text.Equal(o.projectionName, "Parallel") THEN rtemp := 1.0d0 / Data4Radius; ELSE pconst := 1.0d0 / Tan2Vangle4; END; FOR i := 0 TO top.NV-1 DO (* Transform the vertices from 4d World coordinates to 4D eye coordinates. *) WITH v = top.vertex[i] DO TempV := LR4.Sub(c[v.num],o.From4); depth := LR4.Dot(TempV,Wd); IF Text.Equal(o.projectionName, "Perspective") THEN rtemp := pconst / depth; END; c3[v.num][0] := rtemp * LR4.Dot(TempV, Wa); c3[v.num][1] := rtemp * LR4.Dot(TempV, Wb); c3[v.num][2] := rtemp * LR4.Dot(TempV, Wc); END END; END ProjectTo3D; PROCEDURE Save( VAR Stack: REF ARRAY OF CARDINAL; VAR top,element: CARDINAL; ) = (* Saves the "element" on the stack "Stack". *) BEGIN Stack[top] := element; top := top + 1; END Save; PROCEDURE Present( READONLY Stack: REF ARRAY OF CARDINAL; top,element: CARDINAL; ) : BOOLEAN = (* Return TRUE if "element" its on the stack, FALSE c.c. *) VAR nstack1: CARDINAL := top; BEGIN WHILE nstack1 > 0 DO nstack1 := nstack1 - 1; IF Stack[nstack1] = element THEN RETURN TRUE END; END; RETURN FALSE; END Present; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFileTp"); o.inFileTp := pp.getNext(); pp.getKeyword("-inFileSt"); o.inFileSt := pp.getNext(); IF pp.keywordPresent("-outFile") THEN o.outFile := pp.getNext() ELSE o.outFile := o.inFileSt END; IF pp.keywordPresent("-normalize") THEN (* Desired radius of model in R^4 *) o.normalize := pp.getNextLongReal(1.0d-10,1.0d+10); ELSE o.normalize := 0.0d0 (* No normalization *) END; IF pp.keywordPresent("-DepthCueLevels") THEN o.DepthCueLevels := pp.getNextInt(1, 255); ELSE o.DepthCueLevels := 16; END; pp.getKeyword("-projection"); o.projectionName := pp.getNext(); IF NOT (Text.Equal(o.projectionName, "Parallel") OR Text.Equal(o.projectionName, "Perspective")) THEN pp.error("Bad projection \"" & pp.getNext() & "\"\n") END; IF pp.keywordPresent("-From4") THEN FOR j := 0 TO 3 DO o.From4[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.From4 := LR4.T{0.0d0,0.0d0,0.0d0,-5.0d0}; END; IF pp.keywordPresent("-To4") THEN FOR j := 0 TO 3 DO o.To4[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.To4 := LR4.T{0.0d0,0.0d0,0.0d0,0.0d0}; END; IF pp.keywordPresent("-Up4") THEN FOR j := 0 TO 3 DO o.Up4[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.Up4 := LR4.T{0.0d0,1.0d0,0.0d0,0.0d0}; END; IF pp.keywordPresent("-Over4") THEN FOR j := 0 TO 3 DO o.Over4[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.Over4 := LR4.T{0.0d0,0.0d0,1.0d0,0.0d0}; END; IF pp.keywordPresent("-Vangle4") THEN o.Vangle4 := pp.getNextLongReal(1.0d0, 179.0d0); ELSE o.Vangle4 := 45.0d0; END; IF pp.keywordPresent("-From3") THEN FOR j := 0 TO 2 DO o.From3[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.From3 := LR3.T{2.0d0,1.5d0,3.0d0}; END; IF pp.keywordPresent("-To3") THEN FOR j := 0 TO 2 DO o.To3[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.To3 := LR3.T{0.0d0,0.0d0,0.0d0}; END; IF pp.keywordPresent("-Up3") THEN FOR j := 0 TO 2 DO o.Up3[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.Up3 := LR3.T{0.0d0,1.0d0,0.0d0}; END; IF pp.keywordPresent("-Vangle3") THEN o.Vangle3 := pp.getNextLongReal(1.0d0, 179.0d0); ELSE o.Vangle3 := 45.0d0; END; o.all := pp.keywordPresent("-all"); o.silhouette := pp.keywordPresent("-silhouette"); o.colored := pp.keywordPresent("-colored"); IF pp.keywordPresent("-ordernet") THEN o.ordernet := pp.getNextInt(1, 5); END; pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: TriangToWire4 \\\n"); Wr.PutText(stderr, " -inFileTp \\\n"); Wr.PutText(stderr, " -inFileSt \\\n"); Wr.PutText(stderr, " [ -outFile ] \\\n"); Wr.PutText(stderr, " -projection [ Perspective | Parallel ] \\\n"); Wr.PutText(stderr, " [-normalize ] \\\n"); Wr.PutText(stderr, " [ -From4 ]\\ \n"); Wr.PutText(stderr, " [ -To4 ] \\\n"); Wr.PutText(stderr, " [ -Up4 ] \\\n"); Wr.PutText(stderr, " [ -Over4 ] \\\n"); Wr.PutText(stderr, " [ -Vangle4 ] \\\n"); Wr.PutText(stderr, " [ -From3 ] \\\n"); Wr.PutText(stderr, " [ -To3 ] \\\n"); Wr.PutText(stderr, " [ -Up3 ] \\\n"); Wr.PutText(stderr, " [ -Vangle3 ] \\\n"); Wr.PutText(stderr, " [ -DepthCueLevels ] \\\n"); Wr.PutText(stderr, " [ -silhouette ]\n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt(); END TriangToWire4. (**************************************************************************) (* *) (* Copyright (C) 2001 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/TriangToX3D.m3 MODULE TriangToX3D EXPORTS Main; (* This program contain procedures to write "3D topologies" (non exclusively triangulations) in X3D format (".poly"), an interactive wireframe viewer for X11. *) IMPORT Triangulation, FileWr, OSError, ParseParams, Process, Wr, Thread, Fmt, LR3, R3, Tridimensional, LR4, LR4Extras, Octf; FROM Triangulation IMPORT Topology, Pair, TetraNegPosVertices, OrgV, Face; FROM Stdio IMPORT stderr; FROM Octf IMPORT Enext; FROM LR3 IMPORT Scale, Add; TYPE Quad = RECORD u, v, w, x: CARDINAL END; Color = R3.T; Options = RECORD inFileTp : TEXT; inFileSt3 : TEXT; outFile : TEXT; silhouette : BOOLEAN; (* TRUE draws the silhouette faces *) all : BOOLEAN; (* TRUE draws even non-existing triangles *) colored : BOOLEAN; (* coloring the original faces with a defined palete *) ordernet : CARDINAL; (* Order on the net for original faces of the map. *) END; LONG = LONGREAL; VAR palette : ARRAY[0..5] OF Color; (* the palette colors for the original faces. *) fac : REF ARRAY OF Color; (* the face colors to use *) PROCEDURE Sign(d: LONG) : BOOLEAN = (* Return TRUE iff the longreal value is positive, FALSE c.c. *) BEGIN <* ASSERT d # 0.0d0 *> IF d < 0.0d0 THEN RETURN FALSE ELSE RETURN TRUE END; END Sign; PROCEDURE DoIt() = BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToMa(o.inFileTp), rc3 = Tridimensional.ReadState3D(o.inFileSt3), top = tc.top, c3 = rc3^ DO WriteX3DFile(o.outFile, top, c3, o) END END DoIt; PROCEDURE WriteX3DFile( name: TEXT; READONLY top: Topology; READONLY c3: Tridimensional.Coords3D; op : Options; ) = <* FATAL Wr.Failure, Thread.Alerted, OSError.E *> BEGIN WITH wr = FileWr.Open(name & ".poly") DO Wr.PutText(wr, "# Created by TriangToX3D: " & name & ".poly\n"); WriteX3D(wr, top, c3, op); Wr.Close(wr) END END WriteX3DFile; PROCEDURE WriteX3D( wr: Wr.T; READONLY top: Topology; READONLY c3: Tridimensional.Coords3D; op : Options; ) = <* FATAL Wr.Failure, Thread.Alerted *> PROCEDURE FindOriR3(q: Quad) : LONG = (* For each tetrahedron with extremus vertices numbers u,v,w,x compute us its orientation in R^{3} through the 4x4 determinant: _ _ | c3[q.u][0] c3[q.u][1] c3[q.u][2] 1.0d0 | B = | c3[q.v][0] c3[q.v][1] c3[q.v][2] 1.0d0 | | c3[q.w][0] c3[q.w][1] c3[q.w][2] 1.0d0 | | c3[q.x][0] c3[q.x][1] c3[q.x][2] 1.0d0 | - - *) BEGIN WITH a = LR4.T{c3[q.u][0], c3[q.u][1], c3[q.u][2], 1.0d0}, b = LR4.T{c3[q.v][0], c3[q.v][1], c3[q.v][2], 1.0d0}, c = LR4.T{c3[q.w][0], c3[q.w][1], c3[q.w][2], 1.0d0}, d = LR4.T{c3[q.x][0], c3[q.x][1], c3[q.x][2], 1.0d0} DO RETURN LR4Extras.Det(a,b,c,d); END END FindOriR3; PROCEDURE SilhouetteFaces(a: Pair) : BOOLEAN = (* Return TRUE iff the face associated to the pair "a" is a silhouette face, FALSE c.c. *) BEGIN WITH t = TetraNegPosVertices(a), un = t[0].num, vn = t[1].num, wn = t[2].num, xn = t[3].num, yn = t[4].num, t1 = Quad{un,vn,wn,xn}, t2 = Quad{un,vn,wn,yn}, d1 = FindOriR3(t1), d2 = FindOriR3(t2) DO IF (Sign(d1) AND Sign(d2)) OR ((NOT Sign(d1)) AND (NOT Sign(d2))) THEN RETURN TRUE ELSE RETURN FALSE END END END SilhouetteFaces; PROCEDURE WriteX3DCoord(x: LONG) = BEGIN Wr.PutText(wr, Fmt.LongReal(x*1000.0d0, prec := 5)) END WriteX3DCoord; PROCEDURE WriteX3DColor(READONLY cr: R3.T) = BEGIN Wr.PutText(wr, Fmt.Int(ROUND(255.0*cr[0]))); Wr.PutText(wr, " "); Wr.PutText(wr, Fmt.Int(ROUND(255.0*cr[1]))); Wr.PutText(wr, " "); Wr.PutText(wr, Fmt.Int(ROUND(255.0*cr[2]))); END WriteX3DColor; PROCEDURE WriteX3DPoint(READONLY p: LR3.T) = BEGIN WriteX3DCoord(p[0]); Wr.PutText(wr, " "); WriteX3DCoord(p[1]); Wr.PutText(wr, " "); WriteX3DCoord(p[2]); END WriteX3DPoint; PROCEDURE WriteX3DFace( READONLY n: CARDINAL; READONLY f: Triangulation.Face; ) = (* This procedure writes a n-gon face *) VAR sc: REF ARRAY OF CARDINAL; color: R3.T; BEGIN sc := NEW(REF ARRAY OF CARDINAL,n); color := f.color; Wr.PutText(wr, "# face " & Fmt.Int(f.num) & "\n"); Wr.PutText(wr, " "); WriteX3DColor(color); Wr.PutText(wr, "# color \n\n"); WITH a = f.pa DO FOR i := 0 TO n-1 DO sc[i] := OrgV(a).num; Wr.PutText(wr, " "); WriteX3DPoint(c3[sc[i]]); Wr.PutText(wr, "\n"); a := Enext(a); END; END; Wr.PutText(wr,"\n"); Wr.Flush(wr); END WriteX3DFace; PROCEDURE WriteGhostTriang(u,v,w : LR3.T; color: R3.T) = (* This procedure writes a triangular ghost face *) BEGIN Wr.PutText(wr, "# ghost face\n"); Wr.PutText(wr, " "); WriteX3DColor(color); Wr.PutText(wr, "# color \n\n"); Wr.PutText(wr, " "); WriteX3DPoint(u); Wr.PutText(wr, "\n"); Wr.PutText(wr, " "); WriteX3DPoint(v); Wr.PutText(wr, "\n"); Wr.PutText(wr, " "); WriteX3DPoint(w); Wr.PutText(wr, "\n\n"); Wr.Flush(wr); END WriteGhostTriang; PROCEDURE WriteInternalTriangle(f: Face; colored: BOOLEAN; ordernet: CARDINAL) = (* Writes the POV representation of an internal net for the "a.face" (which is assumed to be a triangle). *) BEGIN WITH a = f.pa, b = Enext(a), c = Enext(b), un = OrgV(a).num, vn = OrgV(b).num, wn = OrgV(c).num, d0x = (c3[vn][0] - c3[un][0])/FLOAT(ordernet, LONG), d0y = (c3[vn][1] - c3[un][1])/FLOAT(ordernet, LONG), d0z = (c3[vn][2] - c3[un][2])/FLOAT(ordernet, LONG), d1x = (c3[wn][0] - c3[vn][0])/FLOAT(ordernet, LONG), d1y = (c3[wn][1] - c3[vn][1])/FLOAT(ordernet, LONG), d1z = (c3[wn][2] - c3[vn][2])/FLOAT(ordernet, LONG), d2x = (c3[un][0] - c3[wn][0])/FLOAT(ordernet, LONG), d2y = (c3[un][1] - c3[wn][1])/FLOAT(ordernet, LONG), d2z = (c3[un][2] - c3[wn][2])/FLOAT(ordernet, LONG), fc = f.color DO IF ordernet = 1 THEN (* nothing *) ELSIF ordernet = 2 THEN FOR j := 1 TO ordernet-1 DO WITH n0x = c3[vn][0] - FLOAT(j, LONG) * d0x, n0y = c3[vn][1] - FLOAT(j, LONG) * d0y, n0z = c3[vn][2] - FLOAT(j, LONG) * d0z, n1x = c3[wn][0] - FLOAT(j, LONG) * d1x, n1y = c3[wn][1] - FLOAT(j, LONG) * d1y, n1z = c3[wn][2] - FLOAT(j, LONG) * d1z, n2x = c3[un][0] - FLOAT(j, LONG) * d2x, n2y = c3[un][1] - FLOAT(j, LONG) * d2y, n2z = c3[un][2] - FLOAT(j, LONG) * d2z, n0 = LR3.T{n0x,n0y,n0z}, n1 = LR3.T{n1x,n1y,n1z}, n2 = LR3.T{n2x,n2y,n2z} DO IF NOT colored THEN WriteGhostTriang(n0,n1,n2,fc); ELSE WriteGhostTriang(n0,n1,n2,fc); END END END; ELSIF ordernet = 3 THEN FOR j := 1 TO 1 DO WITH n00x = c3[vn][0] - FLOAT(j, LONG) * d0x, n00y = c3[vn][1] - FLOAT(j, LONG) * d0y, n00z = c3[vn][2] - FLOAT(j, LONG) * d0z, n00 = LR3.T{n00x,n00y,n00z}, n01x = c3[vn][0] - FLOAT(j+1, LONG) * d0x, n01y = c3[vn][1] - FLOAT(j+1, LONG) * d0y, n01z = c3[vn][2] - FLOAT(j+1, LONG) * d0z, n01 = LR3.T{n01x,n01y,n01z}, n10x = c3[wn][0] - FLOAT(j, LONG) * d1x, n10y = c3[wn][1] - FLOAT(j, LONG) * d1y, n10z = c3[wn][2] - FLOAT(j, LONG) * d1z, n10 = LR3.T{n10x,n10y,n10z}, n11x = c3[wn][0] - FLOAT(j+1, LONG) * d1x, n11y = c3[wn][1] - FLOAT(j+1, LONG) * d1y, n11z = c3[wn][2] - FLOAT(j+1, LONG) * d1z, n11 = LR3.T{n11x,n11y,n11z}, n20x = c3[un][0] - FLOAT(j, LONG) * d2x, n20y = c3[un][1] - FLOAT(j, LONG) * d2y, n20z = c3[un][2] - FLOAT(j, LONG) * d2z, n20 = LR3.T{n20x,n20y,n20z}, n21x = c3[un][0] - FLOAT(j+1, LONG) * d2x, n21y = c3[un][1] - FLOAT(j+1, LONG) * d2y, n21z = c3[un][2] - FLOAT(j+1, LONG) * d2z, n21 = LR3.T{n21x,n21y,n21z}, i = Scale(1.0d0/FLOAT(6,LONG),Add(Add(Add(Add(Add(n00,n01),n10),n11),n20),n21)) DO IF NOT colored THEN WriteGhostTriang(n00,i,n11,fc); WriteGhostTriang(i,n21,n10,fc); WriteGhostTriang(n01,n20,i,fc); ELSE WriteGhostTriang(n00,i,n11,fc); WriteGhostTriang(i,n21,n10,fc); WriteGhostTriang(n01,n20,i,fc); END END END ELSE (* nothing *) END END END WriteInternalTriangle; BEGIN IF op.silhouette THEN FOR i := 0 TO top.NF-1 DO WITH f = top.face[i], a = f.pa, der= Octf.DegreeEdgeRing(a) DO IF SilhouetteFaces(a) AND NOT f.exists THEN WriteX3DFace(der,f); END END END END; IF op.colored THEN (* computing the original number faces *) VAR max : CARDINAL := 0; BEGIN FOR i := 0 TO top.NF-1 DO WITH f = top.face[i] DO IF f.exists THEN max := MAX(max,f.root); END END END; Wr.PutText(stderr,"The original number faces is " & Fmt.Int(max+1) & "\n"); fac := NEW(REF ARRAY OF Color,max+1); (* defining the palette colors with brightness aprox. 0.7 *) palette[0] := Color{1.00,0.50,1.00}; palette[1] := Color{0.00,1.00,1.00}; palette[2] := Color{0.80,0.80,0.00}; palette[3] := Color{1.00,0.60,0.60}; palette[4] := Color{0.25,1.00,0.25}; palette[5] := Color{0.70,0.70,1.00}; (* attribution of differents colors for each original face *) FOR j := 0 TO max DO fac[j] := palette[j MOD 6]; END END END; (* drawing the interior of the original faces as a net with the appropriate colors *) FOR i := 0 TO top.NF-1 DO WITH f = top.face[i] DO IF f.exists OR op.all THEN WITH froot = f.root, der = Octf.DegreeEdgeRing(f.pa) DO IF op.colored THEN f.color := fac[froot] END; WriteX3DFace(der,top.face[i]); WriteInternalTriangle(top.face[i],op.colored,op.ordernet); END END END END END WriteX3D; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFileTp"); o.inFileTp := pp.getNext(); pp.getKeyword("-inFileSt3"); o.inFileSt3 := pp.getNext(); IF pp.keywordPresent("-outFile") THEN o.outFile := pp.getNext() ELSE o.outFile := o.inFileTp END; o.all := pp.keywordPresent("-all"); o.silhouette := pp.keywordPresent("-silhouette"); o.colored := pp.keywordPresent("-colored"); IF pp.keywordPresent("-ordernet") THEN o.ordernet := pp.getNextInt(1, 5); END; pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: TriangToX3D \\\n"); Wr.PutText(stderr," -inFileTp -inFileSt3 \\\n"); Wr.PutText(stderr," [-outFile ] [-all] [-silhouette] [-colored]\n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt(); END TriangToX3D. (**************************************************************************) (* *) (* Copyright (C) 2001 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/UnglueCell.m3 MODULE UnglueCell EXPORTS Main; IMPORT Triangulation, Stdio, Wr, Thread, Process, ParseParams, Mis; FROM Stdio IMPORT stderr; FROM Triangulation IMPORT MakePolyhedronTopology, Pair; FROM Octf IMPORT Enext, Srot; TYPE Options = RECORD inFile: TEXT; cellnum: CARDINAL; outFile: TEXT; END; PROCEDURE DoIt() = VAR b: Pair; BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToMa(o.inFile), top = tc.top, a = top.region[o.cellnum], tp = MakePolyhedronTopology(a) DO (* ungluing the polyhedron top.polyhedron[i] *) FOR j := 0 TO tp.NF-1 DO WITH fer = tp.fRef[j] DO b := fer; REPEAT Triangulation.SetOrg(Srot(b), NIL); b := Enext(b) UNTIL b = fer END END; (* building the new topology *) WITH t = Triangulation.MakeTopology(top.out[top.NV-1],1), c = Triangulation.GenCoords(t)^, name = o.outFile DO Triangulation.WriteTopology(name, t, "Created by MakeGem: " & name & ".tp on " & Mis.Today() ); Triangulation.WriteMaterials(name, t, "Created by MakeGem: " & name& ".ma on " & Mis.Today()); Triangulation.WriteState(name, t, c, "Created by MakeGem: " & name & ".st on " & Mis.Today() &"\nRandom Geometry"); END; END; END DoIt; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFile"); o.inFile := pp.getNext(); pp.getKeyword("-cellnum"); o.cellnum := pp.getNextInt(); pp.getKeyword("-outFile"); o.outFile := pp.getNext(); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: Teste" ); Wr.PutText(stderr, " -inFile " ); Wr.PutText(stderr, "\n"); Process.Exit (1); END; END; RETURN o END GetOptions; BEGIN DoIt() END UnglueCell. (**************************************************************************) (* *) (* Copyright (C) 2001 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/UngluingCell.m3 MODULE UngluingCell EXPORTS Main; (* Given a map or any refinement of its, this program unglued any specified cell of the map. *) IMPORT Triangulation, Stdio, Wr, Thread, Process, ParseParams, Mis, Octf, Fmt; FROM Stdio IMPORT stderr; FROM Triangulation IMPORT MakePolyhedronTopology, Pair, Pneg, Ppos, OrgV; FROM Octf IMPORT Enext, Srot; TYPE Options = RECORD inFile : TEXT; cellnum : CARDINAL; outFile : TEXT; polyroot : BOOLEAN; END; PROCEDURE DoIt() = VAR b : Pair; tc : Triangulation.TopCom; top : Triangulation.Topology; oldedge: REF ARRAY OF INTEGER; oldface: REF ARRAY OF INTEGER; oldcoor: REF ARRAY OF INTEGER; <* FATAL Thread.Alerted, Wr.Failure *> BEGIN WITH o = GetOptions(), rc = Triangulation.ReadState(o.inFile), c = rc^ DO IF o.polyroot THEN tc := Triangulation.ReadToMa(o.inFile, TRUE); ELSE tc := Triangulation.ReadToMa(o.inFile, FALSE); END; Wr.PutText(stderr,"Ungluing the cell number "&Fmt.Int(o.cellnum) & "\n"); top := tc.top; oldedge := NEW(REF ARRAY OF INTEGER, top.NFE); oldface := NEW(REF ARRAY OF INTEGER, top.NFE); oldcoor := NEW(REF ARRAY OF INTEGER, top.NFE); FOR i := 0 TO top.NFE-1 DO oldedge[i] := top.facetedge[i].facetedge.edge.num; oldface[i] := top.facetedge[i].facetedge.face.num; oldcoor[i] := OrgV(top.facetedge[i]).num END; FOR i := 0 TO top.NFE-1 DO WITH a = NARROW(top.facetedge[i].facetedge, Triangulation.FacetEdge) DO a.old := i; END END; IF o.polyroot THEN FOR i := 0 TO top.NP-1 DO IF top.polyhedron[i].root = o.cellnum THEN WITH a = top.region[i], tp = MakePolyhedronTopology(a) DO (* ungluing the polyhedron top.polyhedron[i] *) FOR j := 0 TO tp.NF-1 DO WITH fer = tp.fRef[j] DO b := fer; REPEAT Triangulation.SetOrg(Srot(b), NIL); b := Enext(b) UNTIL b = fer END END END END END ELSE WITH a = top.region[o.cellnum], tp = MakePolyhedronTopology(a) DO (* ungluing the polyhedron top.polyhedron[i] *) FOR j := 0 TO tp.NF-1 DO WITH fer = tp.fRef[j] DO b := fer; REPEAT Triangulation.SetOrg(Srot(b), NIL); b := Enext(b) UNTIL b = fer END END END END; FOR i := 0 TO top.NFE-1 DO WITH a = top.facetedge[i], n = Pneg(a), p = Ppos(a) DO IF (n=NIL) AND (p=NIL) THEN VAR b : Pair; BEGIN b := a; REPEAT Octf.DeleteFacetEdge(b); b := Enext(b); UNTIL (b = a); END END END END; (* building the new topology *) PROCEDURE Number() : INTEGER = BEGIN FOR k := 0 TO top.NFE-1 DO WITH l = top.facetedge[k] DO IF (Ppos(l)#NIL) AND (Pneg(l)#NIL) THEN RETURN k END; END END; RETURN -1; END Number; BEGIN WITH l = Number(), t = Triangulation.MakeTopology(top.facetedge[l]), cc = Triangulation.GenCoords(t)^, name = o.outFile DO (* updating the new topology *) FOR i := 0 TO t.NE-1 DO WITH a= t.edge[i] DO Octf.SetEdgeAll(a.pa, a); END END; FOR i := 0 TO t.NF-1 DO WITH a= t.face[i] DO Octf.SetFaceAll(a.pa, a); END END; FOR i := 0 TO t.NFE-1 DO WITH fe = NARROW(t.facetedge[i].facetedge, Triangulation.FacetEdge), o = fe.old, ne = t.facetedge[i].facetedge.edge.num, nf = t.facetedge[i].facetedge.face.num, nv = OrgV(t.facetedge[i]).num, oe = oldedge[o], of = oldface[o], ov = oldcoor[o] DO (* edge *) t.edge[ne].exists := top.edge[oe].exists; t.edge[ne].color := top.edge[oe].color; t.edge[ne].transp := top.edge[oe].transp; t.edge[ne].radius := top.edge[oe].radius; t.edge[ne].root := top.edge[oe].root; (* face *) t.face[nf].exists := top.face[of].exists; t.face[nf].color := top.face[of].color; t.face[nf].transp := top.face[of].transp; t.face[nf].root := top.face[of].root; (* vertex *) cc[nv] := c[ov]; END END; Triangulation.WriteTopology(name, t, "Created by MakeGem: " & name & ".tp on " & Mis.Today() ); Triangulation.WriteMaterials(name, t, "Created by MakeGem: " & name& ".ma on " & Mis.Today(),FALSE); Triangulation.WriteState(name, t, cc, "Created by MakeGem: " & name & ".st on " & Mis.Today() &"\nRandom Geometry"); END END END; END DoIt; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFile"); o.inFile := pp.getNext(); pp.getKeyword("-cellnum"); o.cellnum := pp.getNextInt(); pp.getKeyword("-outFile"); o.outFile := pp.getNext(); o.polyroot := pp.keywordPresent("-polyroot"); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: UngluingCell -inFile \\\n" ); Wr.PutText(stderr, " -outFile -cellnum [-polyroot]\n"); Process.Exit (1); END; END; RETURN o END GetOptions; BEGIN DoIt() END UngluingCell. (**************************************************************************) (* *) (* Copyright (C) 2001 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/Unshellable.m3 MODULE Unshellable EXPORTS Main; IMPORT LR4, Octf, Triangulation, Stdio, Wr, Thread, Fmt, ParseParams, Process, Squared; FROM Octf IMPORT Enext_1, Clock, Fnext, Enext, Fnext_1; FROM Triangulation IMPORT Pair, Coords, OrgV, Topology; FROM Stdio IMPORT stderr; TYPE Options = RECORD gridOrder: CARDINAL; END; TYPE PAIRS = ARRAY[0..3] OF Pair; PROCEDURE MakeBigRawCube(order: CARDINAL) : Pair = (* Build one tridimensional array of cubic cellulas with fixed geometry.*) VAR cd : REF ARRAY OF ARRAY OF ARRAY OF PAIRS; BEGIN cd := NEW(REF ARRAY OF ARRAY OF ARRAY OF PAIRS, 5, order, order); FOR i := 0 TO 4 DO WITH cc = Squared.MakeColumnCube(order) DO FOR j := 0 TO order-1 DO FOR k := 0 TO order-1 DO FOR l := 0 TO 1 DO cd[i,j,k,l] := cc[j,k,l]; END END END END END; (* gluing *) FOR i := 0 TO 3 DO FOR k := 0 TO order-1 DO FOR j := 0 TO order-1 DO EVAL Squared.GlueCube(cd[i,k,j,1],Clock(cd[i+1,k,j,0])); END END END; (* Fix the coordinates *) WITH top = Triangulation.MakeTopology(cd[0,0,0,0],1), r = NEW(REF Coords, top.NV), c = r^, name = "Bigcube-" & Fmt.Int(order), zero = 0.0d0, uno = 1.0d0, comments = " " DO PROCEDURE SetCorner(e: Pair; i: CARDINAL) = BEGIN WITH ii = FLOAT(i,LONGREAL), cv = LR4.T{ii,zero,zero,zero} DO c[OrgV(e).num] := cv; END; END SetCorner; PROCEDURE SetCorner1(e: Pair; o: LR4.T) = BEGIN c[OrgV(e).num] := LR4.T{o[0], o[1]+uno, o[2], o[3]}; END SetCorner1; PROCEDURE SetCorner2(e: Pair; o: LR4.T) = BEGIN c[OrgV(e).num] := LR4.T{o[0], o[1], o[2]+uno, o[3]}; END SetCorner2; PROCEDURE SetCorner3(e: Pair; o: LR4.T) = BEGIN c[OrgV(e).num] := LR4.T{o[0], o[1]-uno, o[2], o[3]}; END SetCorner3; VAR p : Pair; BEGIN FOR i := 0 TO 4 DO SetCorner(Clock(Enext(cd[i,0,0,0])),i); FOR j := 0 TO order-1 DO p := Clock(Enext(cd[i,j,0,0])); FOR k := 0 TO order-1 DO SetCorner1(Enext(p),c[OrgV(p).num]); SetCorner2(Enext(Enext(p)),c[OrgV(Enext(p)).num]); SetCorner3(Enext(Enext(Enext(p))),c[OrgV(Enext(Enext(p))).num]); p := Enext(Fnext_1(Fnext_1(cd[i,j,k,0]))); END; END; END; (* finally *) SetCorner(Enext_1(cd[4,0,0,1]),order); FOR j := 0 TO order-1 DO p := Enext_1(cd[4,j,0,1]); FOR k := 0 TO order-1 DO SetCorner1(Enext(p),c[OrgV(p).num]); SetCorner2(Enext(Enext(p)),c[OrgV(Enext(p)).num]); SetCorner3(Enext(Enext(Enext(p))),c[OrgV(Enext(Enext(p))).num]); p := Clock(Enext_1(Fnext(cd[4,j,k,1]))); END; END; Triangulation.WriteTopology(name,top); Triangulation.MakeTopologyTable(name, top, comments); Triangulation.WriteState(name, top, c, comments); Triangulation.WriteMaterials(name, top, comments); RETURN cd[0,0,0,0]; END; END; END MakeBigRawCube; <* UNUSED *> PROCEDURE FixCoordsCube(READONLY ca: ARRAY[0..5] OF Pair; READONLY ct: Topology): REF Coords = (* Build one cubic with fixed geometry.*) BEGIN WITH r = NEW(REF Coords, ct.NV), c = r^, o1 = LR4.T{ 1.0d0, 1.0d0, 1.0d0,1.0d0}, (* the vertex ( 1, 1, 1,1) *) o2 = LR4.T{ 1.0d0, 1.0d0,-1.0d0,1.0d0}, (* the vertex ( 1, 1,-1,1) *) o3 = LR4.T{ 1.0d0,-1.0d0, 1.0d0,1.0d0}, (* the vertex ( 1,-1, 1,1) *) o4 = LR4.T{ 1.0d0,-1.0d0,-1.0d0,1.0d0}, (* the vertex ( 1,-1,-1,1) *) o5 = LR4.T{-1.0d0, 1.0d0, 1.0d0,1.0d0}, (* the vertex (-1, 1, 1,1) *) o6 = LR4.T{-1.0d0, 1.0d0,-1.0d0,1.0d0}, (* the vertex (-1, 1,-1,1) *) o7 = LR4.T{-1.0d0,-1.0d0, 1.0d0,1.0d0}, (* the vertex (-1,-1, 1,1) *) o8 = LR4.T{-1.0d0,-1.0d0,-1.0d0,1.0d0} (* the vertex (-1,-1,-1,1) *) DO PROCEDURE SetCornerCoords(e: Pair; cv: LR4.T) = BEGIN c[OrgV(e).num] := cv; END SetCornerCoords; BEGIN (* Set the corners *) SetCornerCoords(ca[5],o1); SetCornerCoords(ca[1],o2); SetCornerCoords(Clock(ca[4]),o3); SetCornerCoords(ca[4],o4); SetCornerCoords(Clock(ca[5]),o5); SetCornerCoords(ca[2],o6); SetCornerCoords(Clock(ca[3]),o7); SetCornerCoords(ca[3],o8); END; RETURN r END END FixCoordsCube; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-gridOrder"); o.gridOrder := pp.getNextInt(1,10); pp.finish(); EXCEPT | ParseParams.Error => Wr.PutText(stderr, "Usage: MakeRawCube -gridOrder \n"); Process.Exit (1); END END; RETURN o END GetOptions; PROCEDURE Main() = VAR a: Pair; BEGIN WITH o = GetOptions() DO a := MakeBigRawCube(o.gridOrder); END; END Main; BEGIN Main(); END Unshellable. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/Visibility.m3 MODULE Visibility EXPORTS Main; (* This program implements the "visibility" of a 3D projection. Given a 4D (optimized) configuration, and the viewing parameters of the 4D observer (From4, Up4, etc), writes a POVRAY ".inc" file con- taining the 3D projection of the 4D configuration as "seen" from that viewpoint. The projection will use distinct textures (and optionally omit) the "front" and "back" elements, as well as, the silhouette faces. The back/front test assumes that the tetrahedra constitute the shell of a convex polytope and that the observer is outside that shell. The test consists in computing the orientation of each tetrahedron of the 3D-projected triangulation with reference to the observer and with reference to the "barycenter" of the configuration. Depending the position of the 4D observer we obtain different orientations. Use the option "both" to show both front and back elements. Use the option "-fade" to paint the back elements with faded colors. Use "back" or "front" to show only those elements. If "From4" is not given as an option, the program reads zero or more lines from stdin, each containing an index "i", a value of "From4", one output option ("front"/"back"/"both") and writes one ".inc" file for each such line. *) IMPORT Triangulation, FileWr, ParseParams, OSError, Process, Wr, Rd, Thread, Fmt, Stdio, R3, Lex, Tridimensional, LR4, LR4Extras, Text, Math, FloatMode; FROM Triangulation IMPORT Topology, OrgV, Coords, TetraNegPosVertices, Pair, Barycenter; FROM Stdio IMPORT stderr, stdin; FROM Octf IMPORT Enext, Enext_1, Tors, Clock, Fnext; FROM Pov IMPORT WritePOVSphere, WritePOVCylinder, WritePOVTriangle; FROM Wr IMPORT PutText; CONST Epsilon = 0.0000000001d0; TYPE Options = RECORD inFileTp: TEXT; (* Input file prefix (topology, tabel, materials).*) inFileSt: TEXT; (* Input file prefix (4D geometry). *) outFile: TEXT; (* Output file prefix (POVray include files). *) wire : BOOLEAN; (* Don't draw faces. *) detail: BOOLEAN; (* Debugging. *) silhouette : BOOLEAN; (* Draw the silhouette faces. *) perspective: BOOLEAN; (* TRUE means perspective projection. *) autoProject: BOOLEAN; (* The program choses the viewpoint. *) filter: BOOLEAN; (* TRUE uses filtered colors, FALSE transmit colors.*) fade: BOOLEAN; (* Make the back elements fainter. *) normalize: BOOLEAN; (* Norm. al vertices onto the S^3 with that radius. *) multiple: BOOLEAN; (* T reads multiple "From4"s and "side"s from stdin.*) From4: LR4.T; (* Viewpoint in 4D. *) To4: LR4.T; (* 4D viewing parameters as expected by the *) Up4: LR4.T; (* "Wire4"- Interactive 4D Wireframe Display *) Over4: LR4.T; (* Program. *) Vangle4: LONGREAL; (* *) select: Side; (* Which elements to show in the output. *) selectTxt: TEXT; (* Ditto, in text format. *) colored : BOOLEAN; (* coloring the original faces with a palette*) END; Quad = RECORD u, v, w, x: CARDINAL END; Side = {Back, Front, Both}; Color = R3.T; PACK = RECORD belong: BOOLEAN; num: INTEGER END; <* FATAL Rd.Failure, Wr.Failure, Thread.Alerted, FloatMode.Trap, Lex.Error *> PROCEDURE EdgeBelongsToOriginalFace(a: Pair; READONLY top: Topology): PACK = (* Returns TRUE if the edge component of "a" belongs to a face of the original map also accomplish the number of the original face. *) VAR b: Pair := a; pack: PACK; BEGIN IF top.edge[a.facetedge.edge.num].root # -1 THEN pack.belong := FALSE; pack.num := -1; RETURN pack; END; (* Check if any face incident to "a" belongs to a face of the map. *) REPEAT IF top.face[b.facetedge.face.num].root # -1 THEN pack.belong := TRUE; pack.num := b.facetedge.face.num; RETURN pack; END; b := Fnext(b) UNTIL b = a; pack.belong := FALSE; pack.num := -1; RETURN pack; END EdgeBelongsToOriginalFace; PROCEDURE Sign(d: LONGREAL) : BOOLEAN = (* Return TRUE iff the longreal value is positive, FALSE c.c. *) BEGIN (*<* ASSERT d # 0.0d0 *>*) IF d < 0.0d0 THEN RETURN FALSE ELSE RETURN TRUE END; END Sign; PROCEDURE DoIt() = VAR o : Options := GetOptions(); i : CARDINAL; BEGIN WITH tc = Triangulation.ReadToMa(o.inFileTp), top = tc.top, rc4 = Triangulation.ReadState(o.inFileSt), rc3 = NEW(REF Tridimensional.Coords3D, top.NV), c4 = rc4^, c3 = rc3^ DO IF o.normalize THEN Wr.PutText(stderr, "projecting vertices onto the unit S^3\n"); Triangulation.NormalizeVertexDistances(top, c4, o.normalize); END; IF o.autoProject THEN Wr.PutText(stderr, "selecting camera parameters\n"); SelectProjection(o, c4, top); END; Wr.PutText(stderr, "projecting and converting to POV-Ray\n"); IF o.multiple THEN LOOP Lex.Skip(stdin, Lex.Blanks); IF Rd.EOF(stdin) THEN EXIT END; i := Lex.Int(stdin); o.From4[0] := Lex.LongReal(stdin); o.From4[1] := Lex.LongReal(stdin); o.From4[2] := Lex.LongReal(stdin); o.From4[3] := Lex.LongReal(stdin); Lex.Skip(stdin, Lex.Blanks); o.selectTxt := Lex.Scan(stdin); IF Text.Equal(o.selectTxt, "back") THEN o.select := Side.Back; ELSIF Text.Equal(o.selectTxt, "front") THEN o.select := Side.Front; ELSIF Text.Equal(o.selectTxt, "both") THEN o.select := Side.Both; ELSE Wr.PutText(stderr, "Bad shape \"" & o.selectTxt & "\"\n"); Process.Exit(1) END; ProjectTo3D(o, c4, c3, top); WITH itx = Fmt.Pad(Fmt.Int(i), 4, '0') DO WritePOV(o.outFile & "-" & o.selectTxt & "-" & itx, top, c3, c4, o) END END ELSE ProjectTo3D(o, c4, c3, top); WritePOV(o.outFile & "-" & o.selectTxt, top, c3, c4, o) END END END DoIt; PROCEDURE WritePOV( name: TEXT; READONLY top: Topology; READONLY c3: Tridimensional.Coords3D; READONLY c4: Coords; READONLY o: Options; ) = <* FATAL Wr.Failure, Thread.Alerted, OSError.E *> BEGIN WITH wr = FileWr.Open(name & ".inc") DO Wr.PutText(wr, "// Include File: <" & name & ".inc>\n"); DoWritePOV(wr, top, c3, c4, o); Wr.Close(wr) END END WritePOV; PROCEDURE DoWritePOV( wr: Wr.T; READONLY top: Topology; READONLY c3: Tridimensional.Coords3D; READONLY c: Coords; READONLY o: Options; ) = VAR vseen := NEW(REF ARRAY OF BOOLEAN, top.NV); (* stack for vertices *) eseen := NEW(REF ARRAY OF BOOLEAN, top.NE); (* stack for edges *) fseen := NEW(REF ARRAY OF BOOLEAN, top.NF); (* stack for faces *) quad : REF ARRAY OF Quad; PROCEDURE IsFront(q: Quad) : BOOLEAN = BEGIN WITH u = LR4.Sub(c[q.u],cb), v = LR4.Sub(c[q.v],cb), w = LR4.Sub(c[q.w],cb), x = LR4.Sub(c[q.x],cb), d1 = LR4Extras.Det(u,v,w,x), u_ = LR4.Sub(c[q.u],o.From4), v_ = LR4.Sub(c[q.v],o.From4), w_ = LR4.Sub(c[q.w],o.From4), x_ = LR4.Sub(c[q.x],o.From4), d2 = LR4Extras.Det(u_,v_,w_,x_) DO RETURN (Sign(d1) AND NOT Sign(d2)) OR ( NOT Sign(d1) AND Sign(d2)) END END IsFront; PROCEDURE FindOrientR3(q: Quad) : LONGREAL = BEGIN WITH a = LR4.T{c3[q.u][0], c3[q.u][1], c3[q.u][2], 1.0d0}, b = LR4.T{c3[q.v][0], c3[q.v][1], c3[q.v][2], 1.0d0}, c = LR4.T{c3[q.w][0], c3[q.w][1], c3[q.w][2], 1.0d0}, d = LR4.T{c3[q.x][0], c3[q.x][1], c3[q.x][2], 1.0d0} DO RETURN LR4Extras.Det(a,b,c,d); END END FindOrientR3; PROCEDURE IsSilhouette(a: Pair) : BOOLEAN = (* Return TRUE iff the face associated to the pair "a" is a silhouette face, FALSE c.c. *) BEGIN WITH t = TetraNegPosVertices(a), un = t[0].num, vn = t[1].num, wn = t[2].num, xn = t[3].num, yn = t[4].num, t1 = Quad{un,vn,wn,xn}, t2 = Quad{un,vn,wn,yn}, d1 = FindOrientR3(t1), d2 = FindOrientR3(t2) DO RETURN (Sign(d1) AND Sign(d2)) OR (NOT Sign(d1) AND NOT Sign(d2)) END END IsSilhouette; PROCEDURE WritePOVVertex(s: Triangulation.Vertex; fade: REAL; fbTag: TEXT) = VAR dimTag: TEXT; BEGIN WITH ff = FLOAT(fade, LONGREAL), ts = s.transp, ts = (ts[0] + ts[1] + ts[2]) / 3.0 * fade, tc = R3.Mix(ff, s.color, 1.0d0 - ff, R3.T{0.5,0.5,0.5}) DO IF (s.exists) AND NOT vseen[s.num] THEN IF Text.Equal(s.label, "VV") THEN dimTag := "vertex" ELSE dimTag := "edge" END; WritePOVSphere(wr, c3[s.num], s.radius, tc, ts, TRUE, dimTag, fbTag); vseen[s.num] := TRUE END END END WritePOVVertex; PROCEDURE WritePOVFace(t: Triangulation.Face; fade: REAL; fbTag: TEXT) = BEGIN WITH ff = FLOAT(fade, LONGREAL), ts = t.transp, ts = (ts[0] + ts[1] + ts[2]) / 3.0 * fade, tc = R3.Mix(ff, t.color, 1.0d0 - ff, R3.T{0.5,0.5,0.5}), a = t.pa, b = Enext(a), c = Enext(b), v0 = OrgV(a).num, v1 = OrgV(b).num, v2 = OrgV(c).num DO IF t.exists AND NOT fseen[t.num] THEN WritePOVTriangle(wr, c3[v0], c3[v1], c3[v2], tc, ts, TRUE, "face", fbTag); fseen[t.num] := TRUE END END END WritePOVFace; PROCEDURE WritePOVSilhouetteFace(t: Triangulation.Face) = BEGIN WITH ts = 0.99, tc = R3.T{1.00, 0.99, 0.99}, a = t.pa, b = Enext(a), c = Enext(b), v0 = OrgV(a).num, v1 = OrgV(b).num, v2 = OrgV(c).num DO WritePOVTriangle(wr, c3[v0], c3[v1], c3[v2], tc, ts, o.filter, "face", "silhouette"); END END WritePOVSilhouetteFace; PROCEDURE WritePOVEdge(a: Triangulation.Edge; fade: REAL; color: Color; fbTag: TEXT) = BEGIN WITH ff = FLOAT(fade, LONGREAL), ts = a.transp, ts = (ts[0] + ts[1] + ts[2]) / 3.0 * fade, tc = R3.Mix(ff, color, 1.0d0 - ff, R3.T{0.5,0.5,0.5}), v0 = OrgV(a.pa).num, v1 = OrgV(Clock(a.pa)).num DO IF (a.exists) AND NOT eseen[a.num] THEN WritePOVCylinder(wr, c3[v0], c3[v1], a.radius, tc, ts, o.filter, "edge", fbTag); eseen[a.num] := TRUE END; END END WritePOVEdge; PROCEDURE WriteEdgeColored(e: Triangulation.Edge) = (* draws one colored edge. *) BEGIN WITH a = e.pa DO IF e.exists AND EdgeBelongsToOriginalFace(a,top).belong THEN (* an edge on the net belonging to some original face *) WITH facc = EdgeBelongsToOriginalFace(a,top).num, froot = top.face[facc].root DO WritePOVEdge(e, fadeFactor, fac[froot], "Net"); END; ELSIF e.exists AND NOT EdgeBelongsToOriginalFace(a,top).belong THEN (* an edge of the map *) WritePOVEdge(e, fadeFactor, e.color, "Map"); END END END WriteEdgeColored; VAR isFront: BOOLEAN; fadeFactor: REAL; textureTag: TEXT; cb: LR4.T; palette : ARRAY[0..5] OF Color; max : CARDINAL := 0; fac : REF ARRAY OF Color; (* the face colors to use *) <* FATAL Wr.Failure, Thread.Alerted *> BEGIN cb := Barycenter(top,c,TRUE); quad := NEW(REF ARRAY OF Quad, top.NP); FOR i := 0 TO LAST(vseen^) DO vseen[i] := FALSE END; FOR i := 0 TO LAST(fseen^) DO fseen[i] := FALSE END; FOR i := 0 TO LAST(eseen^) DO eseen[i] := FALSE END; IF o.colored THEN (* computing the original number faces *) FOR i := 0 TO top.NF-1 DO WITH f = top.face[i] DO IF f.exists THEN max := MAX(max,f.root); END END END; PutText(stderr,"The original number faces is " & Fmt.Int(max+1)&"\n"); fac := NEW(REF ARRAY OF Color,max+1); (* defining the palette colors with brightness aprox. 0.7 *) palette[0] := Color{1.00,0.50,1.00}; palette[1] := Color{0.00,1.00,1.00}; palette[2] := Color{0.80,0.80,0.00}; palette[3] := Color{1.00,0.60,0.60}; palette[4] := Color{0.25,1.00,0.25}; palette[5] := Color{0.70,0.70,1.00}; (* attribution of differents colors for each original face *) FOR j := 0 TO max DO fac[j] := palette[j MOD 6]; END; FOR i := 0 TO top.NF-1 DO WITH f = top.face[i] DO IF f.exists THEN WITH froot = f.root DO f.color := fac[froot] END END END END END; FOR i := 0 TO top.NP-1 DO WITH da = top.region[i], a0 = Tors(da), db = Clock(Enext_1(da)), b0 = Tors(db), a1 = Enext(a0), a2 = Enext(a1), un = OrgV(a0).num, vn = OrgV(a1).num, wn = OrgV(a2).num, xn = OrgV(Enext_1(b0)).num DO quad[i] := Quad{un,vn,wn,xn}; isFront := IsFront(quad[i]); IF o.detail THEN Wr.PutText(stderr,"Tetrahedron " & Fmt.Int(i) & " on "); END; IF (isFront AND o.select # Side.Back) OR (NOT isFront AND o.select # Side.Front) THEN IF o.detail THEN Wr.PutText(stderr, "isFront = " & Fmt.Int(ORD(isFront)) & "\n"); END; IF o.fade AND NOT isFront THEN fadeFactor := 0.5; textureTag := "back" ELSE fadeFactor := 1.0; textureTag := "front" END; WITH ri = top.region[i], a = Tors(ri), db = Clock(Enext_1(ri)), b0 = Tors(db), a1 = Enext(a), a2 = Enext(a1), v0 = OrgV(a).num, v1 = OrgV(a1).num, v2 = OrgV(a2).num, v3 = OrgV(Enext_1(b0)).num, s0 = top.vertex[v0], s1 = top.vertex[v1], s2 = top.vertex[v2], s3 = top.vertex[v3], (* faces *) faces = Triangulation.TetraFaces(a), f0 = faces[0].num, f1 = faces[1].num, f2 = faces[2].num, f3 = faces[3].num, t0 = top.face[f0], t1 = top.face[f1], t2 = top.face[f2], t3 = top.face[f3], (* edges *) edges = Triangulation.TetraEdges(a), e0 = edges[0].num, e1 = edges[1].num, e2 = edges[2].num, e3 = edges[3].num, e4 = edges[4].num, e5 = edges[5].num, a0 = top.edge[e0], a1 = top.edge[e1], a2 = top.edge[e2], a3 = top.edge[e3], a4 = top.edge[e4], a5 = top.edge[e5], dc = R3.T{1.00,1.000,0.500} (* default color por edge net *) DO WritePOVVertex(s0, fadeFactor, textureTag); WritePOVVertex(s1, fadeFactor, textureTag); WritePOVVertex(s2, fadeFactor, textureTag); WritePOVVertex(s3, fadeFactor, textureTag); (* write faces *) IF NOT o.wire THEN WritePOVFace(t0, fadeFactor, textureTag); WritePOVFace(t1, fadeFactor, textureTag); WritePOVFace(t2, fadeFactor, textureTag); WritePOVFace(t3, fadeFactor, textureTag); END; IF NOT o.colored THEN (* write edges *) IF a0.root # -1 THEN WritePOVEdge(a0, fadeFactor, a0.color, textureTag); ELSE WritePOVEdge(a0, fadeFactor, dc, "Net"); END; IF a1.root # -1 THEN WritePOVEdge(a1, fadeFactor, a1.color, textureTag); ELSE WritePOVEdge(a1, fadeFactor, dc, "Net"); END; IF a2.root # -1 THEN WritePOVEdge(a2, fadeFactor, a2.color, textureTag); ELSE WritePOVEdge(a2, fadeFactor, dc, "Net"); END; IF a3.root # -1 THEN WritePOVEdge(a3, fadeFactor, a3.color, textureTag); ELSE WritePOVEdge(a3, fadeFactor, dc, "Net"); END; IF a4.root # -1 THEN WritePOVEdge(a4, fadeFactor, a4.color, textureTag); ELSE WritePOVEdge(a4, fadeFactor, dc, "Net"); END; IF a5.root # -1 THEN WritePOVEdge(a5, fadeFactor, a5.color, textureTag); ELSE WritePOVEdge(a5, fadeFactor, dc, "Net"); END; ELSE WriteEdgeColored(a0); WriteEdgeColored(a1); WriteEdgeColored(a2); WriteEdgeColored(a3); WriteEdgeColored(a4); WriteEdgeColored(a5); END END ELSE IF o.detail THEN Wr.PutText(stderr, "front = " & Fmt.Int(ORD(isFront)) & "\n"); END END END END; IF o.silhouette THEN FOR i := 0 TO top.NF-1 DO WITH f = top.face[i] DO IF NOT f.exists THEN WITH a = f.pa DO IF IsSilhouette(a) THEN IF o.detail THEN Wr.PutText(stderr, "Silhouette face: " & Fmt.Int(i) & "\n"); END; WritePOVSilhouetteFace(f) END END END END END END; END DoWritePOV; PROCEDURE ProjectTo3D( READONLY o: Options; READONLY c: Coords; VAR c3: Tridimensional.Coords3D; READONLY top: Topology ) = <* FATAL Wr.Failure, Thread.Alerted *> PROCEDURE CalcV4Matrix() = (* This procedure computes the four basis vectors for the 4D viewing matrix, Wa,Wb,Wc, and Wd. Note that the Up vector transforms to Wb, the Over vector transforms to Wc, and the line of sight transforms to Wd. The Wa vector is then computed from Wb,Wc and Wd. *) BEGIN (* Calculate Wd, the 4th coordinate basis vector and line-of-sight. *) Wd := LR4.Sub(o.To4,o.From4); norm := LR4.Norm(Wd); IF norm < Epsilon THEN Wr.PutText(stderr,"4D To Point and From Point are the same\n"); Process.Exit(1); END; Wd := LR4.Scale(1.0d0/norm, Wd); (* Calculate Wa, the X-axis basis vector. *) Wa := LR4Extras.Cross(o.Up4,o.Over4,Wd); norm := LR4.Norm(Wa); IF norm < Epsilon THEN Wr.PutText(stderr, "4D up,over and view vectors are not perpendicular\n"); Process.Exit(1); END; Wa := LR4.Scale(1.0d0/norm, Wa); (* Calculate Wb, the perpendicularized Up vector. *) Wb := LR4Extras.Cross(o.Over4,Wd,Wa); norm := LR4.Norm(Wb); IF norm < Epsilon THEN Wr.PutText(stderr,"Invalid 4D over vector\n"); Process.Exit(1); END; Wb := LR4.Scale(1.0d0/norm, Wb); (* Calculate Wc, the perpendicularized Over vector. Note that the resulting vector is already normalized, since Wa, Wb and Wd are all unit vectors. *) Wc := LR4Extras.Cross(Wd,Wa,Wb); END CalcV4Matrix; VAR Tan2Vangle4, Data4Radius, pconst, rtemp, depth: LONGREAL; TempV : LR4.T; Wa,Wb,Wc,Wd : LR4.T; norm : LONGREAL; BEGIN WITH angle = o.Vangle4/2.0d0, angler = (FLOAT(Math.Pi,LONGREAL)*angle)/180.0d0 DO Tan2Vangle4 := Math.tan(angler); END; (* Find the radius of the 4D data. The radius of the 4D data is the radius of the smallest enclosing sphere, centered at the To point. Note that during the loop through the vertices, Data4Radius holds the squared radius value. *) Data4Radius := 0.0d0; FOR i := 0 TO top.NV-1 DO WITH v = top.vertex[i], Temp4 = LR4.Sub(c[v.num],o.To4), dist = LR4.Dot(Temp4,Temp4) DO IF dist > Data4Radius THEN Data4Radius := dist; END END END; Data4Radius := Math.sqrt(Data4Radius); Wr.PutText(stderr,"Data4Radius: "& Fmt.Pad(Fmt.LongReal(Data4Radius, Fmt.Style.Fix, prec := 4),8)&"\n"); CalcV4Matrix(); IF o.perspective THEN pconst := 1.0d0 / Tan2Vangle4; ELSE rtemp := 1.0d0 / Data4Radius; END; FOR i := 0 TO top.NV-1 DO (* Transform the vertices from 4d World coordinates to 4D eye coordinates. *) WITH v = top.vertex[i] DO TempV := LR4.Sub(c[v.num],o.From4); depth := LR4.Dot(TempV,Wd); IF o.perspective THEN rtemp := pconst / depth; END; c3[v.num][0] := rtemp * LR4.Dot(TempV, Wa); c3[v.num][1] := rtemp * LR4.Dot(TempV, Wb); c3[v.num][2] := rtemp * LR4.Dot(TempV, Wc); END END END ProjectTo3D; PROCEDURE SelectProjection( VAR o: Options; READONLY c: Coords; READONLY top: Topology ) = VAR norm: LR4.T := LR4.T{0.0d0, ..}; BEGIN FOR i := 0 TO top.NP-1 DO WITH f = top.region[i], k = Triangulation.TetraNegVertices(f), p = c[k[0].num], q = c[k[1].num], r = c[k[2].num], s = c[k[3].num], pq = LR4.Sub(q, p), pr = LR4.Sub(r, p), ps = LR4.Sub(s, p), v = LR4Extras.Cross(pq, pr, ps), n = LR4.Dir(v) DO norm := LR4.Add(norm, n) END END; WITH m = LR4.Norm(norm) DO IF m < 1.0d-20 THEN norm := LR4.T{1.0d0, 0.0d0, ..} ELSE norm := LR4.Scale(1.0d0/m, norm) END END; WITH bar = Barycenter(top,c,TRUE) DO o.To4 := bar; o.From4 := LR4.Add(o.To4, norm); SelectTwoIndepDirs(norm, o.Up4, o.Over4); o.Vangle4 := 120.0d0; END; END SelectProjection; PROCEDURE SelectTwoIndepDirs( READONLY u: LR4.T; VAR v, w: LR4.T; ) = (* Selects two vectors "v", "w", independent of each other and of the given vector "u". *) VAR m: CARDINAL := 0; BEGIN (* Find the largest coordinate of "u": *) FOR i := 1 TO 3 DO IF ABS(u[i]) > ABS(u[m]) THEN m := i END END; FOR i := 0 TO 3 DO v[i] := 0.0d0; w[i] := 0.0d0 END; v[(m+1) MOD 4] := 1.0d0; w[(m+2) MOD 4] := 1.0d0; END SelectTwoIndepDirs; PROCEDURE GetOptions (): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFileTp"); o.inFileTp := pp.getNext(); pp.getKeyword("-inFileSt"); o.inFileSt := pp.getNext(); IF pp.keywordPresent("-outFile") THEN o.outFile := pp.getNext() ELSE o.outFile := o.inFileTp END; o.fade := pp.keywordPresent("-fade"); o.wire := pp.keywordPresent("-wire"); o.detail := pp.keywordPresent("-detail"); o.filter := pp.keywordPresent("-filter"); IF pp.keywordPresent("-silhouette") THEN o.silhouette := TRUE; END; pp.getKeyword("-projection"); WITH pname = pp.getNext() DO IF Text.Equal(pname, "parallel") THEN o.perspective := FALSE; ELSIF Text.Equal(pname, "perspective") THEN o.perspective := TRUE; ELSE pp.error("Bad projection \"" & pname & "\"\n"); END END; IF pp.keywordPresent("-normalize") THEN o.normalize := TRUE; ELSE o.normalize := FALSE; END; IF pp.keywordPresent("-autoProject") THEN (* Program chooses From4: *) o.autoProject := TRUE; o.multiple := FALSE; ELSE (* User may give "From4" *) o.autoProject := FALSE; o.multiple := pp.keywordPresent("-multiple"); IF o.multiple THEN (* Multiple From4"s will be read from stdin *) o.From4 := LR4.T{0.0d0,0.0d0,0.0d0,0.0d0} ELSE (* User may give single From4 option, or take default *) IF pp.keywordPresent("-From4") THEN FOR j := 0 TO 3 DO o.From4[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.From4 := LR4.T{100.0d0,50.0d0,20.0d0,0.0d0} END END END; IF NOT o.multiple THEN pp.getKeyword("-select"); o.selectTxt := pp.getNext(); IF Text.Equal(o.selectTxt, "back") THEN o.select := Side.Back; ELSIF Text.Equal(o.selectTxt, "front") THEN o.select := Side.Front; ELSIF Text.Equal(o.selectTxt, "both") THEN o.select := Side.Both; ELSE pp.error("Bad shape \"" & o.selectTxt & "\"\n"); END END; IF pp.keywordPresent("-To4") THEN FOR j := 0 TO 3 DO o.To4[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.To4 := LR4.T{0.0d0,0.0d0,0.0d0,0.0d0}; END; IF pp.keywordPresent("-Up4") THEN FOR j := 0 TO 3 DO o.Up4[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.Up4 := LR4.T{0.0d0,1.0d0,0.0d0,0.0d0}; END; IF pp.keywordPresent("-Over4") THEN FOR j := 0 TO 3 DO o.Over4[j] := pp.getNextLongReal(-100.0d0, 100.0d0); END; ELSE o.Over4 := LR4.T{0.0d0,0.0d0,1.0d0,0.0d0}; END; IF pp.keywordPresent("-Vangle4") THEN o.Vangle4 := pp.getNextLongReal(1.0d0, 179.0d0); ELSE o.Vangle4 := 25.0d0; END; IF pp.keywordPresent("-colored") THEN o.colored := TRUE; ELSE o.colored := FALSE; END; pp.finish(); EXCEPT | ParseParams.Error => PutText(stderr,"Usage: Visibility \\\n"); PutText(stderr," -inFileTp \\\n"); PutText(stderr," -inFileSt -outFile \\\n"); PutText(stderr," -select [back | front | both] [-fade]\\\n"); PutText(stderr," [ -wire ] [ -detail ] [-filter ] \\\n"); PutText(stderr," [ -silhouette ] [-normalize ] \\\n"); PutText(stderr," -projection [ perspective | parallel ]\\\n"); PutText(stderr," [ [ -autoProject ] | \\\n"); PutText(stderr," [ -From4 ] \\\n"); PutText(stderr," [ -To4 ] \\\n"); PutText(stderr," [ -Up4 ] \\\n"); PutText(stderr," [ -Over4 ] \\\n"); PutText(stderr," ] \\\n"); PutText(stderr," [ -Vangle4 ] [ -colored ]\n"); Process.Exit (1); END END; RETURN o END GetOptions; BEGIN DoIt(); END Visibility. (**************************************************************************) (* *) (* Copyright (C) 2001 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/Volume.m3 (* Programa para testar o volume de um tetraedro no R4 Mediante o uso do produto vetorial e mediante as coordenadas de seus vertices que o definem *) MODULE Volume EXPORTS Main; IMPORT Stdio, Wr, LR4, LR4Extras, Fmt, Thread, Math; PROCEDURE CalVol(READONLY p1,p2,p3,p4: LR4.T) : LONGREAL = VAR d1,d2,d3,d4,vol : LONGREAL; BEGIN WITH l1 = LR4.T{p1[0],p1[1],p1[2],1.0d0}, l2 = LR4.T{p2[0],p2[1],p2[2],1.0d0}, l3 = LR4.T{p3[0],p3[1],p3[2],1.0d0}, l4 = LR4.T{p4[0],p4[1],p4[2],1.0d0}, l5 = LR4.T{p1[0],p1[1],p1[3],1.0d0}, l6 = LR4.T{p2[0],p2[1],p2[3],1.0d0}, l7 = LR4.T{p3[0],p3[1],p3[3],1.0d0}, l8 = LR4.T{p4[0],p4[1],p4[3],1.0d0}, l9 = LR4.T{p1[1],p1[2],p1[3],1.0d0}, l10 = LR4.T{p2[1],p2[2],p2[3],1.0d0}, l11 = LR4.T{p3[1],p3[2],p3[3],1.0d0}, l12 = LR4.T{p4[1],p4[2],p4[3],1.0d0}, l13 = LR4.T{p1[0],p1[2],p1[3],1.0d0}, l14 = LR4.T{p2[0],p2[2],p2[3],1.0d0}, l15 = LR4.T{p3[0],p3[2],p3[3],1.0d0}, l16 = LR4.T{p4[0],p4[2],p4[3],1.0d0} DO d1 := LR4Extras.Det(l1,l2,l3,l4); d2 := LR4Extras.Det(l5,l6,l7,l8); d3 := LR4Extras.Det(l9,l10,l11,l12); d4 := LR4Extras.Det(l13,l14,l15,l16); vol := 1.0d0/6.0d0 * Math.sqrt(d1*d1+d2*d2+d3*d3+d4*d4); RETURN vol; END; END CalVol; /* VAR p1,p2,p3,p4,A,B,C,n : LR4.T; vol,vol1 : LONGREAL; <* FATAL Wr.Failure, Thread.Alerted *> */ VAR a,b,c,d : LONGREAL; BEGIN a := 79.05; b := 201.45; c := 38.25; d := 142.8; Wr.PutText(Stdio.stdout, Fmt.Int(ROUND(a)) & Fmt.Int(ROUND(b)) & Fmt.Int(ROUND(c)) & Fmt.Int(ROUND(d)) & "\n"); /* p1 := LR4.T{ 1.0000d001, 1.00000d01, 1.0000d01, 1.000d001}; p2 := LR4.T{ 3.0000d001, 3.0000d001, 3.000d000, 3.000d000}; p3 := LR4.T{-0.1470d001, -0.7930d001, 0.663d001, -0.000d002}; p4 := LR4.T{-0.0000d005, -0.6770d001, 0.700d002, -0.273d001}; vol := CalVol(p1,p2,p3,p4); Wr.PutText(Stdio.stdout, "V. em funcao das coordenadas dos seus vertices extremos: " & Fmt.LongReal(vol, Fmt.Style.Fix,prec := 2) & "\n"); A := LR4.Sub(p2,p1); B := LR4.Sub(p4,p1); C := LR4.Sub(p3,p2); n := LR4Extras.Cross(A,B,C); vol1 := 1.0d0/6.0d0 * LR4.Norm(n); Wr.PutText(Stdio.stdout, "V. em f. do produto vetorial dos vertices extremos: " & Fmt.LongReal(vol1, Fmt.Style.Fix,prec := 2) & "\n"); */ END Volume. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/WhatAttributes.m3 MODULE WhatAttributes EXPORTS Main; (* Program to find what type of geometric degeneration exists in a given arbitrary topology (triangulation or not). The "detail" option allows to print detail information about the degeneracies. Otherwise only an abstract information is printed. Created by L. Lozada (see notice of copyright at the end of this file). Last modification: 2000-06-08: Includind the number of original vertices *) IMPORT Triangulation, Stdio, Wr, Thread, Process, ParseParams, Fmt, Text; FROM Stdio IMPORT stderr; FROM Wr IMPORT PutText; VAR nve,nee,nfe,npe: CARDINAL := 0; TYPE Options = RECORD inFile: TEXT; detail: BOOLEAN; END; (* Initial guess file name (minus ".tp") *) PROCEDURE DoIt() = <* FATAL Thread.Alerted, Wr.Failure *> BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToMa(o.inFile), top = tc.top DO (* Clean the marks for the attribute degenerate *) FOR i := 0 TO top.NV-1 DO WITH vi = top.vertex[i] DO IF Text.Equal(vi.label, "VV") THEN INC(nve) END ; END END; FOR i := 0 TO top.NE-1 DO WITH ei = top.edge[i] DO IF ei.exists THEN INC(nee) END ; END END; FOR i := 0 TO top.NF-1 DO WITH fi = top.face[i] DO IF fi.exists THEN INC(nfe) END END END; FOR i := 0 TO top.NP-1 DO WITH pi = top.polyhedron[i] DO IF pi.exists THEN INC(npe) END END END; PutText(stderr,"there are "&Fmt.Int(nve)&" existing vertices\n"); PutText(stderr,"there are "&Fmt.Int(nee)&" existing edges\n"); PutText(stderr,"there are "&Fmt.Int(nfe)&" existing faces\n"); PutText(stderr,"there are "&Fmt.Int(npe)&" existing polyhedra\n"); END END DoIt; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFile"); o.inFile := pp.getNext(); o.detail := pp.keywordPresent("-detail"); pp.finish(); EXCEPT | ParseParams.Error => PutText(stderr, "Usage: WhatAttributes" ); PutText(stderr, " -inFile [ -detail ]\n" ); Process.Exit(1); END END; RETURN o END GetOptions; BEGIN DoIt() END WhatAttributes. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ latest/progs/WhatDegenerations.m3 (* Program to find what type of geometric degeneration exists in a given arbitrary topology (triangulation or not). The "detail" option allows to print detail information about the degeneracies. Otherwise only an abstract information is printed. Created by L. Lozada (see notice of copyright at the end of this file). Last modification: 07-02-2000 *) MODULE WhatDegenerations EXPORTS Main; IMPORT Triangulation, Stdio, Wr, Thread, Process, ParseParams, Mis, Fmt, Octf; FROM Stdio IMPORT stderr; FROM Triangulation IMPORT Edge, Face, Polyhedron, OrgV; FROM Wr IMPORT PutText; FROM Octf IMPORT Enext, Tors, Clock; CONST InitStackSize = 1024; VAR estack := NEW(REF ARRAY OF Edge, InitStackSize); estackT := NEW(REF ARRAY OF Edge, InitStackSize); estackF := NEW(REF ARRAY OF Edge, InitStackSize); fstack := NEW(REF ARRAY OF Face, InitStackSize); fstackT := NEW(REF ARRAY OF Face, InitStackSize); fstackF := NEW(REF ARRAY OF Face, InitStackSize); pstack := NEW(REF ARRAY OF Polyhedron, InitStackSize); etop,etopT,etopF,ftop,ftopT,ftopF,ptop,eetop,fftop,pptop: CARDINAL := 0; TYPE Options = RECORD inFile: TEXT; detail: BOOLEAN; END; (* Initial guess file name (minus ".tp") *) PROCEDURE DoIt() = <* FATAL Thread.Alerted, Wr.Failure *> VAR edges,faces,polyhedra: BOOLEAN := FALSE; e1,e2,f1,f2,p1,p2: REF ARRAY OF INTEGER; BEGIN WITH o = GetOptions(), tc = Triangulation.ReadToMa(o.inFile), top = tc.top DO (* Clean the marks for the attribute degenerate *) FOR i := 0 TO top.NE-1 DO deg[i] := FALSE END; FOR i := 0 TO top.NE-1 DO FOR j := i+1 TO top.NE-1 DO WITH ei = NARROW(top.edge[i], Edge), ej = NARROW(top.edge[j], Edge), ei0 = ei.vertex[0].num, ei1 = ei.vertex[1].num, ej0 = ej.vertex[0].num, ej1 = ej.vertex[1].num DO e1 := NEW(REF ARRAY OF INTEGER, 2); e1[0] := ei0; e1[1] := ei1; Mis.InsertionSort(1,e1); e2 := NEW(REF ARRAY OF INTEGER, 2); e2[0] := ej0; e2[1] := ej1; Mis.InsertionSort(1,e2); IF (e1[0] = e2[0]) AND (e1[1] = e2[1]) THEN IF NOT deg[i] THEN deg[i] := TRUE; estack[etop] := ei; INC(etop); IF ei.exists THEN estackT[etopT] := ei; INC(etopT); ELSE estackF[etopF] := ei; INC(etopF); END END; IF NOT deg[j] THEN deg[j] := TRUE; estack[etop] := ej; INC(etop); IF ej.exists THEN estackT[etopT] := ej; INC(etopT); ELSE estackF[etopF] := ej; INC(etopF); END END; edges := TRUE; END END END END; (* Clean the marks for the attribute degenerate *) FOR i := 0 TO top.NF-1 DO fdeg[i] := FALSE END; IF top.der = 3 THEN FOR i := 0 TO top.NF-1 DO FOR j := i+1 TO top.NF-1 DO WITH fi = top.face[i], fj = top.face[j], fi0 = fi.vertex^[0].num, fi1 = fi.vertex^[1].num, fi2 = fi.vertex^[2].num, fj0 = fj.vertex^[0].num, fj1 = fj.vertex^[1].num, fj2 = fj.vertex^[2].num DO f1 := NEW(REF ARRAY OF INTEGER, 3); f1[0] := fi0; f1[1] := fi1; f1[2] := fi2; Mis.InsertionSort(2,f1); f2 := NEW(REF ARRAY OF INTEGER, 3); f2[0] := fj0; f2[1] := fj1; f2[2] := fj2; Mis.InsertionSort(2,f2); IF (f1[0] = f2[0]) AND (f1[1] = f2[1]) AND (f1[2] = f2[2]) THEN IF NOT fdeg[i] THEN fdeg[i] := TRUE; fstack[ftop] := fi; INC(ftop); IF fi.exists THEN fstackT[ftopT] := fi; INC(ftopT); ELSE fstackF[ftopF] := fi; INC(ftopF); END END; IF NOT fdeg[j] THEN fdeg[j] := TRUE; fstack[ftop] := fj; INC(ftop); IF fj.exists THEN fstackT[ftopT] := fj; INC(ftopT); ELSE fstackF[ftopF] := fj; INC(ftopF); END END; faces := TRUE; END END END END; ELSIF top.der = 4 THEN FOR i := 0 TO top.NF-1 DO FOR j := i+1 TO top.NF-1 DO WITH fi = top.face[i], fj = top.face[j], fi0 = fi.vertex^[0].num, fi1 = fi.vertex^[1].num, fi2 = fi.vertex^[2].num, fi3 = fi.vertex^[3].num, fj0 = fj.vertex^[0].num, fj1 = fj.vertex^[1].num, fj2 = fj.vertex^[2].num, fj3 = fj.vertex^[3].num DO f1 := NEW(REF ARRAY OF INTEGER, 4); f1[0] := fi0; f1[1] := fi1; f1[2] := fi2; f1[3] := fi3; Mis.InsertionSort(3,f1); f2 := NEW(REF ARRAY OF INTEGER, 4); f2[0] := fj0; f2[1] := fj1; f2[2] := fj2; f2[3] := fj3; Mis.InsertionSort(3,f2); IF ((f1[0] = f2[0]) AND (f1[1] = f2[1]) AND (f1[2] = f2[2]) AND (f1[3] = f2[3])) THEN IF NOT fdeg[i] THEN fdeg[i] := TRUE; fstack[ftop] := fi; INC(ftop); END; IF NOT fdeg[j] THEN fdeg[j] := TRUE; fstack[ftop] := fj; INC(ftop); END; faces := TRUE; END END END END; ELSIF top.der = 2 THEN FOR i := 0 TO top.NF-1 DO FOR j := i+1 TO top.NF-1 DO WITH fi = top.face[i], fj = top.face[j], fi0 = fi.vertex^[0].num, fi1 = fi.vertex^[1].num, fj0 = fj.vertex^[0].num, fj1 = fj.vertex^[1].num DO f1 := NEW(REF ARRAY OF INTEGER, 2); f1[0] := fi0; f1[1] := fi1; Mis.InsertionSort(1,f1); f2 := NEW(REF ARRAY OF INTEGER, 2); f2[0] := fj0; f2[1] := fj1; Mis.InsertionSort(1,f2); IF (f1[0] = f2[0]) AND (f1[1] = f2[1]) THEN IF NOT fdeg[i] THEN fdeg[i] := TRUE; fstack[ftop] := fi; INC(ftop); END; IF NOT fdeg[j] THEN fdeg[j] := TRUE; fstack[ftop] := fj; INC(ftop); END; faces := TRUE; END END END END; END; (* Clean the marks for the attribute degenerate *) FOR i := 0 TO top.NP-1 DO pdeg[i] := FALSE END; IF top.der = 3 THEN FOR i := 0 TO top.NP-1 DO FOR j := i+1 TO top.NP-1 DO WITH pi = top.polyhedron[i], pj = top.polyhedron[j], pi0 = pi.vertex^[0].num, pi1 = pi.vertex^[1].num, pi2 = pi.vertex^[2].num, pi3 = pi.vertex^[3].num, pj0 = pj.vertex^[0].num, pj1 = pj.vertex^[1].num, pj2 = pj.vertex^[2].num, pj3 = pj.vertex^[3].num DO p1 := NEW(REF ARRAY OF INTEGER, 4); p1[0] := pi0; p1[1] := pi1; p1[2] := pi2; p1[3] := pi3; Mis.InsertionSort(3,p1); p2 := NEW(REF ARRAY OF INTEGER, 4); p2[0] := pj0; p2[1] := pj1; p2[2] := pj2; p2[3] := pj3; Mis.InsertionSort(3,p2); IF (p1[0]=p2[0]) AND (p1[1]=p2[1]) AND (p1[2]=p2[2]) AND (p1[3]=p2[3]) THEN IF NOT pdeg[i] THEN pdeg[i] := TRUE; pstack[ptop] := pi; INC(ptop); END; IF NOT pdeg[j] THEN pdeg[j] := TRUE; pstack[ptop] := pj; INC(ptop); END; polyhedra := TRUE; END END END END; ELSIF top.der = 4 THEN FOR i := 0 TO top.NP-1 DO FOR j := i+1 TO top.NP-1 DO WITH pi = top.polyhedron[i], pj = top.polyhedron[j], pi0 = pi.vertex^[0].num, pi1 = pi.vertex^[1].num, pi2 = pi.vertex^[2].num, pi3 = pi.vertex^[3].num, pi4 = pi.vertex^[4].num, pi5 = pi.vertex^[5].num, pi6 = pi.vertex^[6].num, pi7 = pi.vertex^[7].num, pj0 = pj.vertex^[0].num, pj1 = pj.vertex^[1].num, pj2 = pj.vertex^[2].num, pj3 = pj.vertex^[3].num, pj4 = pj.vertex^[4].num, pj5 = pj.vertex^[5].num, pj6 = pj.vertex^[6].num, pj7 = pj.vertex^[7].num DO p1 := NEW(REF ARRAY OF INTEGER, 8); p1[0] := pi0; p1[1] := pi1; p1[2] := pi2; p1[3] := pi3; p1[4] := pi4; p1[5] := pi5; p1[6] := pi6; p1[7] := pi7; Mis.InsertionSort(7,p1); p2 := NEW(REF ARRAY OF INTEGER, 8); p2[0] := pj0; p2[1] := pj1; p2[2] := pj2; p2[3] := pj3; p2[4] := pj4; p2[5] := pj5; p2[6] := pj6; p2[7] := pj7; Mis.InsertionSort(7,p2); IF( (p1[0]=p2[0]) AND (p1[1]=p2[1]) AND (p1[2]=p2[2]) AND (p1[3]=p2[3]) AND (p1[4]=p2[4]) AND (p1[5]=p2[5]) AND (p1[6]=p2[6]) AND (p1[7]=p2[7])) THEN IF pdeg[i] THEN pstack[ptop] := pi; INC(ptop); END; IF pdeg[j] THEN pdeg[j] := TRUE; pstack[ptop] := pj; INC(ptop); END; polyhedra := TRUE; END END END END END; IF edges THEN PutText(stderr,"there are " & Fmt.Int(etop) & " edge degeneracies:\n"); PutText(stderr," " & Fmt.Int(etopT) & " existing\n"); PutText(stderr," " & Fmt.Int(etopF) & " not existing\n"); <* ASSERT etop = etopF + etopT *> IF o.detail THEN PutText(stderr,"---------------------------------\n"); PutText(stderr," edge vertex vertex\n"); eetop := etop; WHILE eetop > 0 DO eetop := eetop-1; WITH edge = estack[eetop], en = edge.num, a = edge.pa, v0 = OrgV(a).num, v1 = OrgV(Clock(a)).num DO PutText(stderr, Fmt.Pad(Fmt.Int(en), 4) & ":"); PutText(stderr, Fmt.Pad(Fmt.Int(v0), 6) & " "); PutText(stderr, Fmt.Pad(Fmt.Int(v1), 6) & "\n"); END END END ELSE PutText(stderr,"there aren't edge degeneracies\n"); END; IF faces THEN PutText(stderr,"there are "&Fmt.Int(ftop)&" face degeneracies:\n"); PutText(stderr," " & Fmt.Int(ftopT) & " existing\n"); PutText(stderr," " & Fmt.Int(ftopF) & " not existing\n"); <* ASSERT ftop = ftopF + ftopT *> IF o.detail THEN PutText(stderr,"---------------------------------\n"); PutText(stderr," face edge edge edge\n"); fftop := ftop; WHILE fftop > 0 DO fftop := fftop-1; WITH face = fstack[fftop], fn = face.num, a = face.pa, b = Enext(a), c = Enext(b), e0 = a.facetedge.edge.num, e1 = b.facetedge.edge.num, e2 = c.facetedge.edge.num, i0 = ScanStackEdge(e0), i1 = ScanStackEdge(e1), i2 = ScanStackEdge(e2) DO PutText(stderr, Fmt.Pad(Fmt.Int(fn), 3) & ":"); IF i0 THEN PutText(stderr, Fmt.Pad(Fmt.Int(e0), 6) & "T"); ELSE PutText(stderr, Fmt.Pad(Fmt.Int(e0), 6) & "F"); END; IF i1 THEN PutText(stderr, Fmt.Pad(Fmt.Int(e1), 6)& "T"); ELSE PutText(stderr, Fmt.Pad(Fmt.Int(e1), 6) & "F" ); END; IF i2 THEN PutText(stderr, Fmt.Pad(Fmt.Int(e2), 6) & "T\n"); ELSE PutText(stderr, Fmt.Pad(Fmt.Int(e2), 6) & "F\n"); END END END END ELSE PutText(stderr,"there aren't face degeneracies\n"); END; IF polyhedra THEN PutText(stderr,"there are "&Fmt.Int(ptop)&" polyhedron degeneracies\n"); IF o.detail THEN PutText(stderr,"-------------------------------------\n"); PutText(stderr,"poly face face face face\n"); pptop := ptop; WHILE pptop > 0 DO pptop := pptop-1; WITH polyhedron = pstack[pptop], np = polyhedron.num, p = top.region[np], a = Tors(p), faces = Triangulation.TetraFaces(a), f0 = faces[0].num, f1 = faces[1].num, f2 = faces[2].num, f3 = faces[3].num, i0 = ScanStackFace(f0), i1 = ScanStackFace(f1), i2 = ScanStackFace(f2), i3 = ScanStackFace(f3) DO PutText(stderr, Fmt.Pad(Fmt.Int(np), 3) & ":"); IF i0 THEN PutText(stderr, Fmt.Pad(Fmt.Int(f0), 6) & "T"); ELSE PutText(stderr, Fmt.Pad(Fmt.Int(f0), 6) & "F"); END; IF i1 THEN PutText(stderr, Fmt.Pad(Fmt.Int(f1), 6) & "T"); ELSE PutText(stderr, Fmt.Pad(Fmt.Int(f1), 6) & "F" ); END; IF i2 THEN PutText(stderr, Fmt.Pad(Fmt.Int(f2), 6) & "T"); ELSE PutText(stderr, Fmt.Pad(Fmt.Int(f2), 6) & "F"); END; IF i3 THEN PutText(stderr, Fmt.Pad(Fmt.Int(f3), 6) & "T\n"); ELSE PutText(stderr, Fmt.Pad(Fmt.Int(f3), 6) & "F\n"); END END END END ELSE PutText(stderr,"there aren't polyhedron degeneracies\n"); END END END DoIt; PROCEDURE FindDegeneracies(READONLY top: Topology) = (* Finds geometric degeneracies. Update the attribute "degenerate" of the elements: edge, face and polyhedron. *) VAR estack := NEW(REF ARRAY OF Edge, top.NE); edeg := NEW(REF BOOLS, top.NE); fstack := NEW(REF ARRAY OF Face, top.NF); fdeg := NEW(REF BOOLS, top.NF); pstack := NEW(REF ARRAY OF Polyhedron, top.NP); pdeg := NEW(REF BOOLS, top.NP); etop,ftop,ptop: CARDINAL := 0; BEGIN FindEdgeDegeneracies(top, estack^, etop); FindFaceDegeneracies(top, fstack^, ftop); FindPolyhedronDegeneracies(top. pstack^, ptop); END FindDegeneracies; PROCEDURE FindEdgeDegeneracies( READONLY top: Topology; VAR estack: ARRAY OF Edge; VAR etop: CARDINAL; ) = (* Find pairs of edges with same vertices. *) BEGIN etop := 0; FOR i := 0 TO top.NE-1 DO edeg[i] := FALSE END; FOR i := 0 TO top.NE-1 DO WITH ei = top.edge[i], Edge, ei0 = OrgV(ei).num, ei1 = OrgV(Clock(ei)).num, DO FOR j := i+1 TO top.NE-1 DO WITH ej = top.edge[j], ej0 = OrgV(ej).num, ej1 = OrgV(Clock(ej)).num DO IF (ei0 = ej0 AND ei1 = ej1) OR (ei0 = ej1 AND ei1 = ej0) THEN IF NOT deg[i] THEN deg[i] := TRUE; estack[etop] := ei; INC(etop); END; IF NOT deg[j] THEN deg[j] := TRUE; estack[etop] := ej; INC(etop); END END END END END END END FindEdgeDegeneracies; PROCEDURE FindFaceDegeneracies( READONLY top: Topology; VAR fstack: ARRAY OF Face; VAR ftop: CARDINAL; ) = (* Find pairs of faces with same vertices *) VAR rvfi, rvfj: REF ARRAY OF CARDINAL; dgi, dgj: CARDINAL; BEGIN ftop := 0; FOR i := 0 TO top.NF-1 DO fdeg[i] := FALSE END; FOR i := 0 TO top.NF-1 DO CollectFaceVertices(top.face[i], rvfi, dgi); WITH fi = top.face[i], vfi = SUBARRAY(rvfi^, 0, dgi) DO Mis.SortCardinals(vfi); FOR j := i+1 TO top.NF-1 DO CollectFaceVertices(top.face[j], rvfj, dgj); WITH fj = top.face[j], vfj = SUBARRAY(rvfj^, 0, dgj) DO Mis.SortCardinals(vfj); IF vfi = vfj THEN IF NOT fdeg[i] THEN fdeg[i] := TRUE; fstack[ftop] := fi; INC(ftop); END; IF NOT fdeg[j] THEN fdeg[j] := TRUE; fstack[ftop] := fj; INC(ftop); END END END END END END; END FindFaceDegeneracies; PROCEDURE FindPolyhedronDegeneracies( READONLY top: Topology; VAR pstack: ARRAY OF Polyhedron; VAR ptop: CARDINAL; ) = (* Finds pairs of polyhedra with same vertices. *) VAR rvpi, rvpj: REF ARRAY OF CARDINAL; dgi, dgj: CARDINAL; BEGIN ptop := 0; FOR i := 0 TO top.NP-1 DO pdeg[i] := FALSE END; ClearXMarks(top); FOR i := 0 TO top.NP-1 DO WITH ai = Tors(top.region[i]), pi = PnegP(ai) DO <* ASSERT pi.num = i *> CollectPolyhedronVertices(ai, rvpi, dgi); WITH vpi = SUBARRAY(rvpi^, 0, dgi) DO Mis.SortCardinals(vpi); FOR j := i+1 TO top.NP-1 DO WITH aj = Tors(top.region[j]), pj = PnegP(aj) DO <* ASSERT pj.num = j *> CollectPolyhedronVertices(aj, rvpj, dgj); WITH vpj = SUBARRAY(rvpj^, 0, dgj) DO Mis.SortCardinals(vpj); IF vpi = vpj THEN IF NOT pdeg[i] THEN pdeg[i] := TRUE; pstack[ptop] := pi; INC(ptop); END; IF NOT pdeg[j] THEN pdeg[j] := TRUE; pstack[ptop] := pj; INC(ptop); END; END END END END END END END END FindDegeneratePolyhedra; PROCEDURE GetOptions(): Options = <* FATAL Thread.Alerted, Wr.Failure *> VAR o: Options; BEGIN WITH pp = NEW(ParseParams.T).init(stderr) DO TRY pp.getKeyword("-inFile"); o.inFile := pp.getNext(); o.detail := pp.keywordPresent("-detail"); pp.finish(); EXCEPT | ParseParams.Error => PutText(stderr, "Usage: WhatDegenerations" ); PutText(stderr, " -inFile [ -detail ]\n" ); Process.Exit(1); END END; RETURN o END GetOptions; PROCEDURE ScanStackEdge(n: CARDINAL): BOOLEAN = VAR counter: CARDINAL := 0; BEGIN counter := etop; WHILE counter > 0 DO counter := counter-1; IF estack[counter].num = n THEN RETURN TRUE END; END; RETURN FALSE; END ScanStackEdge; PROCEDURE ScanStackFace(num: CARDINAL): BOOLEAN = VAR counter: CARDINAL := 0; BEGIN counter := ftop; WHILE counter > 0 DO counter := counter-1; IF fstack[counter].num = num THEN RETURN TRUE END; END; RETURN FALSE; END ScanStackFace; BEGIN DoIt() END WhatDegenerations. (**************************************************************************) (* *) (* Copyright (C) 2000 Universidade Estadual de Campinas (UNICAMP) *) (* *) (* Authors: *) (* L. P. Lozada & J. Stolfi - UNICAMP *) (* *) (* This file can be freely used, distributed, and modified, provided that *) (* this copyright and authorship notice is included in every copy or *) (* derived version. *) (* *) (* DISCLAIMER: This software is offered ``as is'', without any guarantee *) (* as to fitness for any particular purpose. Neither the copyright *) (* holder nor the authors or their employers can be held responsible *) (* for any damages that may result from its use. *) (* *) (**************************************************************************) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~