File : lattice-io-vrml.adb

with Ada.Text_IO, Ada.Strings.Fixed;
use Ada.Text_IO;


package body Lattice.IO.VRML is

  type D is delta 0.001 range -999.0 .. 999.0;
  package D_IO is new Ada.Text_IO.Fixed_IO(D);
  use D_IO;

  procedure PutHeader(F: in File_Type) is
  begin
    Put_Line(F,"#VRML V2.0 utf8");
    New_Line(F);
  end PutHeader;

  procedure PutBall(F: in File_Type; L: in IPoint; R: in Rep) is
    P: constant RPoint := Coord(L);
  begin
    Put_Line(F,"Transform {");
    Put(F,"  translation ");
    Put(F,D(P(1))); Put(F," ");
    Put(F,D(P(2))); Put(F," ");
    Put(F,D(P(3))); Put(F," ");
    New_Line(F);
    Put_Line(F,"  children [");
    Put_Line(F,"    Shape {");
    Put(F,"      geometry Sphere { radius ");
    Put(F,D(R));
    Put_Line(F," }");
    Put_Line(F,"      appearance Appearance {");
    Put_Line(F,"        material Material {diffuseColor 0.8 0.7 0.4}");
    Put_Line(F,"      }");
    Put_Line(F,"    }");
    Put_Line(F,"  ]");
    Put_Line(F,"}");
    New_Line(F);
  end PutBall;

  procedure PutPoints(F: in File_Type; L: in IPointVec) is
    P: RPoint;
  begin
    Put_Line(F,"Shape {");
    Put_Line(F,"    appearance Appearance {");
    Put_Line(F,"        material Material {");
    Put_Line(F,"            emissiveColor 1.0 1.0 1.0");
    Put_Line(F,"        }");
    Put_Line(F,"    }");
    Put_Line(F,"    geometry PointSet {");
    Put_Line(F,"        coord Coordinate {");
    Put_Line(F,"            point [");
    for I in L'Range loop
      P := Coord(L(I));
      Put(F,"                ");
      Put(F,D(P(1))); Put(F," ");
      Put(F,D(P(2))); Put(F," ");
      Put(F,D(P(3))); Put(F,",");
      New_Line(F);
    end loop;
    Put_Line(F,"            ]");
    Put_Line(F,"        }");
    Put_Line(F,"    }");
    Put_Line(F,"}");
    New_Line(F);
  end PutPoints;

  procedure PutLine(F: in File_Type; L1,L2: in IPoint) is
    P1: constant RPoint := Coord(L1);
    P2: constant RPoint := Coord(L2);
  begin
    Put_Line(F,"Shape {");
    Put_Line(F,"    appearance Appearance {");
    Put_Line(F,"        material Material {");
    Put_Line(F,"            emissiveColor 1.0 1.0 1.0");
    Put_Line(F,"        }");
    Put_Line(F,"    }");
    Put_Line(F,"    geometry IndexedLineSet {");
    Put_Line(F,"        coord Coordinate {");
    Put_Line(F,"            point [");

      Put(F,"                ");
      Put(F,D(P1(1))); Put(F," ");
      Put(F,D(P1(2))); Put(F," ");
      Put(F,D(P1(3))); Put(F,",");
      New_Line(F);
      Put(F,"                ");
      Put(F,D(P2(1))); Put(F," ");
      Put(F,D(P2(2))); Put(F," ");
      Put(F,D(P2(3))); Put(F,",");
      New_Line(F);

    Put_Line(F,"            ]");
    Put_Line(F,"        }");
    Put_Line(F,"        coordIndex [");
    Put_Line(F,"            0, 1");
    Put_Line(F,"         ]");
    Put_Line(F,"    }");
    Put_Line(F,"}");
    New_Line(F);
  end PutLine;

  function Box(B: Poly) return IPointVecPtr is
    L1,L2,L3: Integer := 99;
    R1,R2,R3: Integer := -99;
    N: Integer := 0;
    P: IPoint;
  begin
    for K in 1 .. B.L loop
      P := UnPack(B.V(K));
      L1 := Integer'Min(L1,P(1));
      R1 := Integer'Max(R1,P(1));
      L2 := Integer'Min(L2,P(2));
      R2 := Integer'Max(R2,P(2));
      L3 := Integer'Min(L3,P(3));
      R3 := Integer'Max(R3,P(3));
    end loop;
    for I1 in L1 .. R1 loop
      for I2 in L2 .. R2 loop
        for I3 in L3 .. R3 loop
          if FitsType((I1,I2,I3)) then
            N := N+1;
          end if;
        end loop;
      end loop;
    end loop;
    declare
      L: IPointVecPtr := new IPointVec(1 .. N);
    begin
      N := 0;
      for I1 in L1 .. R1 loop
        for I2 in L2 .. R2 loop
          for I3 in L3 .. R3 loop
            if FitsType((I1,I2,I3)) then
              N := N+1;
              L(N) := Pt(I1,I2,I3);
            end if;
          end loop;
        end loop;
      end loop;
      return L;
    end;
  end Box;

  procedure WriteVRML(Name: in String; B: in PolyPtr) is
    N: Integer := 1;
    OnePlus: constant Rep := 1.001;
    RL: constant Rep := 0.3;
    RS: constant Rep := 0.1;
    P1,P2: IPoint;
    L: IPointVecPtr := Box(B.all);
    F: File_Type;
  begin
    Put_Line("writing " & Name);
    Create(F,Out_File,Name);
    PutHeader(F);
    PutPoints(F,L.all);
    Free(L);
    while B.V(N) >= Fac3 loop
      P1 := UnPack(B.V(N));
      PutBall(F,P1,RL);
      for K in 1 .. N-1 loop
        P2 := UnPack(B.V(K));
        if RDist(P1,P2)<OnePlus then
          PutLine(F,P1,P2);
        end if;
      end loop;
      N := N+1;
      exit when N>B.L;
    end loop;
    while N <= B.L loop
      P1 := UnPack(B.V(N));
      PutBall(F,P1,RS);
      N := N+1;
    end loop;
    Close(F);
  end WriteVRML;

end Lattice.IO.VRML;