[ViewVC] Annotation of: cvs/cfmaps/cfmap2png

#!/opt/bin/perl

# cfmap2png - convert deliantra maps to png+metadata
# Copyright (C) 2005,2007,2008,2009 Marc Lehmann <cfmaps@schmorp.de>
#
# CFARCH2PNG is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with gvpe; if not, write to the Free Software
# Foundation, Inc. 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

# Quoth The master himself:
#
# Object ordering is basically like this:
# top face: players or monsters.  If none on the space, object with highest
# visibility value - if equal, then top object in terms of object stacking on the map.
# middle face: Object with highest visibility (of monster/player on a space).  If
# no monster/player, then object with second highest visibility, or if all equal,
# second top object relative to map stacking.
# Bottom object: the highest object that is a floor type object. 
#
# ... I believe that anytime, but it still doesn't mention the smoothlevel
# interaction :(

our $VERSION = '2.012';

use strict;

use Deliantra;
use List::Util qw(max);

use Gtk2;

sub T (){ 32 }

Deliantra::load_archetypes;
Deliantra::load_tilecache;

sub cfmap_render($;$) {
   my ($mapa, $mapname) = @_;

   my %meta;

   my ($mapx, $mapy);

   my $map;

   for (@{ $mapa->{arch} }) {
      my ($x, $y) = ($_->{x}, $_->{y});

      if ($_->{_name} eq "map") {
         $meta{info} = $_;

         $mapx = $_->{width}  || $x;
         $mapy = $_->{height} || $y;
      } else {
         push @{ $map->[$x][$y] }, $_;

         # arch map is unreliable w.r.t. width and height
         $mapx = $x + 1 if $mapx <= $x;
         $mapy = $y + 1 if $mapy <= $y;
         #$mapx = $a->{x} + 1, warn "$mapname: arch '$a->{_name}' outside map width at ($a->{x}|$a->{y})\n" if $mapx <= $a->{x};
         #$mapy = $a->{y} + 1, warn "$mapname: arch '$a->{_name}' outside map height at ($a->{x}|$a->{y})\n" if $mapy <= $a->{y};
      }
   }

   $meta{width}  = $mapx;
   $meta{height} = $mapy;

   my %draw_info;
   my %map_info;

   # first pass, gather face stacking order, border and corner info
   for my $x (0 .. $mapx - 1) {
      my $col = $map->[$x];
      for my $y (0 .. $mapy - 1) {
         my $as = $col->[$y] || [];

         for my $layer (0 .. $#$as) {
            my $a = $as->[$layer];

            my $o = $ARCH{$a->{_name}}
               or (warn "$mapname: arch '$a->{_name}' not found at ($x|$y)\n"), next;

            my $level = $layer * 256;

            while ($o) {
               my $face = $a->{face} || $o->{face};

               $FACE{$face}
                  or $face =~ s/\.1(\d\d)$/.x$1/;

               $FACE{$face}
                  or (warn "$mapname: face '$face' not found for arch '$a->{_name}' at ($x|$y)\n"), last;

               my $idx = $FACE{$face}{idx};

               my $mx = $x + $o->{x};
               my $my = $y + $o->{y};

               last if 0 > $mx || $mx >= $mapx
                    || 0 > $my || $my >= $mapy;

               push @{ $map_info{$level}{$mx, $my} }, $a;

               $draw_info{$level}{$idx}{$mx, $my} |= 0x2000;

               if (0) { # disable smoothing for the time being
               if (my $sface = $FACEDATA{faceinfo}{$face}{smooth}) {
                  $FACE{$sface}
                     or (warn "$mapname: smoothface '$sface' not found for arch '$a->{_name}' at ($x|$y)\n"), last;
                  my $idx = $FACE{$sface}{idx};
                  my $level = $layer * 256 + $FACEDATA{faceinfo}{$face}{smoothlevel};

                  # full tile
                  $draw_info{$level}{$idx}{$mx    , $my    } |= 0x1000;

                  # borders
                  $draw_info{$level}{$idx}{$mx + 1, $my    } |= 0x0091;
                  $draw_info{$level}{$idx}{$mx    , $my + 1} |= 0x0032;
                  $draw_info{$level}{$idx}{$mx - 1, $my    } |= 0x0064;
                  $draw_info{$level}{$idx}{$mx    , $my - 1} |= 0x00c8;

                  # corners
                  $draw_info{$level}{$idx}{$mx + 1, $my + 1} |= 0x0100;
                  $draw_info{$level}{$idx}{$mx - 1, $my + 1} |= 0x0200;
                  $draw_info{$level}{$idx}{$mx - 1, $my - 1} |= 0x0400;
                  $draw_info{$level}{$idx}{$mx + 1, $my - 1} |= 0x0800;
               }
               }

               $o = $o->{more};
            }
         }
      }
   }

   my $map_pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, $mapx * T, $mapy * T
      or die;
   $map_pb->fill (0xffffff00);

   # second pass, render the map
   for my $level (sort { $a <=> $b } keys %draw_info) {
      my $v = $draw_info{$level};
      while (my ($face, $info) = each %$v) {
         while (my ($xy, $bits) = each %$info) {
            my ($x, $y) = split $;, $xy;

            next if $x < 0 || $x >= $mapx
                 || $y < 0 || $y >= $mapy;

            # bits is __fn cccc CCCC bbbb
            # f  full tile draw with x|y bigface displacement
            # n  do not draw borders&corners
            # c  draw these corners, but...
            # C  ... not these
            # b  draw these borders

            if ($bits & 0x2000) {
               my $ix =     $face % CACHESTRIDE;
               my $iy = int $face / CACHESTRIDE;

               $TILE->composite ($map_pb,
                  $x * T, $y * T,
                  T, T,
                  ($x - $ix) * T, ($y - $iy) * T, 1, 1,
                  "nearest",
                  255
               );
            }

            unless ($bits & 0x1000) {
               my $border = $face + ($bits & 0xf);
               my $bx =     $border % CACHESTRIDE;
               my $by = int $border / CACHESTRIDE;
               $TILE->composite ($map_pb,
                  $x * T, $y * T,
                  T, T,
                  ($x - $bx) * T, ($y - $by) * T, 1, 1,
                  "nearest",
                  255
               ) if $border;

               my $corner = $face + (($bits >> 8) & ~($bits >> 4) & 0xf);
               my $cx =     $corner % CACHESTRIDE;
               my $cy = int $corner / CACHESTRIDE;
               $TILE->composite ($map_pb,
                  $x * T, $y * T,
                  T, T,
                  ($x - $cx) * T, ($y - $cy) * T, 1, 1,
                  "nearest",
                  255
               ) if $corner;
            }
         }
      }
   }

   # third pass, gather meta info
   for my $level (sort { $a <=> $b } keys %map_info) {
      my $info = $map_info{$level};

         while (my ($xy, $as) = each %$info) {
            my ($x, $y) = split $;, $xy;

            next if $x < 0 || $x >= $mapx
                 || $y < 0 || $y >= $mapy;

            push @{ $meta{map}[$x][$y] }, $_ for @$as;
         }
   }

   ($map_pb, \%meta)
}

for my $file (@ARGV) {
   my $stderr;
   $SIG{__WARN__} = sub {
      $stderr .= $_[0];
      print STDERR $_[0];
   };

   $file =~ s/\.map$//;

   eval {
      my $mapa = read_arch "$file.map";
      my ($pb, $meta) = cfmap_render $mapa, $file;
      $pb->save ("$file.png~~", "png");
      system "gm", "convert", "$file.png~~", "-filter" => "lanczos", "-geometry" => "3.125%", "-quality" => 85, "$file.jpg";
      #system "mogrify", "-colors" => 65536, "$file.png~"; # destroys transparency
      system "optipng", "-q", "-out", "$file.png~", "$file.png~~";
#   system "pngnq <\Q$file.png~\E >\Q$file.png\E";
      unlink "$file.png~~";
      utime +(stat "$file.map")[8,9], "$file.jpg"  or die "$file.jpg: $!";
      utime +(stat "$file.map")[8,9], "$file.png~" or die "$file.png~: $!";
      rename "$file.png~", "$file.png";
      1
   } or $stderr .= $@;

   if (length $stderr) {
      open my $fh, ">$file.png.err~"
         or die "$file.png.err~: $!";
      syswrite $fh, $stderr;
      close $fh;
      rename "$file.png.err~", "$file.png.err";
   } else {
      unlink "$file.png.err";
   }
}


Revision:	1.28
Committed:	Thu Oct 22 08:19:15 2009 UTC (14 years, 7 months ago) by root
Branch:	MAIN
CVS Tags:	HEAD
Changes since 1.27:	+1 -1 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	#!/opt/bin/perl
2
3	root	1.27	# cfmap2png - convert deliantra maps to png+metadata
4			# Copyright (C) 2005,2007,2008,2009 Marc Lehmann <cfmaps@schmorp.de>
5	root	1.8	#
6			# CFARCH2PNG is free software; you can redistribute it and/or modify
7			# it under the terms of the GNU General Public License as published by
8			# the Free Software Foundation; either version 2 of the License, or
9			# (at your option) any later version.
10			#
11			# This program is distributed in the hope that it will be useful,
12			# but WITHOUT ANY WARRANTY; without even the implied warranty of
13			# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14			# GNU General Public License for more details.
15			#
16			# You should have received a copy of the GNU General Public License
17			# along with gvpe; if not, write to the Free Software
18			# Foundation, Inc. 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
19
20	root	1.19	# Quoth The master himself:
21			#
22			# Object ordering is basically like this:
23			# top face: players or monsters. If none on the space, object with highest
24			# visibility value - if equal, then top object in terms of object stacking on the map.
25			# middle face: Object with highest visibility (of monster/player on a space). If
26			# no monster/player, then object with second highest visibility, or if all equal,
27			# second top object relative to map stacking.
28			# Bottom object: the highest object that is a floor type object.
29			#
30	root	1.23	# ... I believe that anytime, but it still doesn't mention the smoothlevel
31	root	1.19	# interaction :(
32
33	root	1.27	our $VERSION = '2.012';
34	root	1.9
35	root	1.1	use strict;
36
37	root	1.25	use Deliantra;
38	root	1.1	use List::Util qw(max);
39
40			use Gtk2;
41
42			sub T (){ 32 }
43
44	root	1.25	Deliantra::load_archetypes;
45			Deliantra::load_tilecache;
46	root	1.1
47			sub cfmap_render($;$) {
48			my ($mapa, $mapname) = @_;
49
50			my %meta;
51
52			my ($mapx, $mapy);
53
54	root	1.10	my $map;
55	root	1.1
56			for (@{ $mapa->{arch} }) {
57	root	1.10	my ($x, $y) = ($_->{x}, $_->{y});
58
59	root	1.1	if ($_->{_name} eq "map") {
60			$meta{info} = $_;
61
62	root	1.10	$mapx = $_->{width} \|\| $x;
63			$mapy = $_->{height} \|\| $y;
64	root	1.1	} else {
65	root	1.10	push @{ $map->[$x][$y] }, $_;
66	root	1.1
67			# arch map is unreliable w.r.t. width and height
68	root	1.10	$mapx = $x + 1 if $mapx <= $x;
69			$mapy = $y + 1 if $mapy <= $y;
70	root	1.1	#$mapx = $a->{x} + 1, warn "$mapname: arch '$a->{_name}' outside map width at ($a->{x}\|$a->{y})\n" if $mapx <= $a->{x};
71			#$mapy = $a->{y} + 1, warn "$mapname: arch '$a->{_name}' outside map height at ($a->{x}\|$a->{y})\n" if $mapy <= $a->{y};
72			}
73			}
74
75			$meta{width} = $mapx;
76			$meta{height} = $mapy;
77
78			my %draw_info;
79	root	1.10	my %map_info;
80	root	1.1
81			# first pass, gather face stacking order, border and corner info
82			for my $x (0 .. $mapx - 1) {
83			my $col = $map->[$x];
84			for my $y (0 .. $mapy - 1) {
85			my $as = $col->[$y] \|\| [];
86	root	1.16
87	root	1.1	for my $layer (0 .. $#$as) {
88			my $a = $as->[$layer];
89
90	root	1.23	my $o = $ARCH{$a->{_name}}
91	root	1.1	or (warn "$mapname: arch '$a->{_name}' not found at ($x\|$y)\n"), next;
92
93	root	1.23	my $level = $layer * 256;
94	root	1.1
95	root	1.5	while ($o) {
96			my $face = $a->{face} \|\| $o->{face};
97	root	1.1
98	root	1.23	$FACE{$face}
99	root	1.27	or $face =~ s/\.1(\d\d)$/.x$1/;
100
101			$FACE{$face}
102	root	1.5	or (warn "$mapname: face '$face' not found for arch '$a->{_name}' at ($x\|$y)\n"), last;
103	root	1.1
104	root	1.23	my $idx = $FACE{$face}{idx};
105
106	root	1.1	my $mx = $x + $o->{x};
107			my $my = $y + $o->{y};
108
109	root	1.2	last if 0 > $mx \|\| $mx >= $mapx
110			\|\| 0 > $my \|\| $my >= $mapy;
111	root	1.1
112	root	1.10	push @{ $map_info{$level}{$mx, $my} }, $a;
113
114	root	1.23	$draw_info{$level}{$idx}{$mx, $my} \|= 0x2000;
115	root	1.10
116	root	1.23	if (0) { # disable smoothing for the time being
117			if (my $sface = $FACEDATA{faceinfo}{$face}{smooth}) {
118			$FACE{$sface}
119			or (warn "$mapname: smoothface '$sface' not found for arch '$a->{_name}' at ($x\|$y)\n"), last;
120			my $idx = $FACE{$sface}{idx};
121			my $level = $layer * 256 + $FACEDATA{faceinfo}{$face}{smoothlevel};
122	root	1.1
123			# full tile
124	root	1.23	$draw_info{$level}{$idx}{$mx , $my } \|= 0x1000;
125	root	1.1
126			# borders
127	root	1.23	$draw_info{$level}{$idx}{$mx + 1, $my } \|= 0x0091;
128			$draw_info{$level}{$idx}{$mx , $my + 1} \|= 0x0032;
129			$draw_info{$level}{$idx}{$mx - 1, $my } \|= 0x0064;
130			$draw_info{$level}{$idx}{$mx , $my - 1} \|= 0x00c8;
131	root	1.1
132			# corners
133	root	1.23	$draw_info{$level}{$idx}{$mx + 1, $my + 1} \|= 0x0100;
134			$draw_info{$level}{$idx}{$mx - 1, $my + 1} \|= 0x0200;
135			$draw_info{$level}{$idx}{$mx - 1, $my - 1} \|= 0x0400;
136			$draw_info{$level}{$idx}{$mx + 1, $my - 1} \|= 0x0800;
137			}
138	root	1.1	}
139
140			$o = $o->{more};
141			}
142			}
143			}
144			}
145
146			my $map_pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, $mapx * T, $mapy * T
147	root	1.23	or die;
148	root	1.7	$map_pb->fill (0xffffff00);
149	root	1.1
150	root	1.10	# second pass, render the map
151	root	1.1	for my $level (sort { $a <=> $b } keys %draw_info) {
152			my $v = $draw_info{$level};
153	root	1.23	while (my ($face, $info) = each %$v) {
154	root	1.1	while (my ($xy, $bits) = each %$info) {
155			my ($x, $y) = split $;, $xy;
156
157			next if $x < 0 \|\| $x >= $mapx
158			\|\| $y < 0 \|\| $y >= $mapy;
159
160	root	1.23	# bits is __fn cccc CCCC bbbb
161	root	1.13	# f full tile draw with x\|y bigface displacement
162			# n do not draw borders&corners
163			# c draw these corners, but...
164			# C ... not these
165	root	1.1	# b draw these borders
166
167			if ($bits & 0x2000) {
168	root	1.23	my $ix = $face % CACHESTRIDE;
169			my $iy = int $face / CACHESTRIDE;
170	root	1.1
171	root	1.23	$TILE->composite ($map_pb,
172	root	1.1	$x * T, $y * T,
173			T, T,
174	root	1.23	($x - $ix) * T, ($y - $iy) * T, 1, 1,
175	root	1.1	"nearest",
176			255
177			);
178			}
179
180			unless ($bits & 0x1000) {
181	root	1.23	my $border = $face + ($bits & 0xf);
182			my $bx = $border % CACHESTRIDE;
183			my $by = int $border / CACHESTRIDE;
184			$TILE->composite ($map_pb,
185	root	1.1	$x * T, $y * T,
186			T, T,
187	root	1.23	($x - $bx) * T, ($y - $by) * T, 1, 1,
188	root	1.1	"nearest",
189			255
190			) if $border;
191
192	root	1.23	my $corner = $face + (($bits >> 8) & ~($bits >> 4) & 0xf);
193			my $cx = $corner % CACHESTRIDE;
194			my $cy = int $corner / CACHESTRIDE;
195			$TILE->composite ($map_pb,
196	root	1.1	$x * T, $y * T,
197			T, T,
198	root	1.23	($x - $cx) * T, ($y - $cy) * T, 1, 1,
199	root	1.1	"nearest",
200			255
201			) if $corner;
202			}
203			}
204			}
205			}
206
207	root	1.10	# third pass, gather meta info
208			for my $level (sort { $a <=> $b } keys %map_info) {
209			my $info = $map_info{$level};
210
211			while (my ($xy, $as) = each %$info) {
212			my ($x, $y) = split $;, $xy;
213
214			next if $x < 0 \|\| $x >= $mapx
215			\|\| $y < 0 \|\| $y >= $mapy;
216
217			push @{ $meta{map}[$x][$y] }, $_ for @$as;
218			}
219			}
220
221	root	1.1	($map_pb, \%meta)
222			}
223
224			for my $file (@ARGV) {
225	root	1.27	my $stderr;
226			$SIG{__WARN__} = sub {
227			$stderr .= $_[0];
228			print STDERR $_[0];
229			};
230
231	root	1.21	$file =~ s/\.map$//;
232	root	1.27
233			eval {
234			my $mapa = read_arch "$file.map";
235			my ($pb, $meta) = cfmap_render $mapa, $file;
236			$pb->save ("$file.png~~", "png");
237			system "gm", "convert", "$file.png~~", "-filter" => "lanczos", "-geometry" => "3.125%", "-quality" => 85, "$file.jpg";
238			#system "mogrify", "-colors" => 65536, "$file.png~"; # destroys transparency
239			system "optipng", "-q", "-out", "$file.png~", "$file.png~~";
240	root	1.15	# system "pngnq <\Q$file.png~\E >\Q$file.png\E";
241	root	1.27	unlink "$file.png~~";
242			utime +(stat "$file.map")[8,9], "$file.jpg" or die "$file.jpg: $!";
243			utime +(stat "$file.map")[8,9], "$file.png~" or die "$file.png~: $!";
244			rename "$file.png~", "$file.png";
245			1
246	root	1.28	} or $stderr .= $@;
247	root	1.27
248			if (length $stderr) {
249			open my $fh, ">$file.png.err~"
250			or die "$file.png.err~: $!";
251			syswrite $fh, $stderr;
252			close $fh;
253			rename "$file.png.err~", "$file.png.err";
254			} else {
255			unlink "$file.png.err";
256			}
257	root	1.1	}
258
259
260
261
262
263