1. pragma Warnings (Off); 
  2. pragma Style_Checks (Off); 
  3.  
  4. --  Algorithm to generate a Sci - Fi - style extruded surface 
  5.  --  Copyright (c) Gautier de Montmollin 2006 
  6.  --  CH - 8810 Horgen 
  7.  --  SWITZERLAND 
  8.  --  Permission granted to use the herein contained algorithm for any purpose, 
  9.  --  provided this copyright note remains attached and unmodified. 
  10.  -- 
  11.  --  Change log: 
  12.  --  xx - May - 2006 : - !! split a quad into triangles if not flat 
  13.  --               - !! identify / remove degenerate faces, e.g. on a sphere 
  14.  --                    (triangle ok, less - > erase!) 
  15.  --  26 - May - 2006 : optimized search for duplicate points 
  16.  --  24 - May - 2006 : added explicit bound checks 
  17.  --  14 - May - 2006 : created 
  18.  
  19. with GLOBE_3D.Math; 
  20.  
  21. with Ada.Numerics.Float_Random;         use Ada.Numerics.Float_Random; 
  22.  
  23. package body GLOBE_3D.Random_extrusions is 
  24.  
  25.   seed : Generator; 
  26.  
  27.   procedure Extrude_on_rectangle ( 
  28.     T1, T2, T3, T4      :  in Map_idx_pair;  -- Texture edges, horizontal surface 
  29.     V1, V2, V3, V4      :  in Map_idx_pair;  -- Texture edges, vertical surfaces 
  30.     grid_1, grid_2    :  in Positive; 
  31.     T_ID, V_ID       :  in Image_ID;      -- ID's of plane and vertical texture 
  32.     max_u3           :  in Real; 
  33.     iterations       :  in Natural; 
  34.     last_point       : out Natural; 
  35.     mesh             : out Point_3D_array; 
  36.     last_face        : out Natural; 
  37.     poly             : out Face_array; 
  38.     random_initiator :  in Integer := 0    -- default 0 - > time - dependent seed 
  39. ) 
  40.   is 
  41.     use GL, GLOBE_3D.Math; 
  42.     po, fa : Natural := 0; 
  43.     face_proto  : Face_type; -- takes defaults values 
  44.  
  45.     -- grid : 0 | --- | --- | .. .| --- | --- | n + 2; we don't touch the main face's border 
  46.     -- cell :     0   1       n  n + 1 
  47.     elevation : array (0 .. grid_1 + 1, 0 .. grid_2 + 1) of Real := 
  48.       (others => (others => 0.0));  -- elevation of the middle of a cell 
  49.     -- Temporary data used to search faster existing points: 
  50.     type Point_stack is array (1 .. 36) of Positive; -- 16 should be sufficient .. . 
  51.     -- without redundancies : 16; with redundancies : 36 
  52.     point_touching : array (elevation'Range (1), elevation'Range (2)) of Point_stack; 
  53.     total_points_touching : array (elevation'Range (1), elevation'Range (2)) of Natural := (others => (others => 0)); 
  54.  
  55.     procedure Register (e1n, e2n : Integer; P_idx : Positive) is 
  56.       e1, e2 : Integer; 
  57.       t : Natural; 
  58.     begin 
  59.       e1 := e1n mod (grid_1 + 2); 
  60.       e2 := e2n mod (grid_2 + 2); 
  61.       t := total_points_touching (e1, e2); 
  62.       for i in reverse 1 .. t loop 
  63.         if point_touching (e1, e2) (i)= P_idx then -- already in stack 
  64.           return; 
  65.         end if; 
  66.       end loop; 
  67.       total_points_touching (e1, e2) := t + 1; 
  68.       -- if t + 1 > Point_Stack'Last then raise Constraint_Error; end if; 
  69.       point_touching (e1, e2) (t + 1) := P_idx; 
  70.     end Register; 
  71.  
  72.     procedure Do_Face ( 
  73.       P1, P2, P3, P4  : Point_3D; 
  74.       tex          : Map_idx_pair_4_array; 
  75.       tex_ID       : Image_ID; 
  76.       cell1, cell2  : Natural 
  77. ) 
  78.     is 
  79.       P : array (1 .. 4) of Point_3D; 
  80.       vtx : GLOBE_3D.Natural_Index_array (1 .. 4); 
  81.       pt_idx : Natural; 
  82.       found : Boolean; 
  83.       degen : Natural := 0; 
  84.       last_degen_vtx : Positive; 
  85.       procedure Register_proto is 
  86.       begin 
  87.         fa := fa + 1; 
  88.         if fa > poly'Last then raise Constraint_Error; end if; 
  89.         -- ^ useful if we disable range checks .. . 
  90.         poly (fa) := face_proto; 
  91.       end REgister_proto; 
  92.     begin 
  93.       Geometric_mapping (P1, P (1)); 
  94.       Geometric_mapping (P2, P (2)); 
  95.       Geometric_mapping (P3, P (3)); 
  96.       Geometric_mapping (P4, P (4)); 
  97.       for pt in P'Range loop 
  98.         found := False; 
  99.         -- Look in the stack of registered points: 
  100.         for op in reverse 1 .. total_points_touching (cell1, cell2) loop 
  101.           pt_idx := point_touching (cell1, cell2) (op); 
  102.           if Almost_zero (Norm2 (P (pt) - mesh (pt_idx))) then -- exists already 
  103.             vtx (pt) := pt_idx; 
  104.             found := True; 
  105.           end if; 
  106.         end loop; 
  107.         if not found then -- add a point when non existing 
  108.           po := po + 1; 
  109.           if po > mesh'Last then raise Constraint_Error; end if; 
  110.           -- ^ useful if we disable range checks .. . 
  111.           mesh (po) := P (pt); 
  112.           vtx (pt) := po; 
  113.           for i in - 1 .. 1 loop 
  114.             for j in - 1 .. 1 loop 
  115.               Register (cell1 + i, cell2 + j, po); 
  116.             end loop; 
  117.           end loop; 
  118.         end if; 
  119.       end loop; 
  120.       face_proto.texture_edge_map := tex; 
  121.       face_proto.texture := tex_ID; 
  122.       -- Check degenerate faces 
  123.       for i in 1 .. 4 loop 
  124.         for j in i + 1 .. 4 loop 
  125.           if vtx (i)=vtx (j) then 
  126.             degen := degen + 1; 
  127.             last_degen_vtx := j; 
  128.           end if; 
  129.         end loop; 
  130.       end loop; 
  131.       case degen is 
  132.         when 0 => -- quadrilatere 
  133.           -- !! check if flat, otherwise make 2 triangles! 
  134.           face_proto.P := vtx; 
  135.           Register_proto; 
  136.         when 1 => -- triangle 
  137.           vtx (last_degen_vtx) := 0; 
  138.           face_proto.P := vtx; 
  139.           Register_proto; 
  140.         when others => 
  141.           return; 
  142.       end case; 
  143.     end Do_Face; 
  144.  
  145.     e : Real := 0.0; 
  146.     sc_1 : constant Real := 1.0 / Real (grid_1 + 2); 
  147.     sc_2 : constant Real := 1.0 / Real (grid_2 + 2); 
  148.     p_1, p_2, l_1, l_2 : Positive; 
  149.     xa, xb, ya, yb, en : Real; 
  150.     width_factor : Float; 
  151.     ta, tb : Map_idx_pair; 
  152.  
  153.   begin 
  154.     face_proto.skin := coloured_texture; 
  155.     face_proto.colour := (0.5, 0.5, 0.5); 
  156.     face_proto.whole_texture := False; 
  157.     if random_initiator /= 0 then 
  158.       Reset (seed, random_initiator); 
  159.     end if; 
  160.     -- Generate elevation map by covering it with rectangle layers 
  161.     for i in reverse 1 .. iterations loop 
  162.       p_1 := 1 + Integer (Float (grid_1 - 2)*Random (seed) + 0.5); 
  163.       p_2 := 1 + Integer (Float (grid_2 - 2)*Random (seed) + 0.5); 
  164.       width_factor := Float (i)/Float (iterations); 
  165.       -- ^ cover with decreasing widths 
  166.       l_1 := Integer (Float (grid_1 - p_1 - 1)*Random (seed)*width_factor + 0.5); 
  167.       l_2 := Integer (Float (grid_2 - p_2 - 1)*Random (seed)*width_factor + 0.5); 
  168.       -- e := e + Real (Random (seed))*max_u3/Real (iterations); 
  169.       -- ^ converges to a square of height max_u3 : - ( 
  170.       e := Real (Random (seed))*max_u3; 
  171.       for r_1 in reverse 0 .. l_1 loop 
  172.         for r_2 in reverse 0 .. l_2 loop 
  173.           elevation (p_1 + r_1, p_2 + r_2) := e; 
  174.         end loop; 
  175.       end loop; 
  176.     end loop; 
  177.     -- Create the mesh 
  178.     for e1 in reverse elevation'Range (1) loop 
  179.       for e2 in reverse elevation'Range (2) loop 
  180.         e := elevation (e1, e2); 
  181.         xa := Real (e1)*sc_1; 
  182.         xb := Real (e1 + 1)*sc_1; 
  183.         ya := Real (e2)*sc_2; 
  184.         yb := Real (e2 + 1)*sc_2; 
  185.         ta.u := T1.u + xa * (T2.u - T1.u) + ya * (xa * (T3.u - T2.u) + (1.0 - xa) * (T4.u - T1.u)); 
  186.         ta.v := T1.v + xa * (T2.v - T1.v) + ya * (xa * (T3.v - T2.v) + (1.0 - xa) * (T4.v - T1.v)); 
  187.         tb.u := T1.u + xb * (T2.u - T1.u) + yb * (xb * (T3.u - T2.u) + (1.0 - xb) * (T4.u - T1.u)); 
  188.         tb.v := T1.v + xb * (T2.v - T1.v) + yb * (xb * (T3.v - T2.v) + (1.0 - xb) * (T4.v - T1.v)); 
  189.         -- The horizontal face 
  190.         Do_Face ( 
  191.           (xa, ya, e), (xb, ya, e), (xb, yb, e), (xa, yb, e), 
  192.           (ta, (tb.u, ta.v), tb, (ta.u, tb.v)), 
  193.           T_ID, 
  194.           e1, e2 
  195. ); 
  196.         -- 
  197.         -- Now the funny part : the vertical faces! 
  198.         -- 
  199.         if iterations > 0 and -- < - possible to generate no extrusion at all! 
  200.            e1 > 0 and e2 > 0 then 
  201.           -- 
  202.           --    seen from above :    _|_|_ yb 
  203.           -- - > southern neighbour  _|_|_ ya 
  204.           --                         |^| 
  205.           -- 
  206.           en := elevation (e1, e2 - 1); 
  207.           if Almost_zero (e - en) then 
  208.             null; -- do nothing, there is no face to add 
  209.           else 
  210.             if e > en then -- neighbour has a lower elevation : face visible from south 
  211.               ta.u := V1.u + xa * (V2.u - V1.u) + en * (xa * (V3.u - V2.u) + (1.0 - xa) * (V4.u - V1.u)); 
  212.               ta.v := V1.v + xa * (V2.v - V1.v) + en * (xa * (V3.v - V2.v) + (1.0 - xa) * (V4.v - V1.v)); 
  213.               tb.u := V1.u + xb * (V2.u - V1.u) + e  * (xb * (V3.u - V2.u) + (1.0 - xb) * (V4.u - V1.u)); 
  214.               tb.v := V1.v + xb * (V2.v - V1.v) + e  * (xb * (V3.v - V2.v) + (1.0 - xb) * (V4.v - V1.v)); 
  215.               Do_Face ( 
  216.                 (xa, ya, en), (xb, ya, en), (xb, ya, e), (xa, ya, e), 
  217.                 (ta, (tb.u, ta.v), tb, (ta.u, tb.v)), 
  218.                 V_ID, 
  219.                 e1, e2 
  220. ); 
  221.             else           -- neighbour has a higher elevation : face visible from north 
  222.               ta.u := V2.u + xb * (V1.u - V2.u) + e  * (xb * (V4.u - V1.u) + (1.0 - xb) * (V3.u - V2.u)); 
  223.               ta.v := V2.v + xb * (V1.v - V2.v) + e  * (xb * (V4.v - V1.v) + (1.0 - xb) * (V3.v - V2.v)); 
  224.               tb.u := V2.u + xa * (V1.u - V2.u) + en * (xa * (V4.u - V1.u) + (1.0 - xa) * (V3.u - V2.u)); 
  225.               tb.v := V2.v + xa * (V1.v - V2.v) + en * (xa * (V4.v - V1.v) + (1.0 - xa) * (V3.v - V2.v)); 
  226.               Do_Face ( 
  227.                 (xb, ya, e), (xa, ya, e), (xa, ya, en), (xb, ya, en), 
  228.                 (ta, (tb.u, ta.v), tb, (ta.u, tb.v)), 
  229.                 V_ID, 
  230.                 e1, e2 
  231. ); 
  232.             end if; 
  233.           end if; 
  234.           -- 
  235.           --    seen from above :    _|_|_ 
  236.           -- - > western neighbour  >_|_|_ 
  237.           --                         | | 
  238.           -- 
  239.           en := elevation (e1 - 1, e2); 
  240.           if Almost_zero (e - en) then 
  241.             null; -- do nothing, there is no face to add 
  242.           else 
  243.             if e > en then -- neighbour has a lower elevation : face visible from west 
  244.               ta.u := V2.u + yb * (V1.u - V2.u) + en * (yb * (V4.u - V1.u) + (1.0 - yb) * (V3.u - V2.u)); 
  245.               ta.v := V2.v + yb * (V1.v - V2.v) + en * (yb * (V4.v - V1.v) + (1.0 - yb) * (V3.v - V2.v)); 
  246.               tb.u := V2.u + ya * (V1.u - V2.u) + e  * (ya * (V4.u - V1.u) + (1.0 - ya) * (V3.u - V2.u)); 
  247.               tb.v := V2.v + ya * (V1.v - V2.v) + e  * (ya * (V4.v - V1.v) + (1.0 - ya) * (V3.v - V2.v)); 
  248.               Do_Face ( 
  249.                 (xa, yb, en), (xa, ya, en), (xa, ya, e), (xa, yb, e), 
  250.                 (ta, (tb.u, ta.v), tb, (ta.u, tb.v)), 
  251.                 V_ID, 
  252.                 e1, e2 
  253. ); 
  254.             else           -- neighbour has a higher elevation : face visible from east 
  255.               ta.u := V1.u + ya * (V2.u - V1.u) + e  * (ya * (V3.u - V2.u) + (1.0 - ya) * (V4.u - V1.u)); 
  256.               ta.v := V1.v + ya * (V2.v - V1.v) + e  * (ya * (V3.v - V2.v) + (1.0 - ya) * (V4.v - V1.v)); 
  257.               tb.u := V1.u + yb * (V2.u - V1.u) + en * (yb * (V3.u - V2.u) + (1.0 - yb) * (V4.u - V1.u)); 
  258.               tb.v := V1.v + yb * (V2.v - V1.v) + en * (yb * (V3.v - V2.v) + (1.0 - yb) * (V4.v - V1.v)); 
  259.               Do_Face ( 
  260.                 (xa, ya, e), (xa, yb, e), (xa, yb, en), (xa, ya, en), 
  261.                 (ta, (tb.u, ta.v), tb, (ta.u, tb.v)), 
  262.                 V_ID, 
  263.                 e1, e2 
  264. ); 
  265.             end if; 
  266.           end if; 
  267.           -- 
  268.           -- - > eastern and northern neighbours : treated on next step 
  269.           --    as western and southern cases 
  270.         end if; 
  271.       end loop; 
  272.     end loop; 
  273.     last_point := po; 
  274.     last_face := fa; 
  275.   end Extrude_on_rectangle; 
  276.  
  277. begin 
  278.   Reset (seed); 
  279. end GLOBE_3D.Random_extrusions;