1 | #!/opt/bin/perl |
1 | #!/opt/bin/perl |
|
|
2 | |
|
|
3 | use strict; |
|
|
4 | |
|
|
5 | use Glib; |
|
|
6 | use Gtk2 -init; |
2 | |
7 | |
3 | use SDL; |
8 | use SDL; |
4 | use SDL::App; |
9 | use SDL::App; |
5 | use SDL::Event; |
10 | use SDL::Event; |
6 | use SDL::Surface; |
11 | use SDL::Surface; |
|
|
12 | use SDL::OpenGL; |
|
|
13 | use SDL::OpenGL::Constants; |
7 | |
14 | |
8 | my $conn; |
15 | use Crossfire; |
9 | my $map_surface; |
16 | use Crossfire::Client; |
|
|
17 | use Crossfire::Protocol; |
10 | |
18 | |
11 | my $app = new SDL::App |
19 | use Client::Util; |
12 | -flags => SDL_HWSURFACE | SDL_ANYFORMAT | SDL_HWACCEL | SDL_ASYNCBLIT, |
20 | |
|
|
21 | our $VERSION = '0.1'; |
|
|
22 | |
|
|
23 | our $CFG; |
|
|
24 | our $CONN; |
|
|
25 | |
|
|
26 | our $SDL_TIMER; |
|
|
27 | our $SDL_APP; |
|
|
28 | our $SDL_EV = new SDL::Event; |
|
|
29 | our %SDL_CB; |
|
|
30 | |
|
|
31 | sub init_screen { |
|
|
32 | # nuke all gl context data |
|
|
33 | |
|
|
34 | $SDL_APP = new SDL::App |
|
|
35 | -flags => SDL_ANYFORMAT | SDL_HWSURFACE, |
13 | -title => "Crossfire+ Client", |
36 | -title => "Crossfire+ Client", |
14 | -width => 640, |
37 | -width => $CFG->{width}, |
15 | -height => 480, |
38 | -height => $CFG->{height}, |
16 | -depth => 24, |
39 | -opengl => 1, |
|
|
40 | -red_size => 8, |
|
|
41 | -green_size => 8, |
|
|
42 | -blue_size => 8, |
17 | -double_buffer => 1, |
43 | -double_buffer => 1, |
|
|
44 | -fullscreen => $CFG->{fullscreen}, |
18 | -resizeable => 1; |
45 | -resizeable => 0; |
19 | |
46 | |
20 | sub redraw { |
47 | glEnable GL_TEXTURE_2D; |
21 | $map_surface or return; |
48 | glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE; |
|
|
49 | glShadeModel GL_FLAT; |
|
|
50 | glDisable GL_DEPTH_TEST; |
|
|
51 | glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA; |
|
|
52 | glEnable GL_BLEND; |
22 | |
53 | |
23 | $map_surface->blit (0, $app, 0); |
54 | glMatrixMode GL_PROJECTION; |
24 | $app->sync; |
55 | glLoadIdentity; |
25 | } |
56 | glOrtho 0, $CFG->{width} / 32, $CFG->{height} / 32, 0, -1 , 1; |
26 | |
57 | |
27 | my $ev = new SDL::Event; |
58 | # re-bind all textures |
28 | my %ev_cb; |
|
|
29 | |
|
|
30 | sub event(&$) { |
|
|
31 | $ev_cb{$_[0]->()} = $_[1]; |
|
|
32 | } |
59 | } |
33 | |
60 | |
34 | sub does(&) { shift } |
61 | sub start_game { |
|
|
62 | $SDL_TIMER = add Glib::Timeout 1000/20, sub { |
|
|
63 | while ($SDL_EV->poll) { |
|
|
64 | ($SDL_CB{$SDL_EV->type} || sub { warn "unhandled event ", $SDL_EV->type })->(); |
|
|
65 | } |
35 | |
66 | |
36 | event {SDL_QUIT} does { |
67 | 1 |
37 | exit; |
68 | }; |
38 | }; |
|
|
39 | |
69 | |
40 | event {SDL_VIDEORESIZE} does { |
70 | init_screen; |
41 | print "resize\n"; |
|
|
42 | }; |
|
|
43 | |
71 | |
44 | event {SDL_KEYDOWN} does { |
72 | $CONN = new conn |
45 | print "keypress\n"; |
73 | host => $CFG->{host}, |
46 | }; |
74 | port => $CFG->{port}; |
|
|
75 | } |
47 | |
76 | |
48 | event {SDL_KEYUP} does { |
77 | sub stop_game { |
49 | print "keyup\n";#d# |
78 | remove Glib::Source $SDL_TIMER; |
50 | }; |
|
|
51 | |
79 | |
52 | event {SDL_MOUSEMOTION} does { |
80 | undef $SDL_APP; |
53 | print "motion\n"; |
81 | SDL::Quit; |
54 | }; |
82 | } |
55 | |
83 | |
56 | event {SDL_MOUSEBUTTONDOWN} does { |
84 | sub refresh { |
57 | print "button\n"; |
85 | glClearColor 0, 0, 0, 0; |
58 | }; |
86 | glClear GL_COLOR_BUFFER_BIT; |
59 | |
87 | |
60 | event {SDL_MOUSEBUTTONUP} does { |
88 | my $map = $CONN->{map}; |
61 | print "buttup\n"; |
|
|
62 | }; |
|
|
63 | |
89 | |
64 | event {SDL_ACTIVEEVENT} does { |
90 | for my $x (0 .. $CONN->{mapw} - 1) { |
65 | print "active\n"; |
91 | for my $y (0 .. $CONN->{maph} - 1) { |
66 | }; |
|
|
67 | |
92 | |
68 | package Crossfire::Protocol; |
93 | my $cell = $map->[$x][$y] |
|
|
94 | or next; |
69 | |
95 | |
70 | use AnyEvent; |
96 | my $darkness = $cell->[3] * (1 / 255); |
71 | use IO::Socket::INET; |
97 | glColor $darkness, $darkness, $darkness; |
72 | |
98 | |
73 | sub new { |
99 | for my $num (grep $_, $cell->[0], $cell->[1], $cell->[2]) { |
74 | my $class = shift; |
100 | my $tex = $CONN->{face}[$num]{texture} || 0; |
75 | my $self = bless { @_ }, $class; |
101 | |
|
|
102 | glBindTexture GL_TEXTURE_2D, $tex; |
76 | |
103 | |
77 | $self->{fh} = new IO::Socket::INET PeerHost => $self->{host}, PeerPort => $self->{port} |
104 | glBegin GL_QUADS; |
78 | or die "$self->{host}:$self->{port}: $!"; |
105 | glTexCoord 0, 0; glVertex $x, $y; |
79 | $self->{fh}->blocking (0); # stupid nonblock default |
106 | glTexCoord 0, 1; glVertex $x, $y + 1; |
80 | |
107 | glTexCoord 1, 1; glVertex $x + 1, $y + 1; |
81 | my $buf; |
108 | glTexCoord 1, 0; glVertex $x + 1, $y; |
82 | |
|
|
83 | $self->{w} = AnyEvent->io (fh => $self->{fh}, poll => 'r', cb => sub { |
|
|
84 | if (sysread $self->{fh}, $buf, 16384, length $buf) { |
|
|
85 | if (2 <= length $buf) { |
|
|
86 | my $len = unpack "n", $buf; |
|
|
87 | if ($len + 2 <= length $buf) { |
|
|
88 | substr $buf, 0, 2, ""; |
|
|
89 | $self->feed (substr $buf, 0, $len, ""); |
|
|
90 | } |
109 | glEnd; |
91 | } |
110 | } |
92 | } else { |
|
|
93 | delete $self->{w}; |
|
|
94 | close $self->{fh}; |
|
|
95 | } |
|
|
96 | }); |
|
|
97 | |
|
|
98 | $self->send ("version 1023 1027 perlclient"); |
|
|
99 | $self->send ("setup sound 1 exp 1 map1acmd 1 itemcmd 2 darkness 1 mapsize 63x63 newmapcmd 1 facecache 1 extendedMapInfos 1 extendedTextInfos 1"); |
|
|
100 | $self->send ("addme"); |
|
|
101 | |
|
|
102 | $self |
|
|
103 | } |
|
|
104 | |
|
|
105 | sub feed { |
|
|
106 | my ($self, $data) = @_; |
|
|
107 | |
|
|
108 | $data =~ s/^(\S+)\s// |
|
|
109 | or return; |
|
|
110 | |
|
|
111 | my $command = "feed_$1"; |
|
|
112 | |
|
|
113 | $self->$command ($data); |
|
|
114 | } |
|
|
115 | |
|
|
116 | sub feed_version { |
|
|
117 | my ($self, $version) = @_; |
|
|
118 | } |
|
|
119 | |
|
|
120 | sub feed_setup { |
|
|
121 | my ($self, $data) = @_; |
|
|
122 | |
|
|
123 | $data =~ s/^ +//; |
|
|
124 | |
|
|
125 | $self->{setup} = { split / +/, $data }; |
|
|
126 | |
|
|
127 | ($self->{mapw}, $self->{maph}) = split /x/, $self->{setup}{mapsize}; |
|
|
128 | |
|
|
129 | $self->feed_newmap; |
|
|
130 | } |
|
|
131 | |
|
|
132 | sub feed_query { |
|
|
133 | my ($self, $data) = @_; |
|
|
134 | warn "Q<$data>\n"; |
|
|
135 | } |
|
|
136 | |
|
|
137 | sub feed_stats { |
|
|
138 | my ($self, $data) = @_; |
|
|
139 | # warn "S<$data>\n"; |
|
|
140 | } |
|
|
141 | |
|
|
142 | sub feed_face1 { |
|
|
143 | my ($self, $data) = @_; |
|
|
144 | |
|
|
145 | my ($num, $chksum, $name) = unpack "nNa*", $data; |
|
|
146 | |
|
|
147 | $self->{face}[$num] = { name => $name, chksum => $chksum }; |
|
|
148 | } |
|
|
149 | |
|
|
150 | sub feed_drawinfo { |
|
|
151 | my ($self, $data) = @_; |
|
|
152 | # warn "<$data>\n"; |
|
|
153 | } |
|
|
154 | |
|
|
155 | sub feed_delinv { |
|
|
156 | my ($self, $data) = @_; |
|
|
157 | } |
|
|
158 | |
|
|
159 | sub feed_item2 { |
|
|
160 | my ($self, $data) = @_; |
|
|
161 | } |
|
|
162 | |
|
|
163 | sub feed_map1a { |
|
|
164 | my ($self, $data) = @_; |
|
|
165 | |
|
|
166 | my $map = $self->{map} ||= []; |
|
|
167 | |
|
|
168 | my @dirty; |
|
|
169 | my ($coord, $x, $y, $darkness, $fa, $fb, $fc, $cell); |
|
|
170 | |
|
|
171 | while (length $data) { |
|
|
172 | $coord = unpack "n", substr $data, 0, 2, ""; |
|
|
173 | |
|
|
174 | $x = ($coord >> 10) & 63; |
|
|
175 | $y = ($coord >> 4) & 63; |
|
|
176 | |
|
|
177 | $cell = $map->[$x][$y] ||= []; |
|
|
178 | |
|
|
179 | $cell->[3] = unpack "C", substr $data, 0, 1, "" |
|
|
180 | if $coord & 8; |
|
|
181 | $cell->[0] = unpack "n", substr $data, 0, 2, "" |
|
|
182 | if $coord & 4; |
|
|
183 | $cell->[1] = unpack "n", substr $data, 0, 2, "" |
|
|
184 | if $coord & 2; |
|
|
185 | $cell->[2] = unpack "n", substr $data, 0, 2, "" |
|
|
186 | if $coord & 1; |
|
|
187 | |
|
|
188 | @$cell = () |
|
|
189 | unless $coord & 15; |
|
|
190 | |
|
|
191 | push @dirty, [$x, $y]; |
|
|
192 | } |
|
|
193 | |
|
|
194 | $self->map_update (\@dirty); |
|
|
195 | } |
|
|
196 | |
|
|
197 | sub feed_map_scroll { |
|
|
198 | my ($self, $data) = @_; |
|
|
199 | |
|
|
200 | my ($dx, $dy) = split / /, $data; |
|
|
201 | |
|
|
202 | my $map = $self->{map} ||= []; |
|
|
203 | |
|
|
204 | $self->{mapx} += $dx; |
|
|
205 | $self->{mapy} += $dy; |
|
|
206 | |
|
|
207 | if ($dx > 0) { |
|
|
208 | unshift @$_, ([]) x $dx for @$map; |
|
|
209 | } elsif ($dx < 0) { |
|
|
210 | splice @$_, 0, -$dx, () for @$map; |
|
|
211 | } |
|
|
212 | |
|
|
213 | if ($dy > 0) { |
|
|
214 | unshift @$map, ([]) x $dy; |
|
|
215 | } elsif ($dy < 0) { |
|
|
216 | splice @$map, 0, -$dy, (); |
|
|
217 | } |
|
|
218 | |
|
|
219 | $self->map_scroll ($dx, $dy); |
|
|
220 | } |
|
|
221 | |
|
|
222 | sub feed_newmap { |
|
|
223 | my ($self) = @_; |
|
|
224 | |
|
|
225 | $self->{map} = []; |
|
|
226 | $self->{mapx} = 0; |
|
|
227 | $self->{mapy} = 0; |
|
|
228 | |
|
|
229 | $self->map_clear; |
|
|
230 | } |
|
|
231 | |
|
|
232 | sub feed_image { |
|
|
233 | my ($self, $data) = @_; |
|
|
234 | |
|
|
235 | my ($face, $len, $data) = unpack "NNa*", $data; |
|
|
236 | |
|
|
237 | $self->{face}[$face]{image} = $data; |
|
|
238 | |
|
|
239 | $self->face_update ($face, $self->{face}[$face]); |
|
|
240 | } |
|
|
241 | |
|
|
242 | sub map_clear { } |
|
|
243 | sub map_update { } |
|
|
244 | sub map_scroll { } |
|
|
245 | |
|
|
246 | sub face_update { } |
|
|
247 | |
|
|
248 | sub send { |
|
|
249 | my ($self, $data) = @_; |
|
|
250 | |
|
|
251 | $data = pack "na*", length $data, $data; |
|
|
252 | |
|
|
253 | syswrite $self->{fh}, $data; |
|
|
254 | } |
|
|
255 | |
|
|
256 | package conn; |
|
|
257 | |
|
|
258 | @ISA = Crossfire::Protocol::; |
|
|
259 | |
|
|
260 | sub map_update { |
|
|
261 | my ($self, $dirty) = @_; |
|
|
262 | |
|
|
263 | for (@$dirty) { |
|
|
264 | my ($x, $y) = @$_; |
|
|
265 | |
|
|
266 | my $px = $x * 32; |
|
|
267 | my $py = $y * 32; |
|
|
268 | |
|
|
269 | my $dst = new SDL::Rect -x => $px, -y => $py, -width => 32, -height => 32; |
|
|
270 | |
|
|
271 | my $cell = $self->{map}[$x][$y]; |
|
|
272 | |
|
|
273 | if ($cell) { |
|
|
274 | $cell->[0] or $map_surface->fill ($dst, new SDL::Color -r => 0, -g => 0, -b => 0); # is_floor is opaque, I hope |
|
|
275 | |
|
|
276 | for my $num (grep $_, $cell->[0], $cell->[1], $cell->[2]) { |
|
|
277 | my $surface = $self->{face}[$num]{surface} ||= do { |
|
|
278 | $self->send ("askface $num"); |
|
|
279 | |
|
|
280 | # TODO: fog of "war" |
|
|
281 | my $surface = new SDL::Surface |
|
|
282 | -flags => SDL::SDL_HWSURFACE | SDL::SDL_ANYFORMAT | SDL::SDL_HWACCEL | SDL::SDL_ASYNCBLIT, |
|
|
283 | -width => 32, |
|
|
284 | -height => 32, |
|
|
285 | -depth => 32; |
|
|
286 | |
|
|
287 | $surface->fill (0, new SDL::Color -r => 128, -g => 128, -b => 128); |
|
|
288 | |
|
|
289 | $surface |
|
|
290 | }; |
|
|
291 | |
|
|
292 | $surface->blit (0, $map_surface, $dst); |
|
|
293 | } |
|
|
294 | } else { |
|
|
295 | $map_surface->fill ($dst, new SDL::Color -r => 0, -g => 0, -b => 0); |
|
|
296 | } |
111 | } |
297 | } |
112 | } |
298 | |
113 | |
299 | ::redraw; |
114 | SDL::GLSwapBuffers; |
300 | } |
115 | } |
301 | |
116 | |
|
|
117 | %SDL_CB = ( |
|
|
118 | SDL_QUIT() => sub { |
|
|
119 | warn "sdl quit\n";#d# |
|
|
120 | exit; |
|
|
121 | }, |
|
|
122 | SDL_VIDEORESIZE() => sub { |
|
|
123 | }, |
|
|
124 | SDL_VIDEOEXPOSE() => sub { |
|
|
125 | refresh; |
|
|
126 | }, |
|
|
127 | SDL_KEYDOWN() => sub { |
|
|
128 | }, |
|
|
129 | SDL_KEYUP() => sub { |
|
|
130 | }, |
|
|
131 | SDL_MOUSEMOTION() => sub { |
|
|
132 | warn "sdl motion\n";#d# |
|
|
133 | }, |
|
|
134 | SDL_MOUSEBUTTONDOWN() => sub { |
|
|
135 | }, |
|
|
136 | SDL_MOUSEBUTTONUP() => sub { |
|
|
137 | }, |
|
|
138 | SDL_ACTIVEEVENT() => sub { |
|
|
139 | warn "active\n";#d# |
|
|
140 | }, |
|
|
141 | ); |
|
|
142 | |
|
|
143 | @conn::ISA = Crossfire::Protocol::; |
|
|
144 | |
|
|
145 | sub conn::map_update { |
|
|
146 | my ($self, $dirty) = @_; |
|
|
147 | |
|
|
148 | refresh; |
|
|
149 | } |
|
|
150 | |
302 | sub map_scroll { |
151 | sub conn::map_scroll { |
303 | my ($self, $dx, $dy) = @_; |
152 | my ($self, $dx, $dy) = @_; |
304 | |
153 | |
305 | ::redraw; |
154 | refresh; |
306 | } |
155 | } |
307 | |
156 | |
308 | sub map_clear { |
157 | sub conn::map_clear { |
309 | my ($self) = @_; |
158 | my ($self) = @_; |
310 | |
159 | |
311 | $map_surface = new SDL::Surface |
160 | refresh; |
312 | -flags => SDL::HWSURFACE, |
|
|
313 | -width => $self->{mapw} * 32, |
|
|
314 | -height => $self->{maph} * 32, |
|
|
315 | -depth => 32; |
|
|
316 | |
|
|
317 | SDL::SetClipRect $$map_surface, 0; |
|
|
318 | $map_surface->fill (0, new SDL::Color -r => 0, -g => 0, -b => 0); |
|
|
319 | |
|
|
320 | ::redraw; |
|
|
321 | } |
161 | } |
322 | |
162 | |
323 | sub face_update { |
163 | sub conn::face_update { |
324 | my ($self, $num, $face) = @_; |
164 | my ($self, $num, $face) = @_; |
325 | |
165 | |
326 | warn "up face $self,$num,$face\n";#d# |
166 | my $pb = new Gtk2::Gdk::PixbufLoader; |
327 | #TODO |
|
|
328 | open my $fh, ">:raw", "/tmp/x~"; |
|
|
329 | syswrite $fh, $face->{image}; |
167 | $pb->write ($face->{image}); |
330 | close $fh; |
168 | $pb->close; |
331 | |
169 | |
332 | $face->{surface} = (new SDL::Surface -name => "/tmp/x~")->display_format; |
170 | $pb = $pb->get_pixbuf; |
|
|
171 | $pb = $pb->add_alpha (0, 0, 0, 0); |
333 | |
172 | |
334 | unlink "/tmp/x~"; |
173 | glGetError(); |
|
|
174 | my ($tex) = @{glGenTextures 1}; |
335 | |
175 | |
336 | my @dirty; |
176 | $face->{texture} = $tex; |
337 | |
|
|
338 | for my $x (0..$self->{mapw} - 1) { |
|
|
339 | for my $y (0..$self->{maph} - 1) { |
|
|
340 | push @dirty, [$x, $y] |
|
|
341 | if grep $_ == $num, @{$self->{map}[$x][$y] || []}; |
|
|
342 | } |
|
|
343 | } |
177 | |
344 | $self->map_update (\@dirty); |
178 | glBindTexture GL_TEXTURE_2D, $tex; |
|
|
179 | my $glerr=glGetError(); die "a: ".gluErrorString($glerr)."\n" if $glerr; |
|
|
180 | |
|
|
181 | glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR; |
|
|
182 | glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR;#_MIPMAP_LINEAR; |
|
|
183 | glTexParameter GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP; |
|
|
184 | glTexParameter GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP; |
|
|
185 | |
|
|
186 | glTexImage2D GL_TEXTURE_2D, 0, |
|
|
187 | GL_RGBA8, |
|
|
188 | $pb->get_width, $pb->get_height, |
|
|
189 | 0, |
|
|
190 | GL_RGBA, |
|
|
191 | GL_UNSIGNED_BYTE, |
|
|
192 | $pb->get_pixels; |
|
|
193 | my $glerr=glGetError(); die "Problem setting up 2d Texture (dimensions not a power of 2?)):".gluErrorString($glerr)."\n" if $glerr; |
345 | } |
194 | } |
346 | |
|
|
347 | package main; |
|
|
348 | |
195 | |
349 | ############################################################################# |
196 | ############################################################################# |
350 | |
197 | |
351 | use Event; |
198 | Client::Util::read_cfg "$Crossfire::VARDIR/pclientrc"; |
352 | |
199 | |
353 | $conn = new conn |
200 | $CFG ||= { |
|
|
201 | width => 640, |
|
|
202 | height => 480, |
|
|
203 | fullscreen => 0, |
354 | host => "cf.schmorp.de", |
204 | host => "crossfire.schmorp.de", |
355 | port => 13327; |
205 | port => 13327, |
356 | |
|
|
357 | Event->timer (after => 0, interval => 1/20, hard => 1, cb => sub { |
|
|
358 | while ($ev->poll) { |
|
|
359 | ($ev_cb{$ev->type} || sub { warn "unhandled event ", $ev->type })->(); |
|
|
360 | } |
|
|
361 | }); |
206 | }; |
362 | |
207 | |
363 | Event::loop; |
208 | Client::Util::run_config_dialog; |
364 | |
209 | |
|
|
210 | main Gtk2; |
365 | |
211 | |