[ViewVC] Diff of: cvs/deliantra/Deliantra/Deliantra.pm

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.66 by root, Wed Jun 14 19:23:32 2006 UTC vs.
Revision 1.105 by root, Tue Apr 17 18:50:41 2007 UTC

…		…
4		4
5	=cut	5	=cut
6		6
7	package Crossfire;	7	package Crossfire;
8		8
9	our $VERSION = '0.1';	9	our $VERSION = '0.98';
10		10
11	use strict;	11	use strict;
12		12
13	use base 'Exporter';	13	use base 'Exporter';
14		14
…		…
19		19
20	our @EXPORT = qw(	20	our @EXPORT = qw(
21	read_pak read_arch ARCH TILESIZE $TILE FACE editor_archs arch_extents	21	read_pak read_arch ARCH TILESIZE $TILE FACE editor_archs arch_extents
22	);	22	);
23		23
		24	use JSON::XS qw(from_json to_json);
		25
24	our $LIB = $ENV{CROSSFIRE_LIBDIR};	26	our $LIB = $ENV{CROSSFIRE_LIBDIR};
25		27
26	our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire" : File::Spec->tmpdir . "/crossfire";	28	our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire"
		29	: $ENV{AppData} ? "$ENV{APPDATA}/crossfire"
		30	: File::Spec->tmpdir . "/crossfire";
27		31
28	mkdir $VARDIR, 0777;	32	mkdir $VARDIR, 0777;
29		33
30	sub TILESIZE (){ 32 }	34	sub TILESIZE (){ 32 }
31		35
…		…
44	qw(move_type move_block move_allow move_on move_off move_slow);	48	qw(move_type move_block move_allow move_on move_off move_slow);
45		49
46	# same as in server save routine, to (hopefully) be compatible	50	# same as in server save routine, to (hopefully) be compatible
47	# to the other editors.	51	# to the other editors.
48	our @FIELD_ORDER_MAP = (qw(	52	our @FIELD_ORDER_MAP = (qw(
		53	file_format_version
49	name swap_time reset_timeout fixed_resettime difficulty region	54	name attach swap_time reset_timeout fixed_resettime difficulty region
50	shopitems shopgreed shopmin shopmax shoprace	55	shopitems shopgreed shopmin shopmax shoprace
51	darkness width height enter_x enter_y msg maplore	56	darkness width height enter_x enter_y msg maplore
52	unique template	57	unique template
53	outdoor temp pressure humid windspeed winddir sky nosmooth	58	outdoor temp pressure humid windspeed winddir sky nosmooth
54	tile_path_1 tile_path_2 tile_path_3 tile_path_4	59	tile_path_1 tile_path_2 tile_path_3 tile_path_4
55	));	60	));
56		61
57	our @FIELD_ORDER = (qw(	62	our @FIELD_ORDER = (qw(
		63	inherit
		64
58	elevation	65	elevation
59		66
60	name name_pl custom_name title race	67	name name_pl custom_name attach title race
61	slaying skill msg lore other_arch face	68	slaying skill msg lore other_arch
62	#todo-events
63	animation is_animated	69	face animation is_animated
		70	magicmap smoothlevel smoothface
64	str dex con wis pow cha int	71	str dex con wis pow cha int
65	hp maxhp sp maxsp grace maxgrace	72	hp maxhp sp maxsp grace maxgrace
66	exp perm_exp expmul	73	exp perm_exp expmul
67	food dam luck wc ac x y speed speed_left move_state attack_movement	74	food dam luck wc ac x y speed speed_left move_state attack_movement
68	nrof level direction type subtype attacktype	75	nrof level direction type subtype attacktype
…		…
124	sub MOVE_FLY_HIGH (){ 0x04 }	131	sub MOVE_FLY_HIGH (){ 0x04 }
125	sub MOVE_FLYING (){ 0x06 }	132	sub MOVE_FLYING (){ 0x06 }
126	sub MOVE_SWIM (){ 0x08 }	133	sub MOVE_SWIM (){ 0x08 }
127	sub MOVE_BOAT (){ 0x10 }	134	sub MOVE_BOAT (){ 0x10 }
128	sub MOVE_KNOWN (){ 0x1f } # all of above	135	sub MOVE_KNOWN (){ 0x1f } # all of above
129	sub MOVE_ALLBIT (){ 0x10000 }
130	sub MOVE_ALL (){ 0x1001f } # very special value, more PITA	136	sub MOVE_ALL (){ 0x10000 } # very special value
		137
		138	our %MOVE_TYPE = (
		139	walk => MOVE_WALK,
		140	fly_low => MOVE_FLY_LOW,
		141	fly_high => MOVE_FLY_HIGH,
		142	flying => MOVE_FLYING,
		143	swim => MOVE_SWIM,
		144	boat => MOVE_BOAT,
		145	all => MOVE_ALL,
		146	);
		147
		148	our @MOVE_TYPE = qw(all walk flying fly_low fly_high swim boat);
		149
		150	{
		151	package Crossfire::MoveType;
		152
		153	use overload
		154	'=' => sub { bless [@{$_[0]}], ref $_[0] },
		155	'""' => \&as_string,
		156	'>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef },
		157	'+=' => sub { $_[0][0] \|= $MOVE_TYPE{$_[1]}; $_[0][1] \|= $MOVE_TYPE{$_[1]}; &normalise },
		158	'-=' => sub { $_[0][0] \|= $MOVE_TYPE{$_[1]}; $_[0][1] &= ~$MOVE_TYPE{$_[1]}; &normalise },
		159	'/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise },
		160	'x=' => sub {
		161	my $cur = $_[0] >= $_[1];
		162	if (!defined $cur) {
		163	if ($_[0] >= "all") {
		164	$_[0] -= $_[1];
		165	} else {
		166	$_[0] += $_[1];
		167	}
		168	} elsif ($cur) {
		169	$_[0] -= $_[1];
		170	} else {
		171	$_[0] /= $_[1];
		172	}
		173
		174	$_[0]
		175	},
		176	'eq' => sub { "$_[0]" eq "$_[1]" },
		177	'ne' => sub { "$_[0]" ne "$_[1]" },
		178	;
		179	}
		180
		181	sub Crossfire::MoveType::new {
		182	my ($class, $string) = @_;
		183
		184	my $mask;
		185	my $value;
		186
		187	if ($string =~ /^\s\d+\s$/) {
		188	$mask = MOVE_ALL;
		189	$value = $string+0;
		190	} else {
		191	for (split /\s+/, lc $string) {
		192	if (s/^-//) {
		193	$mask \|= $MOVE_TYPE{$_};
		194	$value &= ~$MOVE_TYPE{$_};
		195	} else {
		196	$mask \|= $MOVE_TYPE{$_};
		197	$value \|= $MOVE_TYPE{$_};
		198	}
		199	}
		200	}
		201
		202	(bless [$mask, $value], $class)->normalise
		203	}
		204
		205	sub Crossfire::MoveType::normalise {
		206	my ($self) = @_;
		207
		208	if ($self->[0] & MOVE_ALL) {
		209	my $mask = ~(($self->[1] & MOVE_ALL ? $self->[1] : ~$self->[1]) & $self->[0] & ~MOVE_ALL);
		210	$self->[0] &= $mask;
		211	$self->[1] &= $mask;
		212	}
		213
		214	$self->[1] &= $self->[0];
		215
		216	$self
		217	}
		218
		219	sub Crossfire::MoveType::as_string {
		220	my ($self) = @_;
		221
		222	my @res;
		223
		224	my ($mask, $value) = @$self;
		225
		226	for (@Crossfire::MOVE_TYPE) {
		227	my $bit = $Crossfire::MOVE_TYPE{$_};
		228	if (($mask & $bit) == $bit && (($value & $bit) == $bit \|\| ($value & $bit) == 0)) {
		229	$mask &= ~$bit;
		230	push @res, $value & $bit ? $_ : "-$_";
		231	}
		232	}
		233
		234	join " ", @res
		235	}
131		236
132	sub load_ref($) {	237	sub load_ref($) {
133	my ($path) = @_;	238	my ($path) = @_;
134		239
135	open my $fh, "<:raw:perlio", $path	240	open my $fh, "<:raw:perlio", $path
…		…
148	close $fh;	253	close $fh;
149	rename "$path~", $path	254	rename "$path~", $path
150	or die "$path: $!";	255	or die "$path: $!";
151	}	256	}
152		257
		258	my %attack_mask = (
		259	physical => 0x00000001,
		260	magic => 0x00000002,
		261	fire => 0x00000004,
		262	electricity => 0x00000008,
		263	cold => 0x00000010,
		264	confusion => 0x00000020,
		265	acid => 0x00000040,
		266	drain => 0x00000080,
		267	weaponmagic => 0x00000100,
		268	ghosthit => 0x00000200,
		269	poison => 0x00000400,
		270	slow => 0x00000800,
		271	paralyze => 0x00001000,
		272	turn_undead => 0x00002000,
		273	fear => 0x00004000,
		274	cancellation => 0x00008000,
		275	deplete => 0x00010000,
		276	death => 0x00020000,
		277	chaos => 0x00040000,
		278	counterspell => 0x00080000,
		279	godpower => 0x00100000,
		280	holyword => 0x00200000,
		281	blind => 0x00400000,
		282	internal => 0x00800000,
		283	life_stealing => 0x01000000,
		284	disease => 0x02000000,
		285	);
		286
		287	sub _add_resist($$$) {
		288	my ($ob, $mask, $value) = @_;
		289
		290	while (my ($k, $v) = each %attack_mask) {
		291	$ob->{"resist_$k"} = min 100, max -100, $ob->{"resist_$k"} + $value if $mask & $v;
		292	}
		293	}
		294
		295	my %MATERIAL = reverse
		296	paper => 1,
		297	iron => 2,
		298	glass => 4,
		299	leather => 8,
		300	wood => 16,
		301	organic => 32,
		302	stone => 64,
		303	cloth => 128,
		304	adamant => 256,
		305	liquid => 512,
		306	tin => 1024,
		307	bone => 2048,
		308	ice => 4096,
		309
		310	# guesses
		311	runestone => 12,
		312	bronze => 18,
		313	"ancient wood" => 20,
		314	glass => 36,
		315	marble => 66,
		316	ice => 68,
		317	stone => 70,
		318	stone => 80,
		319	cloth => 136,
		320	ironwood => 144,
		321	adamantium => 258,
		322	glacium => 260,
		323	blood => 544,
		324	;
		325
153	# object as in "Object xxx", i.e. archetypes	326	# object as in "Object xxx", i.e. archetypes
154	sub normalize_object($) {	327	sub normalize_object($) {
155	my ($ob) = @_;	328	my ($ob) = @_;
156		329
		330	# convert material bitset to materialname, if possible
		331	if (exists $ob->{material}) {
		332	if (!$ob->{material}) {
		333	delete $ob->{material};
		334	} elsif (exists $ob->{materialname}) {
		335	if ($MATERIAL{$ob->{material}} eq $ob->{materialname}) {
		336	delete $ob->{material};
		337	} else {
		338	warn "object $ob->{_name} has both materialname ($ob->{materialname}) and material ($ob->{material}) set.\n";
		339	delete $ob->{material}; # assume materilname is more specific and nuke material
		340	}
		341	} elsif (my $name = $MATERIAL{$ob->{material}}) {
		342	delete $ob->{material};
		343	$ob->{materialname} = $name;
		344	} else {
		345	warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n";
		346	}
		347	}
		348
		349	# color_fg is used as default for magicmap if magicmap does not exist
		350	$ob->{magicmap} \|\|= delete $ob->{color_fg} if exists $ob->{color_fg};
		351
157	# nuke outdated or never supported fields	352	# nuke outdated or never supported fields
158	delete $ob->{$_} for qw(	353	delete @$ob{qw(
159	can_knockback can_parry can_impale can_cut can_dam_armour	354	can_knockback can_parry can_impale can_cut can_dam_armour
160	can_apply pass_thru can_pass_thru	355	can_apply pass_thru can_pass_thru color_bg color_fg
161	);	356	)};
		357
		358	if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; }
		359	if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; }
		360	if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; }
162		361
163	# convert movement strings to bitsets	362	# convert movement strings to bitsets
164	for my $attr (keys %FIELD_MOVEMENT) {	363	for my $attr (keys %FIELD_MOVEMENT) {
165	next unless exists $ob->{$attr};	364	next unless exists $ob->{$attr};
166		365
167	$ob->{$attr} = MOVE_ALL if $ob->{$attr} == 255; #d# compatibility	366	$ob->{$attr} = new Crossfire::MoveType $ob->{$attr};
168
169	next if $ob->{$attr} =~ /^\d+$/;
170
171	my $flags = 0;
172
173	# assume list
174	for my $flag (map lc, split /\s+/, $ob->{$attr}) {
175	$flags \|= MOVE_WALK if $flag eq "walk";
176	$flags \|= MOVE_FLY_LOW if $flag eq "fly_low";
177	$flags \|= MOVE_FLY_HIGH if $flag eq "fly_high";
178	$flags \|= MOVE_FLYING if $flag eq "flying";
179	$flags \|= MOVE_SWIM if $flag eq "swim";
180	$flags \|= MOVE_BOAT if $flag eq "boat";
181	$flags \|= MOVE_ALL if $flag eq "all";
182
183	$flags &= ~MOVE_WALK if $flag eq "-walk";
184	$flags &= ~MOVE_FLY_LOW if $flag eq "-fly_low";
185	$flags &= ~MOVE_FLY_HIGH if $flag eq "-fly_high";
186	$flags &= ~MOVE_FLYING if $flag eq "-flying";
187	$flags &= ~MOVE_SWIM if $flag eq "-swim";
188	$flags &= ~MOVE_BOAT if $flag eq "-boat";
189	$flags &= ~MOVE_ALL if $flag eq "-all";
190	}
191
192	$ob->{$attr} = $flags;
193	}	367	}
194		368
195	# convert outdated movement flags to new movement sets	369	# convert outdated movement flags to new movement sets
196	if (defined (my $v = delete $ob->{no_pass})) {	370	if (defined (my $v = delete $ob->{no_pass})) {
197	$ob->{move_block} = $v ? MOVE_ALL : 0;	371	$ob->{move_block} = new Crossfire::MoveType $v ? "all" : "";
198	}	372	}
199	if (defined (my $v = delete $ob->{slow_move})) {	373	if (defined (my $v = delete $ob->{slow_move})) {
200	$ob->{move_slow} \|= MOVE_WALK;	374	$ob->{move_slow} += "walk";
201	$ob->{move_slow_penalty} = $v;	375	$ob->{move_slow_penalty} = $v;
202	}	376	}
203	if (defined (my $v = delete $ob->{walk_on})) {	377	if (defined (my $v = delete $ob->{walk_on})) {
204	$ob->{move_on} = MOVE_ALL unless exists $ob->{move_on};	378	$ob->{move_on} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" }
205	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_WALK
206	: $ob->{move_on} & ~MOVE_WALK;
207	}	379	}
208	if (defined (my $v = delete $ob->{walk_off})) {	380	if (defined (my $v = delete $ob->{walk_off})) {
209	$ob->{move_off} = MOVE_ALL unless exists $ob->{move_off};	381	$ob->{move_off} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" }
210	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_WALK
211	: $ob->{move_off} & ~MOVE_WALK;
212	}	382	}
213	if (defined (my $v = delete $ob->{fly_on})) {	383	if (defined (my $v = delete $ob->{fly_on})) {
214	$ob->{move_on} = MOVE_ALL unless exists $ob->{move_on};	384	$ob->{move_on} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "fly_low" } else { $ob->{move_on} -= "fly_low" }
215	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_FLY_LOW
216	: $ob->{move_on} & ~MOVE_FLY_LOW;
217	}	385	}
218	if (defined (my $v = delete $ob->{fly_off})) {	386	if (defined (my $v = delete $ob->{fly_off})) {
219	$ob->{move_off} = MOVE_ALL unless exists $ob->{move_off};	387	$ob->{move_off} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "fly_low" } else { $ob->{move_off} -= "fly_low" }
220	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_FLY_LOW
221	: $ob->{move_off} & ~MOVE_FLY_LOW;
222	}	388	}
223	if (defined (my $v = delete $ob->{flying})) {	389	if (defined (my $v = delete $ob->{flying})) {
224	$ob->{move_type} = MOVE_ALL unless exists $ob->{move_type};	390	$ob->{move_type} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_type} += "fly_low" } else { $ob->{move_type} -= "fly_low" }
225	$ob->{move_type} = $v ? $ob->{move_type} \| MOVE_FLY_LOW
226	: $ob->{move_type} & ~MOVE_FLY_LOW;
227	}	391	}
228		392
229	# convert idiotic event_xxx things into objects	393	# convert idiotic event_xxx things into objects
230	while (my ($event, $subtype) = each %EVENT_TYPE) {	394	while (my ($event, $subtype) = each %EVENT_TYPE) {
231	if (exists $ob->{"event_${event}_plugin"}) {	395	if (exists $ob->{"event_${event}_plugin"}) {
…		…
235	slaying => delete $ob->{"event_${event}"},	399	slaying => delete $ob->{"event_${event}"},
236	name => delete $ob->{"event_${event}_options"},	400	name => delete $ob->{"event_${event}_options"},
237	};	401	};
238	}	402	}
239	}	403	}
		404
		405	# some archetypes had "+3" instead of the canonical "3", so fix
		406	$ob->{dam} *= 1 if exists $ob->{dam};
240		407
241	$ob	408	$ob
242	}	409	}
243		410
244	# arch as in "arch xxx", ie.. objects	411	# arch as in "arch xxx", ie.. objects
…		…
286	}	453	}
287		454
288	$ob	455	$ob
289	}	456	}
290		457
		458	sub attr_thaw($) {
		459	my ($ob) = @_;
		460
		461	$ob->{attach} = from_json $ob->{attach}
		462	if exists $ob->{attach};
		463
		464	$ob
		465	}
		466
		467	sub attr_freeze($) {
		468	my ($ob) = @_;
		469
		470	$ob->{attach} = Crossfire::to_json $ob->{attach}
		471	if exists $ob->{attach};
		472
		473	$ob
		474	}
		475
291	sub read_pak($) {	476	sub read_pak($) {
292	my ($path) = @_;	477	my ($path) = @_;
293		478
294	my %pak;	479	my %pak;
295		480
…		…
308	sub read_arch($;$) {	493	sub read_arch($;$) {
309	my ($path, $toplevel) = @_;	494	my ($path, $toplevel) = @_;
310		495
311	my %arc;	496	my %arc;
312	my ($more, $prev);	497	my ($more, $prev);
		498	my $comment;
313		499
314	open my $fh, "<:raw:perlio:utf8", $path	500	open my $fh, "<:raw:perlio:utf8", $path
315	or Carp::croak "$path: $!";	501	or Carp::croak "$path: $!";
316		502
317	binmode $fh;	503	# binmode $fh;
318		504
319	my $parse_block; $parse_block = sub {	505	my $parse_block; $parse_block = sub {
320	my %arc = @_;	506	my %arc = @_;
321		507
322	while (<$fh>) {	508	while (<$fh>) {
323	s/\s+$//;	509	s/\s+$//;
324	if (/^end$/i) {	510	if (/^end$/i) {
325	last;	511	last;
		512
326	} elsif (/^arch (\S+)$/i) {	513	} elsif (/^arch (\S+)$/i) {
327	push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1);	514	push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
		515
328	} elsif (/^lore$/i) {	516	} elsif (/^lore$/i) {
329	while (<$fh>) {	517	while (<$fh>) {
330	last if /^endlore\s*$/i;	518	last if /^endlore\s*$/i;
331	$arc{lore} .= $_;	519	$arc{lore} .= $_;
332	}	520	}
…		…
341	chomp;	529	chomp;
342	push @{ $arc{anim} }, $_;	530	push @{ $arc{anim} }, $_;
343	}	531	}
344	} elsif (/^(\S+)\s(.)$/) {	532	} elsif (/^(\S+)\s(.)$/) {
345	$arc{lc $1} = $2;	533	$arc{lc $1} = $2;
346	} elsif (/^\s*($\|#)/) {	534	} elsif (/^\s*#/) {
		535	$arc{_comment} .= "$_\n";
		536
		537	} elsif (/^\s*$/) {
347	#	538	#
348	} else {	539	} else {
349	warn "$path: unparsable line '$_' in arch $arc{_name}";	540	warn "$path: unparsable line '$_' in arch $arc{_name}";
350	}	541	}
351	}	542	}
…		…
357	s/\s+$//;	548	s/\s+$//;
358	if (/^more$/i) {	549	if (/^more$/i) {
359	$more = $prev;	550	$more = $prev;
360	} elsif (/^object (\S+)$/i) {	551	} elsif (/^object (\S+)$/i) {
361	my $name = $1;	552	my $name = $1;
362	my $arc = normalize_object $parse_block->(_name => $name);	553	my $arc = attr_thaw normalize_object $parse_block->(_name => $name, _comment => $comment);
		554	undef $comment;
		555	delete $arc{_comment} unless length $arc{_comment};
		556	$arc->{_atype} = 'object';
363		557
364	if ($more) {	558	if ($more) {
365	$more->{more} = $arc;	559	$more->{more} = $arc;
366	} else {	560	} else {
367	$arc{$name} = $arc;	561	$arc{$name} = $arc;
368	}	562	}
369	$prev = $arc;	563	$prev = $arc;
370	$more = undef;	564	$more = undef;
371	} elsif (/^arch (\S+)$/i) {	565	} elsif (/^arch (\S+)$/i) {
372	my $name = $1;	566	my $name = $1;
373	my $arc = normalize_arch $parse_block->(_name => $name);	567	my $arc = attr_thaw normalize_arch $parse_block->(_name => $name, _comment => $comment);
		568	undef $comment;
		569	delete $arc{_comment} unless length $arc{_comment};
		570	$arc->{_atype} = 'arch';
374		571
375	if ($more) {	572	if ($more) {
376	$more->{more} = $arc;	573	$more->{more} = $arc;
377	} else {	574	} else {
378	push @{ $arc{arch} }, $arc;	575	push @{ $arc{arch} }, $arc;
…		…
386	push @{$toplevel->{lev_array}}, $_+0;	583	push @{$toplevel->{lev_array}}, $_+0;
387	}	584	}
388	} else {	585	} else {
389	$toplevel->{$1} = $2;	586	$toplevel->{$1} = $2;
390	}	587	}
		588	} elsif (/^\s*#/) {
		589	$comment .= "$_\n";
391	} elsif (/^\s*($\|#)/) {	590	} elsif (/^\s*($\|#)/) {
392	#	591	#
393	} else {	592	} else {
394	die "$path: unparseable top-level line '$_'";	593	die "$path: unparseable top-level line '$_'";
395	}	594	}
396	}	595	}
397		596
398	undef $parse_block; # work around bug in perl not freeing $fh etc.	597	undef $parse_block; # work around bug in perl not freeing $fh etc.
399		598
400	\%arc	599	\%arc
		600	}
		601
		602	sub archlist_to_string {
		603	my ($arch) = @_;
		604
		605	my $str;
		606
		607	my $append; $append = sub {
		608	my %a = %{$_[0]};
		609
		610	Crossfire::attr_freeze \%a;
		611	Crossfire::normalize_arch \%a;
		612
		613	# undo the bit-split we did before
		614	if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) {
		615	$a{attack_movement} = (delete $a{attack_movement_bits_0_3})
		616	\| (delete $a{attack_movement_bits_4_7});
		617	}
		618
		619	if (my $comment = delete $a{_comment}) {
		620	if ($comment =~ /[^\n\s#]/) {
		621	$str .= $comment;
		622	}
		623	}
		624
		625	$str .= ((exists $a{_atype}) ? $a{_atype} : 'arch'). " $a{_name}\n";
		626
		627	my $inv = delete $a{inventory};
		628	my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some
		629	my $anim = delete $a{anim};
		630
		631	if ($a{_atype} eq 'object') {
		632	$str .= join "\n", "anim", @$anim, "mina\n"
		633	if $anim;
		634	}
		635
		636	my @kv;
		637
		638	for ($a{_name} eq "map"
		639	? @Crossfire::FIELD_ORDER_MAP
		640	: @Crossfire::FIELD_ORDER) {
		641	push @kv, [$_, delete $a{$_}]
		642	if exists $a{$_};
		643	}
		644
		645	for (sort keys %a) {
		646	next if /^_/; # ignore our _-keys
		647	push @kv, [$_, delete $a{$_}];
		648	}
		649
		650	for (@kv) {
		651	my ($k, $v) = @$_;
		652
		653	if (my $end = $Crossfire::FIELD_MULTILINE{$k}) {
		654	$v =~ s/\n$//;
		655	$str .= "$k\n$v\n$end\n";
		656	} else {
		657	$str .= "$k $v\n";
		658	}
		659	}
		660
		661	if ($inv) {
		662	$append->($_) for @$inv;
		663	}
		664
		665	$str .= "end\n";
		666
		667	if ($a{_atype} eq 'object') {
		668	if ($more) {
		669	$str .= "more\n";
		670	$append->($more) if $more;
		671	} else {
		672	$str .= "\n";
		673	}
		674	}
		675	};
		676
		677	for (@$arch) {
		678	$append->($_);
		679	}
		680
		681	$str
401	}	682	}
402		683
403	# put all archs into a hash with editor_face as it's key	684	# put all archs into a hash with editor_face as it's key
404	# NOTE: the arrays in the hash values are references to	685	# NOTE: the arrays in the hash values are references to
405	# the archs from $ARCH	686	# the archs from $ARCH
…		…
426	my ($a) = @_;	707	my ($a) = @_;
427		708
428	my $o = $ARCH{$a->{_name}}	709	my $o = $ARCH{$a->{_name}}
429	or return;	710	or return;
430		711
431	my $face = $FACE{$a->{face} \|\| $o->{face} \|\| "blank.111"}	712	my $face = $FACE{$a->{face} \|\| $o->{face} \|\| "blank.111"};
		713	unless ($face) {
		714	$face = $FACE{"blank.x11"}
432	or (warn "no face data found for arch '$a->{_name}'"), return;	715	or (warn "no face data found for arch '$a->{_name}'"), return;
		716	}
433		717
434	if ($face->{w} > 1 \|\| $face->{h} > 1) {	718	if ($face->{w} > 1 \|\| $face->{h} > 1) {
435	# bigface	719	# bigface
436	return (0, 0, $face->{w} - 1, $face->{h} - 1);	720	return (0, 0, $face->{w} - 1, $face->{h} - 1);
437		721
…		…
544	];	828	];
545		829
546	$attr	830	$attr
547	}	831	}
548		832
549	sub arch_edit_sections {
550	# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
551	# edit_type = 0;
552	# else if (edit_type != 0) {
553	# // all flags from 'check_type' must be unset in this arch because they get recalculated now
554	# edit_type &= ~check_type;
555	# }
556	#
557	# }
558	# if ((check_type & IGUIConstants.TILE_EDIT_MONSTER) != 0 &&
559	# getAttributeValue("alive", defarch) == 1 &&
560	# (getAttributeValue("monster", defarch) == 1 \|\|
561	# getAttributeValue("generator", defarch) == 1)) {
562	# // Monster: monsters/npcs/generators
563	# edit_type \|= IGUIConstants.TILE_EDIT_MONSTER;
564	# }
565	# if ((check_type & IGUIConstants.TILE_EDIT_WALL) != 0 &&
566	# arch_type == 0 && getAttributeValue("no_pass", defarch) == 1) {
567	# // Walls
568	# edit_type \|= IGUIConstants.TILE_EDIT_WALL;
569	# }
570	# if ((check_type & IGUIConstants.TILE_EDIT_CONNECTED) != 0 &&
571	# getAttributeValue("connected", defarch) != 0) {
572	# // Connected Objects
573	# edit_type \|= IGUIConstants.TILE_EDIT_CONNECTED;
574	# }
575	# if ((check_type & IGUIConstants.TILE_EDIT_EXIT) != 0 &&
576	# arch_type == 66 \|\| arch_type == 41 \|\| arch_type == 95) {
577	# // Exit: teleporter/exit/trapdoors
578	# edit_type \|= IGUIConstants.TILE_EDIT_EXIT;
579	# }
580	# if ((check_type & IGUIConstants.TILE_EDIT_TREASURE) != 0 &&
581	# getAttributeValue("no_pick", defarch) == 0 && (arch_type == 4 \|\|
582	# arch_type == 5 \|\| arch_type == 36 \|\| arch_type == 60 \|\|
583	# arch_type == 85 \|\| arch_type == 111 \|\| arch_type == 123 \|\|
584	# arch_type == 124 \|\| arch_type == 130)) {
585	# // Treasure: randomtreasure/money/gems/potions/spellbooks/scrolls
586	# edit_type \|= IGUIConstants.TILE_EDIT_TREASURE;
587	# }
588	# if ((check_type & IGUIConstants.TILE_EDIT_DOOR) != 0 &&
589	# arch_type == 20 \|\| arch_type == 23 \|\| arch_type == 26 \|\|
590	# arch_type == 91 \|\| arch_type == 21 \|\| arch_type == 24) {
591	# // Door: door/special door/gates + keys
592	# edit_type \|= IGUIConstants.TILE_EDIT_DOOR;
593	# }
594	# if ((check_type & IGUIConstants.TILE_EDIT_EQUIP) != 0 &&
595	# getAttributeValue("no_pick", defarch) == 0 && ((arch_type >= 13 &&
596	# arch_type <= 16) \|\| arch_type == 33 \|\| arch_type == 34 \|\|
597	# arch_type == 35 \|\| arch_type == 39 \|\| arch_type == 70 \|\|
598	# arch_type == 87 \|\| arch_type == 99 \|\| arch_type == 100 \|\|
599	# arch_type == 104 \|\| arch_type == 109 \|\| arch_type == 113 \|\|
600	# arch_type == 122 \|\| arch_type == 3)) {
601	# // Equipment: weapons/armour/wands/rods
602	# edit_type \|= IGUIConstants.TILE_EDIT_EQUIP;
603	# }
604	#
605	# return(edit_type);
606	#
607	#
608	}
609
610	sub cache_file($$&&) {	833	sub cache_file($$&&) {
611	my ($src, $cache, $load, $create) = @_;	834	my ($src, $cache, $load, $create) = @_;
612		835
613	my ($size, $mtime) = (stat $src)[7,9]	836	my ($size, $mtime) = (stat $src)[7,9]
614	or Carp::croak "$src: $!";	837	or Carp::croak "$src: $!";
…		…
662	}, sub {	885	}, sub {
663	read_arch "$LIB/archetypes"	886	read_arch "$LIB/archetypes"
664	};	887	};
665	}	888	}
666		889
		890	sub construct_tilecache_pb {
		891	my ($idx, $cache) = @_;
		892
		893	my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
		894
		895	while (my ($name, $tile) = each %$cache) {
		896	my $tpb = delete $tile->{pb};
		897	my $ofs = $tile->{idx};
		898
		899	for my $x (0 .. $tile->{w} - 1) {
		900	for my $y (0 .. $tile->{h} - 1) {
		901	my $idx = $ofs + $x + $y * $tile->{w};
		902	$tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
		903	$pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
		904	}
		905	}
		906	}
		907
		908	$pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
		909
		910	$cache
		911	}
		912
		913	sub use_tilecache {
		914	my ($face) = @_;
		915	$TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
		916	or die "$VARDIR/tilecache.png: $!";
		917	*FACE = $_[0];
		918	}
		919
667	=item load_tilecache	920	=item load_tilecache
668		921
669	(Re-)Load %TILE and %FACE.	922	(Re-)Load %TILE and %FACE.
670		923
671	=cut	924	=cut
672		925
673	sub load_tilecache() {	926	sub load_tilecache() {
674	require Gtk2;	927	require Gtk2;
675		928
		929	if (-e "$LIB/crossfire.0") { # Crossfire1 version
676	cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub {	930	cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", \&use_tilecache,
677	$TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"	931	sub {
678	or die "$VARDIR/tilecache.png: $!";
679	*FACE = $_[0];
680	}, sub {
681	my $tile = read_pak "$LIB/crossfire.0";	932	my $tile = read_pak "$LIB/crossfire.0";
682		933
683	my %cache;	934	my %cache;
684		935
685	my $idx = 0;	936	my $idx = 0;
686		937
687	for my $name (sort keys %$tile) {	938	for my $name (sort keys %$tile) {
688	my $pb = new Gtk2::Gdk::PixbufLoader;	939	my $pb = new Gtk2::Gdk::PixbufLoader;
689	$pb->write ($tile->{$name});	940	$pb->write ($tile->{$name});
690	$pb->close;	941	$pb->close;
691	my $pb = $pb->get_pixbuf;	942	my $pb = $pb->get_pixbuf;
692		943
693	my $tile = $cache{$name} = {	944	my $tile = $cache{$name} = {
694	pb => $pb,	945	pb => $pb,
695	idx => $idx,	946	idx => $idx,
696	w => int $pb->get_width / TILESIZE,	947	w => int $pb->get_width / TILESIZE,
697	h => int $pb->get_height / TILESIZE,	948	h => int $pb->get_height / TILESIZE,
		949	};
		950
		951	$idx += $tile->{w} * $tile->{h};
		952	}
		953
		954	construct_tilecache_pb $idx, \%cache;
		955
		956	\%cache
698	};	957	};
		958
		959	} else { # Crossfire+ version
		960	cache_file "$LIB/facedata", "$VARDIR/tilecache.pst", \&use_tilecache,
		961	sub {
		962	my %cache;
		963	my $facedata = Storable::retrieve "$LIB/facedata";
		964
		965	$facedata->{version} == 2
		966	or die "$LIB/facedata: version mismatch, cannot proceed.";
		967
		968	my $faces = $facedata->{faceinfo};
		969	my $idx = 0;
		970
		971	for (sort keys %$faces) {
		972	my ($face, $info) = ($_, $faces->{$_});
		973
		974	my $pb = new Gtk2::Gdk::PixbufLoader;
		975	$pb->write ($info->{data32});
		976	$pb->close;
		977	my $pb = $pb->get_pixbuf;
		978
		979	my $tile = $cache{$face} = {
		980	pb => $pb,
		981	idx => $idx,
		982	w => int $pb->get_width / TILESIZE,
		983	h => int $pb->get_height / TILESIZE,
699		984	};
700		985
701	$idx += $tile->{w} * $tile->{h};	986	$idx += $tile->{w} * $tile->{h};
702	}
703
704	my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
705
706	while (my ($name, $tile) = each %cache) {
707	my $tpb = delete $tile->{pb};
708	my $ofs = $tile->{idx};
709
710	for my $x (0 .. $tile->{w} - 1) {
711	for my $y (0 .. $tile->{h} - 1) {
712	my $idx = $ofs + $x + $y * $tile->{w};
713	$tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
714	$pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
715	}	987	}
		988
		989	construct_tilecache_pb $idx, \%cache;
		990
		991	\%cache
716	}	992	};
717	}
718
719	$pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
720
721	\%cache
722	};	993	}
723	}	994	}
724		995
725	=head1 AUTHOR	996	=head1 AUTHOR
726		997
727	Marc Lehmann <schmorp@schmorp.de>	998	Marc Lehmann <schmorp@schmorp.de>

Diff Legend

-–
+Removed lines
-+
+Added lines
-<
+Changed lines
->
+Changed lines

Comparing deliantra/Deliantra/Deliantra.pm (file contents): Revision 1.66 by root, Wed Jun 14 19:23:32 2006 UTC vs. Revision 1.105 by root, Tue Apr 17 18:50:41 2007 UTC

Diff Legend

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.66 by root, Wed Jun 14 19:23:32 2006 UTC vs.
Revision 1.105 by root, Tue Apr 17 18:50:41 2007 UTC