with openGL.Geometry.lit_textured, openGL.Primitive.indexed, openGL.Texture.Coordinates, openGL.IO, ada.unchecked_Deallocation; package body openGL.Model.terrain is use Texture; -------- -- Forge -- function new_Terrain (heights_Asset : in asset_Name; Row, Col : in Integer; Heights : in height_Map_view; color_Map : in asset_Name; texture_Details : in texture_Set.item := texture_Set.null_Set; Tiling : in texture_Transform_2d := (S => (0.0, 1.0), T => (0.0, 1.0))) return View is the_Model : constant View := new Item' (textured_Model.textured_item with heights_Asset => heights_Asset, Heights => Heights, Row => Row, Col => Col, color_Map => color_Map, tiling => Tiling); begin the_Model.set_Bounds; the_Model.texture_Details_is (texture_Details); return the_Model; end new_Terrain; overriding procedure destroy (Self : in out Item) is procedure deallocate is new ada.unchecked_Deallocation (height_Map, height_Map_view); begin destroy (Model.Item (Self)); deallocate (Self.Heights); end destroy; ------------- -- Attributes -- overriding function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class; Fonts : in Font.font_id_Map_of_font) return Geometry.views is pragma unreferenced (Textures, Fonts); use Geometry, Geometry.lit_textured; Heights : height_Map_view renames Self.Heights; row_Count : constant Index_t := Heights'Length (1) - 1; col_Count : constant Index_t := Heights'Length (2) - 1; vertex_Count : constant Index_t := Heights'Length (1) * Heights'Length (2); indices_Count : constant long_Index_t := (2 * (long_Index_t (Heights'Length (2)) + 1)) * (long_Index_t (row_Count) - 1) + 2 * (long_Index_t (Heights'Length (2))); the_Sites : aliased Sites := [1 .. vertex_Count => <>]; the_Bounds : openGL.Bounds := null_Bounds; the_Vertices : aliased Geometry.lit_textured.Vertex_array := [1 .. vertex_Count => <>]; the_Indices : aliased Indices := [1 .. indices_Count => <>]; the_Geometry : constant Geometry.lit_textured.view := Geometry.lit_textured.new_Geometry; begin the_Geometry.Model_is (Self.all'unchecked_Access); set_Sites: declare vert_Id : Index_t := 0; the_height_Range : constant Vector_2 := height_Extent (Heights.all); Middle : constant Real := (the_height_Range (1) + the_height_Range (2)) / 2.0; flipped_Row : Index_t; begin for Row in 1 .. row_Count + 1 loop for Col in 1 .. col_Count + 1 loop vert_Id := vert_Id + 1; flipped_Row := 2 + row_Count - Row; -- Flipping the row simplifies building the triangle strip below. the_Sites (vert_Id) := [Real (Col) - Real (col_Count) / 2.0 - 1.0, Heights (flipped_Row, Col) - Middle, Real (Row) - Real (row_Count) / 2.0 - 1.0]; the_Bounds.Box.Lower (1) := Real'Min (the_Bounds.Box.Lower (1), the_Sites (vert_Id) (1)); the_Bounds.Box.Lower (2) := Real'Min (the_Bounds.Box.Lower (2), the_Sites (vert_Id) (2)); the_Bounds.Box.Lower (3) := Real'Min (the_Bounds.Box.Lower (3), the_Sites (vert_Id) (3)); the_Bounds.Box.Upper (1) := Real'Max (the_Bounds.Box.Upper (1), the_Sites (vert_Id) (1)); the_Bounds.Box.Upper (2) := Real'Max (the_Bounds.Box.Upper (2), the_Sites (vert_Id) (2)); the_Bounds.Box.Upper (3) := Real'Max (the_Bounds.Box.Upper (3), the_Sites (vert_Id) (3)); the_Bounds.Ball := Real'Max (the_Bounds.Ball, abs (the_Sites (vert_Id))); the_Vertices (vert_Id).Site := the_Sites (vert_Id); end loop; end loop; the_Bounds.Ball := the_Bounds.Ball * 1.1; -- TODO: Why the '* 1.1' ? end set_Sites; set_Indices: declare Cursor : long_Index_t := 0; Start, Upper, Lower : Index_t; begin Start := 1; for Row in 1 .. row_Count loop Upper := Start; Lower := Start + col_Count + 1; for Col in 1 .. col_Count + 1 loop Cursor := Cursor + 1; the_Indices (Cursor) := Upper; Cursor := Cursor + 1; the_Indices (Cursor) := Lower; if Col /= col_Count + 1 then Upper := Upper + 1; Lower := Lower + 1; end if; end loop; if Row /= row_Count -- Not the last row. then -- Add 1st redundant triangle to allow for next strip. Cursor := Cursor + 1; the_Indices (Cursor) := Lower; -- Advance Start index. Start := Start + col_Count + 1; -- Add 2nd redundant triangle to allow for next strip. Cursor := Cursor + 1; the_Indices (Cursor) := Start; end if; end loop; end set_Indices; set_Normals: declare type Normals_view is access all Normals; the_Normals : Normals_view := Geometry.Normals_of (Primitive.triangle_Strip, the_Indices, the_Sites); procedure deallocate is new ada.unchecked_Deallocation (Normals, Normals_view); begin for i in the_Vertices'Range loop the_Vertices (i).Normal := the_Normals (i); the_Vertices (i).Shine := default_Shine; end loop; deallocate (the_Normals); end set_Normals; if Self.color_Map /= null_Asset then set_texture_Coords: declare x_Length : constant Real := the_Bounds.Box.upper (1) - the_Bounds.Box.lower (1); x_Min : constant Real := the_Bounds.Box.lower (1); z_Length : constant Real := the_Bounds.Box.upper (3) - the_Bounds.Box.lower (3); z_Min : constant Real := the_Bounds.Box.lower (3); upper_Generator : constant Texture.Coordinates.xz_Generator := (Normalise => (S => (-x_Min, 1.0 / x_Length), T => (-z_Min, 1.0 / z_Length)), Tile => Self.Tiling); the_Coords : constant Coordinates_2D := upper_Generator.to_Coordinates (the_Sites'Access); begin for i in the_Coords'Range loop the_Vertices (i).Coords := the_Coords (i); end loop; end set_texture_Coords; set_Texture: declare the_Image : constant Image := IO.to_Image (Self.color_Map); the_Texture : constant Texture.object := Forge.to_Texture (the_Image); begin the_Geometry.Texture_is (the_Texture); end set_Texture; end if; the_Geometry.is_Transparent (False); the_Geometry.Vertices_are (the_Vertices); Self.Bounds := the_Bounds; declare the_Primitive : constant Primitive.indexed.view := Primitive.indexed.new_Primitive (Primitive.triangle_Strip, the_Indices); begin the_Geometry.add (Primitive.view (the_Primitive)); end; return [1 => Geometry.view (the_Geometry)]; end to_GL_Geometries; overriding procedure set_Bounds (Self : in out Item) is Heights : height_Map_view renames Self.Heights; row_Count : constant Index_t := Heights'Length (1) - 1; col_Count : constant Index_t := Heights'Length (2) - 1; vertex_Count : constant Index_t := Heights'Length (1) * Heights'Length (2); the_Sites : aliased Sites := [1 .. vertex_Count => <>]; the_Bounds : openGL.Bounds := null_Bounds; begin set_Sites: declare vert_Id : Index_t := 0; the_height_Range : constant Vector_2 := height_Extent (Heights.all); Middle : constant Real := (the_height_Range (1) + the_height_Range (2)) / 2.0; begin for Row in 1 .. row_Count + 1 loop for Col in 1 .. col_Count + 1 loop vert_Id := vert_Id + 1; the_Sites (vert_Id) := [Real (Col) - Real (col_Count) / 2.0 - 1.0, Heights (Row, Col) - Middle, Real (Row) - Real (row_Count) / 2.0 - 1.0]; the_Bounds.Box.Lower (1) := Real'Min (the_Bounds.Box.Lower (1), the_Sites (vert_Id) (1)); the_Bounds.Box.Lower (2) := Real'Min (the_Bounds.Box.Lower (2), the_Sites (vert_Id) (2)); the_Bounds.Box.Lower (3) := Real'Min (the_Bounds.Box.Lower (3), the_Sites (vert_Id) (3)); the_Bounds.Box.Upper (1) := Real'Max (the_Bounds.Box.Upper (1), the_Sites (vert_Id) (1)); the_Bounds.Box.Upper (2) := Real'Max (the_Bounds.Box.Upper (2), the_Sites (vert_Id) (2)); the_Bounds.Box.Upper (3) := Real'Max (the_Bounds.Box.Upper (3), the_Sites (vert_Id) (3)); the_Bounds.Ball := Real'Max (the_Bounds.Ball, abs (the_Sites (vert_Id))); end loop; end loop; the_Bounds.Ball := the_Bounds.Ball * 1.1; -- TODO: Why the '* 1.1' ? end set_Sites; Self.Bounds := the_Bounds; end set_Bounds; ------------ -- Texturing -- -- overriding -- procedure Fade_is (Self : in out Item; Which : in texture_Set.texture_Id; -- Now : in texture_Set.fade_Level) -- is -- begin -- null; -- end Fade_is; -- -- -- -- overriding -- function Fade (Self : in Item; Which : in texture_Set.texture_Id) return texture_Set.fade_Level -- is -- begin -- return 0.0; -- end Fade; -- -- -- -- procedure Texture_is (Self : in out Item; Which : in texture_Set.texture_Id; -- Now : in openGL.asset_Name) -- is -- begin -- Self.color_Map := Now; -- end Texture_is; -- -- -- -- overriding -- function texture_Count (Self : in Item) return Natural -- is -- begin -- return 1; -- end texture_Count; end openGL.Model.terrain;