MODULE MakeShape EXPORTS Main;

(*
  Generates ".top" files for some simple maps with various topologies.
  The vertex coordinates are random numbers in [-1..+1].
*)

IMPORT 
  Fmt, ParseParams, Text, LR3, Oct, Map, Random,
  Triang, Color, Wr, Stdio, Thread, Process;
FROM Oct IMPORT 
  Splice, EnumEdges, Onext, Oprev, Lnext, Rnext, 
  Rprev, Rot, Sym, Tor, Flip, Degree, PrintArc;

FROM Map IMPORT Arc, GluePatch, Middle;

FROM Triang IMPORT OrgV;

FROM Stdio IMPORT stderr;

TYPE 
  Shape = {
    Torus, BiTorus, TriTorus, Klein, Klein2, Klein3, PPlane, 
    Tetra, Stick, Ring, Cube, 
    Sausage, Sausage2, Orange, Fork, 
    Star, StarBug1, StarBug2,
    Cup, Flaps
  };
  Options = RECORD
      gridOrder: CARDINAL;
      shape: Shape;
      shapeName: TEXT;
      colr1, colr2: Color.T;
    END;

PROCEDURE DoIt() =  
  BEGIN
    WITH 
      o = GetOptions(),
      m = MakeMap(o.shape, o.gridOrder),
      s = TriangulateMap(m),
      t = Triang.MakeTopology(s),
      c = GenCoords(t)^
    DO
      Triang.Write(
        o.shapeName & "-" & Fmt.Int(o.gridOrder),
        t, c,
        "Created by MakeShape"
      )
    END
  END DoIt;

PROCEDURE MakeMap(shape: Shape; gridOrder: CARDINAL): Arc =
  BEGIN
    CASE shape OF 
    | Shape.Torus    => RETURN MakeTorus(gridOrder);
    | Shape.BiTorus  => RETURN MakeBiTorus(gridOrder);
    | Shape.TriTorus => RETURN MakeTriTorus(gridOrder);
    | Shape.Klein    => RETURN MakeKlein(gridOrder);
    | Shape.Klein2   => RETURN MakeKlein2(gridOrder);
    | Shape.Klein3   => RETURN MakeKlein3(gridOrder);
    | Shape.PPlane   => RETURN MakePPlane(gridOrder);
    | Shape.Tetra    => RETURN MakeTetra(gridOrder);
    | Shape.Stick    => RETURN MakeStick(gridOrder);
    | Shape.Ring     => RETURN MakeRing(5, gridOrder);
    | Shape.Cube     => RETURN MakeCube(gridOrder);
    | Shape.Sausage  => RETURN MakeSausage(2, gridOrder);
    | Shape.Sausage2 => RETURN MakeSausage(4, gridOrder);
    | Shape.Orange   => RETURN MakeFork(7, 0, gridOrder);
    | Shape.Fork     => RETURN MakeFork(3, 2, gridOrder);
    | Shape.Star     => RETURN MakeFork(5, 1, gridOrder);
    | Shape.StarBug1 => RETURN MakeForkBug1(5, 1, gridOrder);
    | Shape.StarBug2 => RETURN MakeForkBug2(5, 1, gridOrder);
    | Shape.Cup      => RETURN MakeFork(1, 2, gridOrder);
    | Shape.Flaps    => RETURN MakeFork(2, 2, gridOrder);
    END
  END MakeMap;
  
PROCEDURE TriangulateMap(a: Arc): Triang.Arc =
  BEGIN
    EnumEdges(a, GluePatch);
    EnumEdges(a, Prt);
    RETURN Middle(a)
  END TriangulateMap;

VAR EdgeCount: CARDINAL := 0;
  
(* Basic tools: *)

PROCEDURE MkEdge(gridOrder: CARDINAL): Arc = 
  BEGIN
    WITH 
      color1 = Color.T{1.0, 0.95, 0.7},
      color2 = Color.T{1.0, 0.95, 0.7},
      a = Map.MakeEdge(gridOrder),
      e = NARROW(a.edge, Map.Edge)
    DO 
      e.num := EdgeCount;
      Map.SetPrimalProperties(
        a, 
        vertexRadius := 0.03,
        vertexColor := Color.T{0.0, 0.0, 0.0},
        edgeRadius := 0.01,
        edgeColor := Color.T{0.0, 0.0, 0.0},
        faceColor := color1,
        faceTransp := Color.T{0.8, 0.8, 0.8}
      );
      Map.SetPrimalProperties(
        Rot(a),
        vertexRadius := 0.02,
        vertexColor := Color.T{1.0, 0.2, 0.0},
        edgeRadius := 0.01,
        edgeColor := Color.T{1.0, 0.2, 0.0},
        faceColor := color2,
        faceTransp := Color.T{0.8, 0.8, 0.8}
      );
      WITH vc = OrgV(Middle(a)) DO
        vc.color := Color.T{0.5, 0.1, 0.0};
        vc.radius := 0.02
      END;
      INC(EdgeCount, 1); 
      RETURN a
    END
  END MkEdge;

PROCEDURE MakeRing (n: INTEGER; gridOrder: CARDINAL): Arc =
  VAR fst, a, b: Arc;
  BEGIN
    a := MkEdge(gridOrder); 
    fst := a;
    FOR i := 2 TO n DO
      b := MkEdge(gridOrder); 
      Splice(b, Sym(a));
      a := b;
    END;
    Splice(fst, Sym(a));
    RETURN fst
  END MakeRing;

PROCEDURE MakeOrange(n: CARDINAL; gridOrder: CARDINAL): Arc =
  (* 
    Same as Rot(MakeRing(n, gridOrder)), except that the 
    primal/dual coloring of patches is reversed. *)
  VAR fst, a, b: Arc;
  BEGIN
    a := Rot(MkEdge(gridOrder));
    Splice(a, Sym(a));    (* WAS MISSING IN WRONG VERSION *)
    fst := a;
    FOR i := 2 TO n DO
      b := Rot(MkEdge(gridOrder));
      Splice(b, Sym(b));  (* WAS MISSING IN WRONG VERSION *)
      Splice(b, Sym(a));
      a := b;
    END;
    Splice(fst, Sym(a));
    <* ASSERT Degree(Tor(fst)) = n *>
    RETURN Tor(fst)
  END MakeOrange;

(* Shape builders: *)

PROCEDURE MakeTetra(gridOrder: CARDINAL): Arc =
  VAR s, t, a: Arc;
  <* FATAL Wr.Failure, Thread.Alerted *>
  BEGIN
    s := MakeRing(4, gridOrder);
    a := MkEdge(gridOrder);
    t := Rnext(Rnext(s));
    
    Splice(s, a); Splice(t, Sym(a));
    a := MkEdge(gridOrder);
    Splice(Sym(s), a); Splice(Sym(t), Sym(a));

    Wr.PutText(stderr, "Exit MakeTetra:\n"); 
    RETURN a    
  END MakeTetra;

PROCEDURE MakeStick (gridOrder: CARDINAL):Arc =
  VAR a: Arc;
  <* FATAL Wr.Failure, Thread.Alerted *>
  BEGIN
    a := MkEdge(gridOrder);
    Splice(a, Sym(a));
    Wr.PutText(Stdio.stderr, "Exit MakeStick:\n");
    RETURN a;
  END MakeStick;

PROCEDURE MakeCube (gridOrder: CARDINAL): Arc =
  VAR b, t, e: Arc;
  <* FATAL Wr.Failure, Thread.Alerted *>
  BEGIN
    b := MakeRing(4,gridOrder);
    t := MakeRing(4,gridOrder); t := Oprev(t);
    FOR i := 1 TO 4 DO
      e := MkEdge(gridOrder);
      Splice(b, e); Splice(Sym(e), t);
      b := Rprev(b); t := Rnext(t)
    END;
    Wr.PutText(stderr, "Exit MakeCube:\n"); 
    RETURN b    
  END MakeCube;

PROCEDURE MakeSausage (length: CARDINAL; gridOrder: CARDINAL): Arc =
  VAR t: Arc;
  <* FATAL Wr.Failure, Thread.Alerted *>
  BEGIN
    t := MakeRing(2, gridOrder);
    BuildTower(2, length, gridOrder, t);
    Wr.PutText(stderr, "Exit MakeSausage:\n"); 
    RETURN t    
  END MakeSausage;

PROCEDURE MakeFork (prongs, length: CARDINAL; gridOrder: CARDINAL): Arc =
  VAR o: Arc;
  <* FATAL Wr.Failure, Thread.Alerted *>
  BEGIN
    o := MakeOrange(prongs, gridOrder);
    FOR k := 1 TO prongs DO 
      o := Onext(o); 
      BuildTower(2, length, gridOrder, o);
    END;
    IF length = 0 THEN 
      <* ASSERT Degree(o) = prongs *>    
    ELSE
      <* ASSERT Degree(o) = 2*prongs *> 
    END;
    Wr.PutText(stderr, "Exit MakeFork:\n"); 
    RETURN o    
  END MakeFork;
  
PROCEDURE BuildTower(m, h, gridOrder: CARDINAL; a: Arc) =
  (* 
    Builds a cylindrical tower on the face Right(a), 
    which must have "m" edges. The tower will have "h" stages
    and a roof; each stage will be a ring with "m" square faces.
    The roof of the tower will be a single face of "m" edges. *)
  VAR s, e, t: Arc;
  BEGIN
    t := a;
    FOR i := 1 TO h DO
      t := Oprev(t);
      <* ASSERT Degree(Tor(t)) = m *>
      s := MakeRing(m, gridOrder);
      FOR j  := 1 TO m DO 
        e := MkEdge(gridOrder);
        Splice(t, e); Splice(Sym(e), Oprev(s));
        t := Lnext(t); 
        s := Lnext(s)     (* WAS "s := Rnext(s)" IN BUGGY VERSION 1 *)
      END;
      t := Onext(s);      (* WAS "t := s" IN BUGGY VERSIONS 1 AND 2 *)
    END;
  END BuildTower;
  
PROCEDURE MakeForkBug1 (prongs, length: CARDINAL; gridOrder: CARDINAL): Arc =
  VAR o: Arc;
  <* FATAL Wr.Failure, Thread.Alerted *>
  BEGIN
    o := MakeOrange(prongs, gridOrder);
    FOR k := 1 TO prongs DO 
      o := Onext(o); 
      BuildTowerBug1(2, length, gridOrder, o);
    END;
    Wr.PutText(stderr, "Exit MakeForkBug1:\n"); 
    RETURN o    
  END MakeForkBug1;
  
PROCEDURE BuildTowerBug1(m, h, gridOrder: CARDINAL; a: Arc) =
  (* 
    Builds a cylindrical tower on the face Right(a), 
    which must have "m" edges. The tower will have "h" stages
    and a roof; each stage will be a ring with "m" square faces.
    The roof of the tower will be a single face of "m" edges. *)
  VAR s, e, t: Arc;
  BEGIN
    t := a;
    FOR i := 1 TO h DO
      t := Oprev(t);
      s := MakeRing(m, gridOrder);
      FOR j  := 1 TO m DO 
        e := MkEdge(gridOrder);
        Splice(t, e); Splice(Sym(e), Oprev(s));
        t := Lnext(t); 
        s := Rnext(s)    (* SHOULD BE "s := Lnext(s)" *)
      END;
      t := s;            (* SHOULD BE "t := Onext(s)" *)
    END;
  END BuildTowerBug1;
  
PROCEDURE MakeForkBug2 (prongs, length: CARDINAL; gridOrder: CARDINAL): Arc =
  VAR o: Arc;
  <* FATAL Wr.Failure, Thread.Alerted *>
  BEGIN
    o := MakeOrange(prongs, gridOrder);
    FOR k := 1 TO prongs DO 
      o := Onext(o); 
      BuildTowerBug2(2, length, gridOrder, o);
    END;
    Wr.PutText(stderr, "Exit MakeForkBug2:\n"); 
    RETURN o    
  END MakeForkBug2;
  
PROCEDURE BuildTowerBug2(m, h, gridOrder: CARDINAL; a: Arc) =
  (* 
    Builds a cylindrical tower on the face Right(a), 
    which must have "m" edges. The tower will have "h" stages
    and a roof; each stage will be a ring with "m" square faces.
    The roof of the tower will be a single face of "m" edges. *)
  VAR s, e, t: Arc;
  BEGIN
    t := a;
    FOR i := 1 TO h DO
      t := Oprev(t);
      s := MakeRing(m, gridOrder);
      FOR j  := 1 TO m DO 
        e := MkEdge(gridOrder);
        Splice(t, e); Splice(Sym(e), Oprev(s));
        t := Lnext(t); 
        s := Lnext(s)    (* WAS "s := Rnext(s)" IN BUGGY VERSION 1 *)
      END;
      t := s;            (* SHOULD BE "t := Onext(s)" *)
    END;
  END BuildTowerBug2;
  
PROCEDURE MakePPlane (gridOrder: CARDINAL): Arc =
  VAR e: Arc;
  <* FATAL Wr.Failure, Thread.Alerted *> 
  BEGIN
    e := MkEdge(gridOrder);
    Splice (Flip(Sym(e)), e);
    Wr.PutText(stderr, "Exit MakePPlane: \n");
    RETURN e
  END MakePPlane;

PROCEDURE MakeTorus(gridOrder: CARDINAL): Arc =
  VAR a, b: Arc;
  <* FATAL Wr.Failure, Thread.Alerted *>
  BEGIN
    a := MkEdge(gridOrder);
    b := MkEdge(gridOrder);
    Splice(a, b);
    Splice(Sym(a), a);
    Splice(Sym(b), a);
    Wr.PutText(stderr, "Exit MakeTorus: \n");    
    RETURN a
  END MakeTorus;
 
PROCEDURE MakeBiTorus(gridOrder: CARDINAL): Arc =
  VAR a, b, c, d, e, f: Arc;
  <* FATAL Wr.Failure, Thread.Alerted *>
  BEGIN
    a := MkEdge(gridOrder);
    b := MkEdge(gridOrder);
    c := MkEdge(gridOrder);
    d := MkEdge(gridOrder);
    e := MkEdge(gridOrder);
    f := MkEdge(gridOrder);
    Splice(a, b);
    Splice(b, c);
    Splice(c, d);
    Splice(d, e);
    Splice(e, Sym(c));
    Splice(Sym(a), Sym(e));
    Splice(Sym(e), Sym(f));
    Splice(Sym(f), Sym(d));
    Splice(Sym(d), Sym(b)); 
    Splice(Sym(b), f); 
    Wr.PutText(stderr, "Exit MakeBiTorus: \n");    
    RETURN a
  END MakeBiTorus;
 
PROCEDURE MakeTriTorus(gridOrder: CARDINAL): Arc =
  VAR a: ARRAY [0..1] OF ARRAY [0..3] OF Arc;
      t, s, e: Arc;
  <* FATAL Wr.Failure, Thread.Alerted *>
  BEGIN
    (* 
      Build two tetrahedra, inner and outer.  Store in a[i, k]
      one arc such that Left(a[i,k]) is face "k" of tetrahedron "i".
    *)
    FOR i := 0 TO 1 DO 
      a[i,0] := MakeTetra(gridOrder);
      a[i,1] := Onext(a[i,0]);
      a[i,2] := Sym(Onext(Sym(a[i,0])));
      a[i,3] := Oprev(a[i,2]);
    END;
    (*
      Build tubes connecting corresponding faces of the two tetrahedra.
      Each tube has three edges and three square faces.
    *)
    FOR k := 0 TO 3 DO 
      t := a[0,k]; s := a[1,k];
      FOR j := 1 TO 3 DO 
        e := MkEdge(gridOrder);
        Splice(t, e); Splice(s, Flip(Sym(e)));
        t := Lnext(t); s := Lnext(s)
      END;
    END;
    Wr.PutText(stderr, "Exit MakeTriTorus: \n");    
    RETURN s
  END MakeTriTorus;
 
PROCEDURE MakeKlein(gridOrder: CARDINAL): Arc =
  VAR a, b: Arc;
  <* FATAL Wr.Failure, Thread.Alerted *>
  BEGIN
    a := MkEdge(gridOrder); 
    b := MkEdge(gridOrder);
    Splice(a, b);
    Splice(Sym(a), a);
    Splice(Flip(Sym(b)), a);
    Wr.PutText(stderr, "Exit MakeKlein: \n");
    RETURN a
  END MakeKlein;
  
PROCEDURE MakeKlein2(gridOrder: CARDINAL): Arc =
  VAR a, b, c, d: Arc;
  <* FATAL Wr.Failure, Thread.Alerted *>
  BEGIN
    a := MkEdge(gridOrder); 
    b := MkEdge(gridOrder);
    c := MkEdge(gridOrder); 
    d := MkEdge(gridOrder);
    
    (* Vertex 1: *)
    Splice(b, a);
    Splice(a, Flip(Sym(c)));
    Splice(Flip(Sym(c)), Sym(a));
    
    (* Vertex 2: *)
    Splice(c, d);
    Splice(d, Sym(b));
    Splice(Sym(b), Sym(d));
    
    Wr.PutText(stderr, "Exit MakeKlein2: \n");
    RETURN a
  END MakeKlein2;
  
PROCEDURE MakeKlein3(gridOrder: CARDINAL): Arc =
  VAR a, b, c, d, e, f: Arc;
  <* FATAL Wr.Failure, Thread.Alerted *>
  BEGIN
    a := MkEdge(gridOrder); 
    b := MkEdge(gridOrder);
    c := MkEdge(gridOrder); 
    d := MkEdge(gridOrder);
    e := MkEdge(gridOrder);
    f := MkEdge(gridOrder);
    Wr.PutText(stderr, "Exit MakeKlein3: \n");
    
    (* Vertex 1: *)
    Splice(b, a);
    Splice(a, Flip(Sym(c)));
    Splice(Flip(Sym(c)), Sym(a));
    
    (* Vertex 2: *)
    Splice(f, d);
    Splice(d, Sym(b));
    Splice(Sym(b), Sym(d));
    
    (* Vertex 3: *)
    Splice(c, e);
    Splice(e, Sym(f));
    Splice(Sym(f), Sym(e));
    
    RETURN a
  END MakeKlein3;
  
PROCEDURE GenCoords(READONLY t: Triang.Topology): REF Triang.Coords =
  BEGIN
    WITH
      coins = NEW(Random.Default).init(TRUE),
      r = NEW(REF Triang.Coords, t.NV),
      c = r^
    DO
      FOR i := 0 TO LAST(c) DO 
        c[i] := LR3.T{
          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 Prt (a: Arc) =
  <* FATAL Wr.Failure, Thread.Alerted *>
  BEGIN
    Wr.PutText(stderr, "edge: "); PrintArc(stderr, a);
    Wr.PutText(stderr, "  onext: "); PrintArc(stderr, Onext(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("-gridOrder");                               
        o.gridOrder := pp.getNextInt(1, 20); 

        pp.getKeyword("-shape");  
        o.shapeName := pp.getNext();
        IF Text.Equal(o.shapeName, "torus") THEN
          o.shape := Shape.Torus
        ELSIF Text.Equal(o.shapeName, "bitorus") THEN
          o.shape := Shape.BiTorus
        ELSIF Text.Equal(o.shapeName, "tritorus") THEN
          o.shape := Shape.TriTorus
        ELSIF Text.Equal(o.shapeName, "klein") THEN
          o.shape := Shape.Klein
        ELSIF Text.Equal(o.shapeName, "klein2") THEN
          o.shape := Shape.Klein2
        ELSIF Text.Equal(o.shapeName, "klein3") THEN
          o.shape := Shape.Klein3
        ELSIF Text.Equal(o.shapeName, "pplane") THEN
          o.shape := Shape.PPlane
        ELSIF Text.Equal(o.shapeName, "tetra") THEN
          o.shape := Shape.Tetra
        ELSIF Text.Equal(o.shapeName, "stick") THEN
          o.shape := Shape.Stick
        ELSIF Text.Equal(o.shapeName, "ring") THEN
          o.shape := Shape.Ring
        ELSIF Text.Equal(o.shapeName, "cube") THEN
          o.shape := Shape.Cube
        ELSIF Text.Equal(o.shapeName, "sausage") THEN
          o.shape := Shape.Sausage
        ELSIF Text.Equal(o.shapeName, "sausage2") THEN
          o.shape := Shape.Sausage2
        ELSIF Text.Equal(o.shapeName, "orange") THEN
          o.shape := Shape.Orange
        ELSIF Text.Equal(o.shapeName, "fork") THEN
          o.shape := Shape.Fork
        ELSIF Text.Equal(o.shapeName, "star") THEN
          o.shape := Shape.Star
        ELSIF Text.Equal(o.shapeName, "starbug1") THEN
          o.shape := Shape.StarBug1
        ELSIF Text.Equal(o.shapeName, "starbug2") THEN
          o.shape := Shape.StarBug2
        ELSIF Text.Equal(o.shapeName, "cup") THEN
          o.shape := Shape.Cup
        ELSIF Text.Equal(o.shapeName, "flaps") THEN
          o.shape := Shape.Flaps
        ELSE
          pp.error("Bad shape \"" & pp.getNext() & "\"\n")
        END;
        pp.finish();                                       
      EXCEPT                                                            
      | ParseParams.Error =>                                              
          Wr.PutText(stderr, "Usage: MakeShape -gridOrder <num>\\\n");
          Wr.PutText(stderr, "  -shape { torus | klein | ... | star }\n");
          Process.Exit (1);                                              
      END
    END;
    RETURN o
  END GetOptions;
 
BEGIN 
  DoIt();
END MakeShape.