Prev: cmake and PLplot for Ada
Next: ANN: Simple components for Ada v3.9
From: anon on 11 Jul 2010 00:22
-- This program was converted from a C openGL sample program. June 2009
-- No comment because my "C to A" converter does not create comments
-- But it should be easy to understand what going on.
--
-- System: One program file and a single support package (2files)
-- Requires: GNAT, adaopengl, openGL engine

--
-- Spec
--

with openGL ;
with openGL.GLu ;
with openGL.GLut ;

use openGL ;
use openGL.GLu ;
use openGL.GLut ;

package Bitmap_Sub is

DoubleBuffer : Boolean := False ;

type RGB_ARRAY is array ( Natural range <>,
Natural range <> ) of aliased GLfloat ;

RGBMap : RGB_ARRAY := ( ( 0.0, 0.0, 0.0 ),
( 1.0, 0.0, 0.0 ),
( 0.0, 1.0, 0.0 ),
( 1.0, 1.0, 0.0 ),
( 0.0, 0.0, 1.0 ),
( 1.0, 0.0, 1.0 ),
( 0.0, 1.0, 1.0 ),
( 1.0, 1.0, 1.0 ),
( 0.5, 0.5, 0.5 )
) ;

End_Error : exception ;

-- ------------------------------------------------------------------------ --

procedure Reshape ( width : GLint ;
height : GLint ) ;

procedure key ( key_value : GLubyte ;
x : Integer ;
y : Integer ) ;

procedure Draw ;


end Bitmap_Sub ;

--
-- Body
--

with Interfaces.C ;
with Interfaces.C.Strings ;

with openGL ;
with openGL.GLu ;
with openGL.GLut ;

use Interfaces.C ;
use Interfaces.C.Strings ;

use openGL ;
use openGL.GLu ;
use openGL.GLut ;

package body Bitmap_Sub is


type GLubyte_Array is array ( Natural range <> ) of GLubyte ;

type GLfloat_Array is array ( Natural range <> ) of aliased GLfloat ;



OPENGL_WIDTH : constant := 24.0 ;
OPENGL_HEIGHT : constant := 13.0 ;

boxA_Ary : GLfloat_Array := ( 0.0, 0.0, 0.0 ) ;
boxB_Ary : GLfloat_Array := ( -100.0, 0.0, 0.0 ) ;
boxC_Ary : GLfloat_Array := ( 100.0, 0.0, 0.0 ) ;
boxD_Ary : GLfloat_Array := ( 0.0, 95.0, 0.0 ) ;
boxE_Ary : GLfloat_Array := ( 0.0, -105.0, 0.0 ) ;

boxA : GLfloatPtr := boxA_Ary ( 0 )'Access ;
boxB : GLfloatPtr := boxB_Ary ( 0 )'Access ;
boxC : GLfloatPtr := boxC_Ary ( 0 )'Access ;
boxD : GLfloatPtr := boxD_Ary ( 0 )'Access ;
boxE : GLfloatPtr := boxE_Ary ( 0 )'Access ;


OpenGL_bits1_Ary : aliased char_array := ( char'val ( 16#00# ),
char'val ( 16#03# ),
char'val ( 16#00# ),
char'val ( 16#7f# ),
char'val ( 16#fb# ),
char'val ( 16#ff# ),
char'val ( 16#7f# ),
char'val ( 16#fb# ),
char'val ( 16#ff# ),
char'val ( 16#00# ),
char'val ( 16#03# ),
char'val ( 16#00# ),
char'val ( 16#3e# ),
char'val ( 16#8f# ),
char'val ( 16#b7# ),
char'val ( 16#63# ),
char'val ( 16#db# ),
char'val ( 16#b0# ),
char'val ( 16#63# ),
char'val ( 16#db# ),
char'val ( 16#b7# ),
char'val ( 16#63# ),
char'val ( 16#db# ),
char'val ( 16#b6# ),
char'val ( 16#63# ),
char'val ( 16#8f# ),
char'val ( 16#f3# ),
char'val ( 16#63# ),
char'val ( 16#00# ),
char'val ( 16#00# ),
char'val ( 16#63# ),
char'val ( 16#00# ),
char'val ( 16#00# ),
char'val ( 16#63# ),
char'val ( 16#00# ),
char'val ( 16#00# ),
char'val ( 16#3e# ),
char'val ( 16#00# ),
char'val ( 16#00# ),
char'val ( 16#00# )
) ;

OpenGL_bits1 : GLubytePtr :=
To_Chars_Ptr ( OpenGL_bits1_Ary'Access ) ;

OpenGL_bits2_Ary : aliased char_array := ( char'val ( 16#00# ),
char'val ( 16#00# ),
char'val ( 16#00# ),
char'val ( 16#ff# ),
char'val ( 16#ff# ),
char'val ( 16#01# ),
char'val ( 16#ff# ),
char'val ( 16#ff# ),
char'val ( 16#01# ),
char'val ( 16#00# ),
char'val ( 16#00# ),
char'val ( 16#00# ),
char'val ( 16#f9# ),
char'val ( 16#fc# ),
char'val ( 16#01# ),
char'val ( 16#8d# ),
char'val ( 16#0d# ),
char'val ( 16#00# ),
char'val ( 16#8d# ),
char'val ( 16#0d# ),
char'val ( 16#00# ),
char'val ( 16#8d# ),
char'val ( 16#0d# ),
char'val ( 16#00# ),
char'val ( 16#cc# ),
char'val ( 16#0d# ),
char'val ( 16#00# ),
char'val ( 16#0c# ),
char'val ( 16#4c# ),
char'val ( 16#0a# ),
char'val ( 16#0c# ),
char'val ( 16#4c# ),
char'val ( 16#0e# ),
char'val ( 16#8c# ),
char'val ( 16#ed# ),
char'val ( 16#0e# ),
char'val ( 16#f8# ),
char'val ( 16#0c# ),
char'val ( 16#00# ),
char'val ( 16#00# )
) ;

OpenGL_bits2 : GLubytePtr :=
To_Chars_Ptr ( OpenGL_bits2_Ary'Access ) ;


logo_bits_Ary : aliased char_array := ( char'val ( 16#00# ),
char'val ( 16#66# ),
char'val ( 16#66# ),
char'val ( 16#ff# ),
char'val ( 16#66# ),
char'val ( 16#66# ),
char'val ( 16#00# ),
char'val ( 16#00# ),
char'val ( 16#00# ),
char'val ( 16#ff# ),
char'val ( 16#3c# ),
char'val ( 16#3c# ),
char'val ( 16#00# ),
char'val ( 16#42# ),
char'val ( 16#40# ),
char'val ( 16#ff# ),
char'val ( 16#42# ),
char'val ( 16#40# ),
char'val ( 16#00# ),
char'val ( 16#41# ),
char'val ( 16#40# ),
char'val ( 16#ff# ),
char'val ( 16#21# ),
char'val ( 16#20# ),
char'val ( 16#00# ),
char'val ( 16#2f# ),
char'val ( 16#20# ),
char'val ( 16#ff# ),
char'val ( 16#20# ),
char'val ( 16#20# ),
char'val ( 16#00# ),
char'val ( 16#10# ),
char'val ( 16#90# ),
char'val ( 16#ff# ),
char'val ( 16#10# ),
char'val ( 16#90# ),
char'val ( 16#00# ),
char'val ( 16#0f# ),
char'val ( 16#10# ),
char'val ( 16#ff# ),
char'val ( 16#00# ),
char'val ( 16#00# ),
char'val ( 16#00# ),
char'val ( 16#66# ),
char'val ( 16#66# ),
char'val ( 16#ff# ),
char'val ( 16#66# ),
char'val ( 16#66# ),
char'val ( 16#00# )
) ;

logo_bits : GLubytePtr := To_Chars_Ptr ( logo_bits_Ary'Access ) ;


COLOR_BLACK : constant := 0 ;
COLOR_RED : constant := 1 ;
COLOR_GREEN : constant := 2 ;
COLOR_YELLOW : constant := 3 ;
COLOR_BLUE : constant := 4 ;
COLOR_MAGENTA : constant := 5 ;
COLOR_CYAN : constant := 6 ;
COLOR_WHITE : constant := 7 ;

-- ------------------------------------------------------------------------ --

procedure Reshape ( width : GLint ;
height : GLint ) is

begin
glViewport ( 0, 0, width, height ) ;

glMatrixMode ( GL_PROJECTION ) ;
glLoadIdentity ;
gluOrtho2D ( -175.0, 175.0, -175.0, 175.0 ) ;
glMatrixMode ( GL_MODELVIEW ) ;
end Reshape ;

procedure key ( key_value : GLubyte ;
x : Integer ;
y : Integer ) is


begin
case key_value is
when 16#27# =>
raise End_Error ;
when others =>
null ;
end case ;
end key ;


procedure Draw is

procedure SetColor ( C : Natural ) is
begin
if glutGet ( GLUT_WINDOW_RGBA ) = GL_TRUE then
glColor3fv ( RGBMap ( C, 0 )'Access ) ;
else
-- glIndexf ( GLfloat ( C ) ) ;
glIndexi ( C ) ;
end if ;
end SetColor ;

procedure Draw_Bits ( Color : Natural ;
box : GLfloatPtr ) is
begin
SetColor ( Color ) ;
glRasterPos3fv ( box ) ;
glBitmap ( GLsizei ( OPENGL_WIDTH ),
GLsizei ( OPENGL_HEIGHT ),
OPENGL_WIDTH, 0.0,
OPENGL_WIDTH, 0.0,
OpenGL_bits1 ) ;
glBitmap ( GLsizei ( OPENGL_WIDTH ),
GLsizei ( OPENGL_HEIGHT ),
OPENGL_WIDTH, 0.0,
OPENGL_WIDTH, 0.0,
OpenGL_bits2 ) ;
end Draw_Bits ;

mapI : GLfloat_Array := ( 0.0, 1.0 ) ;
mapIR : GLfloat_Array := ( 0.0, 0.0 ) ;
mapIA : GLfloat_Array := ( 1.0, 1.0 ) ;

begin
glClear ( GL_COLOR_BUFFER_BIT ) ;

glPixelMapfv ( GL_PIXEL_MAP_I_TO_R, 2,
mapIR ( 0 )'Unchecked_Access ) ;
glPixelMapfv ( GL_PIXEL_MAP_I_TO_G, 2,
mapI ( 0 )'Unchecked_Access ) ;
glPixelMapfv ( GL_PIXEL_MAP_I_TO_B, 2,
mapI ( 0 )'Unchecked_Access ) ;
glPixelMapfv ( GL_PIXEL_MAP_I_TO_A, 2,
mapIA ( 0 )'Unchecked_Access ) ;
glPixelTransferi ( GL_MAP_COLOR, GL_TRUE);

-- SetColor ( COLOR_White ) ;
glRasterPos3fv ( boxA ) ;
glPixelStorei ( GL_UNPACK_ROW_LENGTH, 24 ) ;
glPixelStorei ( GL_UNPACK_SKIP_PIXELS, 8 ) ;
glPixelStorei ( GL_UNPACK_SKIP_ROWS, 2 ) ;
glPixelStorei ( GL_UNPACK_LSB_FIRST, GL_FALSE ) ;
glPixelStorei ( GL_UNPACK_ALIGNMENT, 1 ) ;
glBitmap ( 16, 12, 16.0, 0.0, 16.0, 0.0, logo_bits ) ;

glPixelStorei ( GL_UNPACK_ROW_LENGTH, 0 ) ;
glPixelStorei ( GL_UNPACK_SKIP_PIXELS, 0 ) ;
glPixelStorei ( GL_UNPACK_SKIP_ROWS, 0 ) ;
glPixelStorei ( GL_UNPACK_LSB_FIRST, GL_TRUE ) ;
glPixelStorei ( GL_UNPACK_ALIGNMENT, 1 ) ;

Draw_Bits ( COLOR_WHITE, boxB ) ;
Draw_Bits ( COLOR_YELLOW, boxC ) ;
Draw_Bits ( COLOR_CYAN, boxD ) ;
Draw_Bits ( COLOR_RED, boxE ) ;

glFlush ;

if DoubleBuffer then
glutSwapBuffers ;
end if ;
end Draw ;

end Bitmap_Sub ;

---
--- main body
---

with Ada.Command_Line ;
with Ada.Text_IO ;
with Interfaces.C ;
with Interfaces.C.Strings ;

with openGL ;
with openGL.GLu ;
with openGL.GLut ;

use openGL ;
use openGL.GLu ;
use openGL.GLut ;

with Bitmap_Sub ;
use Bitmap_Sub ;

procedure Bitmap is

windType : Interfaces.C.unsigned ;

RGB : Boolean := True ;

End_Error : exception ;

-- ------------------------------------------------------------------------ --

procedure Args is

use Ada.Command_Line ;
use Ada.Text_IO;
use Interfaces.C ;

begin
windType := GLUT_RGB or GLUT_SINGLE ;

for Index in 1..Argument_Count loop
if Argument ( Index ) = "-ci" then
RGB := False ;
windType := GLUT_INDEX ;
elsif Argument ( Index ) = "-rgb" then
RGB := True ;
windType := GLUT_RGB ;
elsif Argument ( Index ) = "-sb" then
DoubleBuffer := False ;
windType := windType or GLUT_SINGLE ;
elsif Argument ( Index ) = "-db" then
DoubleBuffer := True ;
windType := windType or GLUT_SINGLE ;
elsif Argument ( Index ) = "-?" then
Put_Line ( "Usage: bitmap2 [-ci|-rgb] [-sb|-db] [-?]" ) ;
raise End_Error ;
else
Put_Line ( "Illegal command line opion: " &
Argument ( Index ) ) ;
raise End_Error ;
end if ;
end loop ;
end Args ;

procedure InitMap is

begin
if not RGB then
for Index in 0..8 loop
glutSetColor ( Index, RGBMap ( Index, 0 ),
RGBMap ( Index, 1 ),
RGBMap ( Index, 2 ) ) ;
end loop ;
end if ;
end InitMap ;

procedure Init is

begin
glClearColor ( 0.0, 0.0, 0.0, 0.0 ) ;
glClearIndex ( 0.0 ) ;
end Init ;


-- ------------------------------------------------------------------------ --

argc : aliased Integer;
pragma Import ( C, argc, "gnat_argc" ) ;

argv : GLubytePtr ;
pragma Import ( C, argv, "gnat_argv" ) ;


use Ada.Text_IO;
use Interfaces.C.Strings ;

begin
Args ;

glutInit ( argc'Access, argv ) ;

glutInitDisplayMode ( windType ) ;
glutInitWindowPosition ( 0, 0 ) ;
glutInitWindowSize ( 300, 300 ) ;

if glutCreateWindow ( New_String ( "Bitmap" ) ) = GL_FALSE then
Put_Line ( "glutCreateWindow Error" ) ;
raise End_Error ;
end if ;

InitMap ;

Init ;

glutReshapeFunc ( Reshape'Access ) ;
glutKeyboardFunc ( Key'Access ) ;
glutDisplayFunc ( Draw'Access ) ;
glutMainLoop ;

exception
when End_Error =>
null ;
when others =>
null ;

end Bitmap ;



 | 
Pages: 1
Prev: cmake and PLplot for Ada
Next: ANN: Simple components for Ada v3.9