Clean up. This dir is still on experimental branch
[sdlgit/SDL_perl.git] / test / OpenGL / tutorial / lesson06.pl
CommitLineData
8fde61e3 1#!/usr/bin/perl -w
2# This code was created by Jeff Molofee '99
3# (ported to SDL by Sam Lantinga '2000)
4# (ported to Perl/SDL by Wayne Keenan '2000)
5#
6# If you've found this code useful, please let me know.
7#
8# Visit me at www.demonews.com/hosted/nehe
9
10use strict;
11use Getopt::Long;
12use Data::Dumper;
13use Benchmark;
14
15use SDL;
16use SDL::App;
17use SDL::OpenGL;
18use SDL::Event;
19
20my $arg_screen_width =640;
21my $arg_screen_height=512;
22my $arg_fullscreen=0;
23my $delay = 3;
24
25GetOptions(
26 "width:i" => \$arg_screen_width,
27 "height:i" => \$arg_screen_height,
28 "fullscreen!" => \$arg_fullscreen,
29 "delay:i" => \$delay,
30
31 ) or die $!;
32
33############################################################
34
35my ($xrot, $yrot, $zrot) = (0,0,0);
36
37main();
38exit;
39
40
41sub main
42 {
43 my $done=0;
44
45 my $app = new SDL::App ( -title => "Jeff Molofee's GL Code Tutorial ... NeHe '99",
46 -icon => "Data/perl.png",
47 -width => $arg_screen_width,
48 -height =>$arg_screen_height,
49 -opengl => 1,
50 );
51 $app->fullscreen() if $arg_fullscreen;
52
53 SDL::ShowCursor(0);
54
55 my $event = new SDL::Event;
56 $event->set(SDL_SYSWMEVENT,SDL_IGNORE);
57
58 InitGL($arg_screen_width, $arg_screen_height);
59
60
61 while ( not $done ) {
62
63 DrawGLScene();
64
65 $app->sync();
66
67 for (1 .. 10) {
68 $event->pump;
69 $event->poll;
70 $app->delay($delay);
71 }
72
73
74 if ( $event->type == SDL_QUIT ) {
75 $done = 1;
76 }
77
78 if ( $event->type == SDL_KEYDOWN ) {
79 if ( $event->key_sym == SDLK_ESCAPE ) {
80 $done = 1;
81 }
82 }
83 }
84 }
85
86
87
88
89
90
91#########################################################################
92#Pretty much in original form, but 'Perlised'
93
94
95
96
97sub InitGL
98 {
99 my ($Width, $Height) = @_;
100
101 glViewport(0, 0, $Width, $Height);
102
103 LoadGLTextures(); # Load The Texture(s)
104
105 glEnable(GL_TEXTURE_2D()); # Enable Texture Mapping
106
107 glClearColor(0.0, 0.0, 1.0, 0.0); # This Will Clear The Background Color To Black
108 glClearDepth(1.0); # Enables Clearing Of The Depth Buffer
109 glDepthFunc(GL_LESS); # The Type Of Depth Test To Do
110 glEnable(GL_DEPTH_TEST); # Enables Depth Testing
111 glShadeModel(GL_SMOOTH); # Enables Smooth Color Shading
112
113 glMatrixMode(GL_PROJECTION);
114 glLoadIdentity(); # Reset The Projection Matrix
115
116 gluPerspective(45.0, $Width/$Height, 0.1, 100.0); # Calculate The Aspect Ratio Of The Window
117
118 glMatrixMode(GL_MODELVIEW);
119 }
120
121
122
123# The main drawing function.
124sub DrawGLScene
125 {
126 glClear(GL_COLOR_BUFFER_BIT | GL_DEPTH_BUFFER_BIT); # Clear The Screen And The Depth Buffer
127 glLoadIdentity(); # Reset The View
128
129
130 glTranslate(0.0,0.0,-5.0); # move 5 units into the screen.
131
132 glRotate($xrot,1.0,0.0,0.0); # Rotate On The X Axis
133 glRotate($yrot,0.0,1.0,0.0); # Rotate On The Y Axis
134 glRotate($zrot,0.0,0.0,1.0); # Rotate On The Z Axis
135
136 glBindTexture(GL_TEXTURE_2D, 1); # choose the texture to use.
137
138 glBegin(GL_QUADS); # begin drawing a cube
139
140 # Front Face (note that the texture's corners have to match the quad's corners)
141 glTexCoord(0.0, 0.0); glVertex(-1.0, -1.0, 1.0); # Bottom Left Of The Texture and Quad
142 glTexCoord(1.0, 0.0); glVertex( 1.0, -1.0, 1.0); # Bottom Right Of The Texture and Quad
143 glTexCoord(1.0, 1.0); glVertex( 1.0, 1.0, 1.0); # Top Right Of The Texture and Quad
144 glTexCoord(0.0, 1.0); glVertex(-1.0, 1.0, 1.0); # Top Left Of The Texture and Quad
145
146 # Back Face
147 glTexCoord(1.0, 0.0); glVertex(-1.0, -1.0, -1.0); # Bottom Right Of The Texture and Quad
148 glTexCoord(1.0, 1.0); glVertex(-1.0, 1.0, -1.0); # Top Right Of The Texture and Quad
149 glTexCoord(0.0, 1.0); glVertex( 1.0, 1.0, -1.0); # Top Left Of The Texture and Quad
150 glTexCoord(0.0, 0.0); glVertex( 1.0, -1.0, -1.0); # Bottom Left Of The Texture and Quad
151
152 # Top Face
153 glTexCoord(0.0, 1.0); glVertex(-1.0, 1.0, -1.0); # Top Left Of The Texture and Quad
154 glTexCoord(0.0, 0.0); glVertex(-1.0, 1.0, 1.0); # Bottom Left Of The Texture and Quad
155 glTexCoord(1.0, 0.0); glVertex( 1.0, 1.0, 1.0); # Bottom Right Of The Texture and Quad
156 glTexCoord(1.0, 1.0); glVertex( 1.0, 1.0, -1.0); # Top Right Of The Texture and Quad
157
158 # Bottom Face
159 glTexCoord(1.0, 1.0); glVertex(-1.0, -1.0, -1.0); # Top Right Of The Texture and Quad
160 glTexCoord(0.0, 1.0); glVertex( 1.0, -1.0, -1.0); # Top Left Of The Texture and Quad
161 glTexCoord(0.0, 0.0); glVertex( 1.0, -1.0, 1.0); # Bottom Left Of The Texture and Quad
162 glTexCoord(1.0, 0.0); glVertex(-1.0, -1.0, 1.0); # Bottom Right Of The Texture and Quad
163
164 # Right face
165 glTexCoord(1.0, 0.0); glVertex( 1.0, -1.0, -1.0); # Bottom Right Of The Texture and Quad
166 glTexCoord(1.0, 1.0); glVertex( 1.0, 1.0, -1.0); # Top Right Of The Texture and Quad
167 glTexCoord(0.0, 1.0); glVertex( 1.0, 1.0, 1.0); # Top Left Of The Texture and Quad
168 glTexCoord(0.0, 0.0); glVertex( 1.0, -1.0, 1.0); # Bottom Left Of The Texture and Quad
169
170 # Left Face
171 glTexCoord(0.0, 0.0); glVertex(-1.0, -1.0, -1.0); # Bottom Left Of The Texture and Quad
172 glTexCoord(1.0, 0.0); glVertex(-1.0, -1.0, 1.0); # Bottom Right Of The Texture and Quad
173 glTexCoord(1.0, 1.0); glVertex(-1.0, 1.0, 1.0); # Top Right Of The Texture and Quad
174 glTexCoord(0.0, 1.0); glVertex(-1.0, 1.0, -1.0); # Top Left Of The Texture and Quad
175
176 glEnd(); # done with the polygon.
177
178 $xrot+=15.0; # X Axis Rotation
179 $yrot+=15.0; # Y Axis Rotation
180 $zrot+=15.0; # Z Axis Rotation
181
182
183 }
184
185#my $image1,$a; #this can cause a segfault in LoadGLTextures/glTexImage2D !!!
186
187
188sub LoadGLTextures
189 {
190 # Load Texture
191
192 #uncomment this for a different method of loading:
193 #my $img_data = read_gfx_file(FILENAME=>"../../ScrollerDemos/backdrop2.h");
194 #my $pixel_ptr = $img_data->{PIXEL_PTR};
195 #my $pic_info = $img_data->{INFO};
196 #my $width = $pic_info->{WIDTH};
197 #my $height = $pic_info->{HEIGHT};
198
199
200 #if you uncomment the bit above, comment this out:
201 #-snip-
202 my $surface=create_SDL_surface_from_file("Data/crate.png");
203 my $width=$surface->width();
204 my $height=$surface->height();
205 my $pitch = $surface->pitch();
206 my $bytespp= $surface->bytes_per_pixel();
207 my $size=$pitch*$height;
208 my $pixels = $surface->pixels();
209
210 # Create Texture
211 my $textures = glGenTextures(1); #name texture
212 die "Could not genereate textures" unless $$textures[0];
213
214 glBindTexture(GL_TEXTURE_2D, $$textures[0]); # 2d texture
215
216
217 glTexParameter(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR); # scale linearly when image bigger than texture
218 glTexParameter(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); # scale linearly when image smalled than texture
219
220 glTexImage2D(GL_TEXTURE_2D(),
221 0, #level (0 normal, heighr is form mip-mapping)
222 GL_RGB(), #internal format (3=GL_RGB)
223 $width,$height,
224 0, # border
225 GL_RGB(), #format RGB color data
226 GL_UNSIGNED_BYTE(), #unsigned bye data
227 $pixels); #ptr to texture data
228
229 die "Problem setting up 2d Texture (dimensions not a power of 2?)):".glErrorString(glGetError())."\n" if glGetError();
230
231 }
232
233sub create_SDL_surface_from_file
234 {
235 my $filename=shift;
236
237 my $surface = new SDL::Surface( -name => $filename);
238
239 return $surface;
240
241 }
242
243
244
245
246
247###################
248#alternat loading support:
249
250#keep ref counts up:
251my @sprite_c_heap =();
252my @sprite_area =();
253
254sub read_gfx_file
255 {
256 my %args=(
257 TYPE => "GIMP_HEADER",
258 FILENAME => undef,
259 @_,
260 );
261
262 my $struct = read_gimp_header_image($args{FILENAME});
263 my $size = length $struct->{DATA};
264 my $c_array = new OpenGL::Array $size , GL_UNSIGNED_BYTE;
265
266 # c_array is the main reason to do the following ref count trickster:
267 # (otherwise the OpenGL:Array goes out of scope and the memory (image) is ZEROed out (and invalidated) by the DESTROY method
268 push @sprite_c_heap, $c_array;
269 push @sprite_area, $struct;
270
271 $c_array->assign_data(0, $struct->{DATA} ); #take a copy of the data
272
273 return {
274 PIXEL_PTR => $c_array->ptr(), #could return $c_array instead to kepe ref count alive
275 INFO => $struct,
276 };
277
278 #that all needs modularising.....
279
280 }
281
282
283#nasty fixed to 3 byte RGB
284sub read_gimp_header_image
285 {
286 my $file=shift;
287 my $cached_file="$file.cached-bin";
288
289 my ($width, $height,$pixel_format, $data)=(0,0,"RGB","");
290
291 #due to that fact that this aint the fastest code ever, we keep a cache.
292 if (-e $cached_file and (-C $file >= -C $cached_file))
293 {
294
295 print "Reading cached binary bitmap data : $cached_file\n";
296 open (FH, "<$file.cached-bin") or die "Open: $!";
297 my $line="";
298 $width=<FH>;
299 $height=<FH>;
300 $pixel_format=<FH>;
301 chomp $width;
302 chomp $height;
303 chomp $pixel_format; #but who cares? not here anyway!!!
304
305 #slurp in the rest of the file (its pixel data)
306 {
307 local $/;
308 undef $/;
309
310 my @lines= <FH>;
311 $data=join '', @lines;
312 }
313
314 close (FH);
315 }
316 else # there is no cached file, or the cached file is out of date.
317 {
318
319 open (FH, "<$file") or die "Open: $!";
320
321 my @data=();
322 my @pixel=();
323 while (defined (my $line=<FH>))
324 {
325 $width =$1 if ($line =~ /width\s*=\s*(\d+)/);
326 $height=$1 if ($line =~ /height\s*=\s*(\d+)/);
327 if ($line =~ /^\s+\"(.+)\"$/g)
328 {
329 my $c=$1;
330 $c =~ s/\\(.)/$1/g; #remove meta guard
331 $c =~
332 s/
333 \G
334 (.)(.)(.)(.)
335 /
336 @data=(ord($1),ord($2),ord($3),ord($4));
337
338 chr ( ( ( ( $data[0] - 33) << 2) | ( ($data[1] - 33) >> 4) ) ).
339 chr ( ( ( ( ( $data[1] - 33) & 0xF) << 4) | ( ($data[2] - 33) >> 2) ) ).
340 chr ( ( ( ( ( $data[2] - 33) & 0x3) << 6) | ( ($data[3] - 33) ) ) );
341 /gex;
342
343 $data.=$c ;
344 }
345 }
346
347
348 close(FH);
349
350 print "Writing cached binary bitmap data for: $file as $cached_file\n";
351
352 #create a binary cached copy
353 open (FH, ">$cached_file") or die "Open: $!";
354 binmode FH; #we might have to put up with weak OSes.
355 print FH "$width\n$height\n$pixel_format\n$data";
356
357 close(FH);
358 }
359
360
361
362
363 return {
364 WIDTH => $width,
365 HEIGHT => $height,
366 FORMAT => $pixel_format,
367 DATA => $data
368 };
369 }
370
371