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

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.59 by root, Sun Mar 26 11:52:31 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
…		…
102		109
103	body_range body_arm body_torso body_head body_neck body_skill	110	body_range body_arm body_torso body_head body_neck body_skill
104	body_finger body_shoulder body_foot body_hand body_wrist body_waist	111	body_finger body_shoulder body_foot body_hand body_wrist body_waist
105	));	112	));
106		113
		114	our %EVENT_TYPE = (
		115	apply => 1,
		116	attack => 2,
		117	death => 3,
		118	drop => 4,
		119	pickup => 5,
		120	say => 6,
		121	stop => 7,
		122	time => 8,
		123	throw => 9,
		124	trigger => 10,
		125	close => 11,
		126	timer => 12,
		127	);
		128
107	sub MOVE_WALK (){ 0x01 }	129	sub MOVE_WALK (){ 0x01 }
108	sub MOVE_FLY_LOW (){ 0x02 }	130	sub MOVE_FLY_LOW (){ 0x02 }
109	sub MOVE_FLY_HIGH (){ 0x04 }	131	sub MOVE_FLY_HIGH (){ 0x04 }
110	sub MOVE_FLYING (){ 0x06 }	132	sub MOVE_FLYING (){ 0x06 }
111	sub MOVE_SWIM (){ 0x08 }	133	sub MOVE_SWIM (){ 0x08 }
112	sub MOVE_BOAT (){ 0x10 }	134	sub MOVE_BOAT (){ 0x10 }
113	sub MOVE_KNOWN (){ 0x1f } # all of above	135	sub MOVE_KNOWN (){ 0x1f } # all of above
114	sub MOVE_ALLBIT (){ 0x10000 }
115	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	}
116		236
117	sub load_ref($) {	237	sub load_ref($) {
118	my ($path) = @_;	238	my ($path) = @_;
119		239
120	open my $fh, "<", $path	240	open my $fh, "<:raw:perlio", $path
121	or die "$path: $!";	241	or die "$path: $!";
122	binmode $fh;
123	local $/;	242	local $/;
124		243
125	thaw <$fh>	244	thaw <$fh>
126	}	245	}
127		246
128	sub save_ref($$) {	247	sub save_ref($$) {
129	my ($ref, $path) = @_;	248	my ($ref, $path) = @_;
130		249
131	open my $fh, ">", "$path~"	250	open my $fh, ">:raw:perlio", "$path~"
132	or die "$path~: $!";	251	or die "$path~: $!";
133	binmode $fh;
134	print $fh freeze $ref;	252	print $fh freeze $ref;
135	close $fh;	253	close $fh;
136	rename "$path~", $path	254	rename "$path~", $path
137	or die "$path: $!";	255	or die "$path: $!";
138	}	256	}
139		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
		326	# object as in "Object xxx", i.e. archetypes
140	sub normalize_object($) {	327	sub normalize_object($) {
141	my ($ob) = @_;	328	my ($ob) = @_;
142		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
		352	# nuke outdated or never supported fields
143	delete $ob->{$_} for qw(	353	delete @$ob{qw(
144	can_knockback can_parry can_impale can_cut can_dam_armour	354	can_knockback can_parry can_impale can_cut can_dam_armour
145	can_apply pass_thru can_pass_thru	355	can_apply pass_thru can_pass_thru color_bg color_fg
146	);	356	)};
147		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; }
		361
		362	# convert movement strings to bitsets
148	for my $attr (keys %FIELD_MOVEMENT) {	363	for my $attr (keys %FIELD_MOVEMENT) {
149	next unless exists $ob->{$attr};	364	next unless exists $ob->{$attr};
150		365
151	$ob->{$attr} = MOVE_ALL if $ob->{$attr} == 255; #d# compatibility	366	$ob->{$attr} = new Crossfire::MoveType $ob->{$attr};
152
153	next if $ob->{$attr} =~ /^\d+$/;
154
155	my $flags = 0;
156
157	# assume list
158	for my $flag (map lc, split /\s+/, $ob->{$attr}) {
159	$flags \|= MOVE_WALK if $flag eq "walk";
160	$flags \|= MOVE_FLY_LOW if $flag eq "fly_low";
161	$flags \|= MOVE_FLY_HIGH if $flag eq "fly_high";
162	$flags \|= MOVE_FLYING if $flag eq "flying";
163	$flags \|= MOVE_SWIM if $flag eq "swim";
164	$flags \|= MOVE_BOAT if $flag eq "boat";
165	$flags \|= MOVE_ALL if $flag eq "all";
166
167	$flags &= ~MOVE_WALK if $flag eq "-walk";
168	$flags &= ~MOVE_FLY_LOW if $flag eq "-fly_low";
169	$flags &= ~MOVE_FLY_HIGH if $flag eq "-fly_high";
170	$flags &= ~MOVE_FLYING if $flag eq "-flying";
171	$flags &= ~MOVE_SWIM if $flag eq "-swim";
172	$flags &= ~MOVE_BOAT if $flag eq "-boat";
173	$flags &= ~MOVE_ALL if $flag eq "-all";
174	}
175
176	$ob->{$attr} = $flags;
177	}	367	}
178		368
		369	# convert outdated movement flags to new movement sets
179	if (defined (my $v = delete $ob->{no_pass})) {	370	if (defined (my $v = delete $ob->{no_pass})) {
180	$ob->{move_block} = $v ? MOVE_ALL : 0;	371	$ob->{move_block} = new Crossfire::MoveType $v ? "all" : "";
181	}	372	}
182	if (defined (my $v = delete $ob->{slow_move})) {	373	if (defined (my $v = delete $ob->{slow_move})) {
183	$ob->{move_slow} \|= MOVE_WALK;	374	$ob->{move_slow} += "walk";
184	$ob->{move_slow_penalty} = $v;	375	$ob->{move_slow_penalty} = $v;
185	}	376	}
186	if (defined (my $v = delete $ob->{walk_on})) {	377	if (defined (my $v = delete $ob->{walk_on})) {
187	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_WALK	378	$ob->{move_on} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" }
188	: $ob->{move_on} & ~MOVE_WALK;
189	}	379	}
190	if (defined (my $v = delete $ob->{walk_off})) {	380	if (defined (my $v = delete $ob->{walk_off})) {
191	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_WALK	381	$ob->{move_off} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" }
192	: $ob->{move_off} & ~MOVE_WALK;
193	}	382	}
194	if (defined (my $v = delete $ob->{fly_on})) {	383	if (defined (my $v = delete $ob->{fly_on})) {
195	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_FLY_LOW	384	$ob->{move_on} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "fly_low" } else { $ob->{move_on} -= "fly_low" }
196	: $ob->{move_on} & ~MOVE_FLY_LOW;
197	}	385	}
198	if (defined (my $v = delete $ob->{fly_off})) {	386	if (defined (my $v = delete $ob->{fly_off})) {
199	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_FLY_LOW	387	$ob->{move_off} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "fly_low" } else { $ob->{move_off} -= "fly_low" }
200	: $ob->{move_off} & ~MOVE_FLY_LOW;
201	}	388	}
202	if (defined (my $v = delete $ob->{flying})) {	389	if (defined (my $v = delete $ob->{flying})) {
203	$ob->{move_type} = $v ? $ob->{move_type} \| MOVE_FLY_LOW	390	$ob->{move_type} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_type} += "fly_low" } else { $ob->{move_type} -= "fly_low" }
204	: $ob->{move_type} & ~MOVE_FLY_LOW;
205	}	391	}
		392
		393	# convert idiotic event_xxx things into objects
		394	while (my ($event, $subtype) = each %EVENT_TYPE) {
		395	if (exists $ob->{"event_${event}_plugin"}) {
		396	push @{$ob->{inventory}}, {
		397	_name => "event_$event",
		398	title => delete $ob->{"event_${event}_plugin"},
		399	slaying => delete $ob->{"event_${event}"},
		400	name => delete $ob->{"event_${event}_options"},
		401	};
		402	}
		403	}
		404
		405	# some archetypes had "+3" instead of the canonical "3", so fix
		406	$ob->{dam} *= 1 if exists $ob->{dam};
206		407
207	$ob	408	$ob
208	}	409	}
209		410
		411	# arch as in "arch xxx", ie.. objects
210	sub normalize_arch($) {	412	sub normalize_arch($) {
211	my ($ob) = @_;	413	my ($ob) = @_;
212		414
213	normalize_object $ob;	415	normalize_object $ob;
214		416
…		…
251	}	453	}
252		454
253	$ob	455	$ob
254	}	456	}
255		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
256	sub read_pak($) {	476	sub read_pak($) {
257	my ($path) = @_;	477	my ($path) = @_;
258		478
259	my %pak;	479	my %pak;
260		480
261	open my $fh, "<", $path	481	open my $fh, "<:raw:perlio", $path
262	or Carp::croak "$_[0]: $!";	482	or Carp::croak "$_[0]: $!";
263	binmode $fh;	483	binmode $fh;
264	while (<$fh>) {	484	while (<$fh>) {
265	my ($type, $id, $len, $path) = split;	485	my ($type, $id, $len, $path) = split;
266	$path =~ s/.*\///;	486	$path =~ s/.*\///;
…		…
268	}	488	}
269		489
270	\%pak	490	\%pak
271	}	491	}
272		492
273	sub read_arch($) {	493	sub read_arch($;$) {
274	my ($path) = @_;	494	my ($path, $toplevel) = @_;
275		495
276	my %arc;	496	my %arc;
277	my ($more, $prev);	497	my ($more, $prev);
		498	my $comment;
278		499
279	open my $fh, "<", $path	500	open my $fh, "<:raw:perlio:utf8", $path
280	or Carp::croak "$path: $!";	501	or Carp::croak "$path: $!";
281		502
282	binmode $fh;	503	# binmode $fh;
283		504
284	my $parse_block; $parse_block = sub {	505	my $parse_block; $parse_block = sub {
285	my %arc = @_;	506	my %arc = @_;
286		507
287	while (<$fh>) {	508	while (<$fh>) {
288	s/\s+$//;	509	s/\s+$//;
289	if (/^end$/i) {	510	if (/^end$/i) {
290	last;	511	last;
		512
291	} elsif (/^arch (\S+)$/i) {	513	} elsif (/^arch (\S+)$/i) {
292	push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1);	514	push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
		515
293	} elsif (/^lore$/i) {	516	} elsif (/^lore$/i) {
294	while (<$fh>) {	517	while (<$fh>) {
295	last if /^endlore\s*$/i;	518	last if /^endlore\s*$/i;
296	$arc{lore} .= $_;	519	$arc{lore} .= $_;
297	}	520	}
298	} elsif (/^msg$/i) {	521	} elsif (/^msg$/i) {
299	while (<$fh>) {	522	while (<$fh>) {
300	last if /^endmsg\s*$/i;	523	last if /^endmsg\s*$/i;
301	$arc{msg} .= $_;	524	$arc{msg} .= $_;
302	}	525	}
		526	} elsif (/^anim$/i) {
		527	while (<$fh>) {
		528	last if /^mina\s*$/i;
		529	chomp;
		530	push @{ $arc{anim} }, $_;
		531	}
303	} elsif (/^(\S+)\s(.)$/) {	532	} elsif (/^(\S+)\s(.)$/) {
304	$arc{lc $1} = $2;	533	$arc{lc $1} = $2;
305	} elsif (/^\s*($\|#)/) {	534	} elsif (/^\s*#/) {
		535	$arc{_comment} .= "$_\n";
		536
		537	} elsif (/^\s*$/) {
306	#	538	#
307	} else {	539	} else {
308	warn "$path: unparsable line '$_' in arch $arc{_name}";	540	warn "$path: unparsable line '$_' in arch $arc{_name}";
309	}	541	}
310	}	542	}
…		…
316	s/\s+$//;	548	s/\s+$//;
317	if (/^more$/i) {	549	if (/^more$/i) {
318	$more = $prev;	550	$more = $prev;
319	} elsif (/^object (\S+)$/i) {	551	} elsif (/^object (\S+)$/i) {
320	my $name = $1;	552	my $name = $1;
321	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';
322		557
323	if ($more) {	558	if ($more) {
324	$more->{more} = $arc;	559	$more->{more} = $arc;
325	} else {	560	} else {
326	$arc{$name} = $arc;	561	$arc{$name} = $arc;
327	}	562	}
328	$prev = $arc;	563	$prev = $arc;
329	$more = undef;	564	$more = undef;
330	} elsif (/^arch (\S+)$/i) {	565	} elsif (/^arch (\S+)$/i) {
331	my $name = $1;	566	my $name = $1;
332	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';
333		571
334	if ($more) {	572	if ($more) {
335	$more->{more} = $arc;	573	$more->{more} = $arc;
336	} else {	574	} else {
337	push @{ $arc{arch} }, $arc;	575	push @{ $arc{arch} }, $arc;
338	}	576	}
339	$prev = $arc;	577	$prev = $arc;
340	$more = undef;	578	$more = undef;
		579	} elsif ($toplevel && /^(\S+)\s+(.*)$/) {
		580	if ($1 eq "lev_array") {
		581	while (<$fh>) {
		582	last if /^endplst\s*$/;
		583	push @{$toplevel->{lev_array}}, $_+0;
		584	}
		585	} else {
		586	$toplevel->{$1} = $2;
		587	}
		588	} elsif (/^\s*#/) {
		589	$comment .= "$_\n";
341	} elsif (/^\s*($\|#)/) {	590	} elsif (/^\s*($\|#)/) {
342	#	591	#
343	} else {	592	} else {
344	warn "$path: unparseable top-level line '$_'";	593	die "$path: unparseable top-level line '$_'";
345	}	594	}
346	}	595	}
347		596
348	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.
349		598
350	\%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
351	}	682	}
352		683
353	# 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
354	# NOTE: the arrays in the hash values are references to	685	# NOTE: the arrays in the hash values are references to
355	# the archs from $ARCH	686	# the archs from $ARCH
356	sub editor_archs {	687	sub editor_archs {
357	my %paths;	688	my %paths;
358		689
359	for (keys %ARCH) {	690	for (keys %ARCH) {
360	my $arch = $ARCH{$_};	691	my $arch = $ARCH{$_};
361	push @{$paths{$arch->{editor_folder}}}, \$arch;	692	push @{$paths{$arch->{editor_folder}}}, $arch;
362	}	693	}
363		694
364	\%paths	695	\%paths
365	}	696	}
366		697
…		…
376	my ($a) = @_;	707	my ($a) = @_;
377		708
378	my $o = $ARCH{$a->{_name}}	709	my $o = $ARCH{$a->{_name}}
379	or return;	710	or return;
380		711
381	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"}
382	or (warn "no face data found for arch '$a->{_name}'"), return;	715	or (warn "no face data found for arch '$a->{_name}'"), return;
		716	}
383		717
384	if ($face->{w} > 1 \|\| $face->{h} > 1) {	718	if ($face->{w} > 1 \|\| $face->{h} > 1) {
385	# bigface	719	# bigface
386	return (0, 0, $face->{w} - 1, $face->{h} - 1);	720	return (0, 0, $face->{w} - 1, $face->{h} - 1);
387		721
…		…
431	my $type = $obj->{type} \|\| $arch->{type};	765	my $type = $obj->{type} \|\| $arch->{type};
432		766
433	if ($type > 0) {	767	if ($type > 0) {
434	$root = $Crossfire::Data::ATTR{$type};	768	$root = $Crossfire::Data::ATTR{$type};
435	} else {	769	} else {
		770	my %a = (%$arch, %$obj);
		771
		772	if ($a{is_floor} && !$a{alive}) {
		773	$root = $Crossfire::Data::TYPE{Floor};
		774	} elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) {
		775	$root = $Crossfire::Data::TYPE{"Monster & NPC"};
		776	} elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) {
		777	$root = $Crossfire::Data::TYPE{Wall};
		778	} elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) {
		779	$root = $Crossfire::Data::TYPE{"Weak Wall"};
		780	} else {
436	$root = $Crossfire::Data::TYPE{Misc};	781	$root = $Crossfire::Data::TYPE{Misc};
437
438	type:
439	for (@Crossfire::Data::ATTR0) {
440	my $req = $_->{required}
441	or die "internal error: ATTR0 without 'required'";
442
443	keys %$req;
444	while (my ($k, $v) = each %$req) {
445	next type
446	unless $obj->{$k} == $v \|\| $arch->{$k} == $v;
447	}
448
449	$root = $_;
450	}	782	}
451	}	783	}
452		784
453	my @import = ($root);	785	my @import = ($root);
454		786
…		…
496	];	828	];
497		829
498	$attr	830	$attr
499	}	831	}
500		832
501	sub arch_edit_sections {
502	# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
503	# edit_type = 0;
504	# else if (edit_type != 0) {
505	# // all flags from 'check_type' must be unset in this arch because they get recalculated now
506	# edit_type &= ~check_type;
507	# }
508	#
509	# }
510	# if ((check_type & IGUIConstants.TILE_EDIT_MONSTER) != 0 &&
511	# getAttributeValue("alive", defarch) == 1 &&
512	# (getAttributeValue("monster", defarch) == 1 \|\|
513	# getAttributeValue("generator", defarch) == 1)) {
514	# // Monster: monsters/npcs/generators
515	# edit_type \|= IGUIConstants.TILE_EDIT_MONSTER;
516	# }
517	# if ((check_type & IGUIConstants.TILE_EDIT_WALL) != 0 &&
518	# arch_type == 0 && getAttributeValue("no_pass", defarch) == 1) {
519	# // Walls
520	# edit_type \|= IGUIConstants.TILE_EDIT_WALL;
521	# }
522	# if ((check_type & IGUIConstants.TILE_EDIT_CONNECTED) != 0 &&
523	# getAttributeValue("connected", defarch) != 0) {
524	# // Connected Objects
525	# edit_type \|= IGUIConstants.TILE_EDIT_CONNECTED;
526	# }
527	# if ((check_type & IGUIConstants.TILE_EDIT_EXIT) != 0 &&
528	# arch_type == 66 \|\| arch_type == 41 \|\| arch_type == 95) {
529	# // Exit: teleporter/exit/trapdoors
530	# edit_type \|= IGUIConstants.TILE_EDIT_EXIT;
531	# }
532	# if ((check_type & IGUIConstants.TILE_EDIT_TREASURE) != 0 &&
533	# getAttributeValue("no_pick", defarch) == 0 && (arch_type == 4 \|\|
534	# arch_type == 5 \|\| arch_type == 36 \|\| arch_type == 60 \|\|
535	# arch_type == 85 \|\| arch_type == 111 \|\| arch_type == 123 \|\|
536	# arch_type == 124 \|\| arch_type == 130)) {
537	# // Treasure: randomtreasure/money/gems/potions/spellbooks/scrolls
538	# edit_type \|= IGUIConstants.TILE_EDIT_TREASURE;
539	# }
540	# if ((check_type & IGUIConstants.TILE_EDIT_DOOR) != 0 &&
541	# arch_type == 20 \|\| arch_type == 23 \|\| arch_type == 26 \|\|
542	# arch_type == 91 \|\| arch_type == 21 \|\| arch_type == 24) {
543	# // Door: door/special door/gates + keys
544	# edit_type \|= IGUIConstants.TILE_EDIT_DOOR;
545	# }
546	# if ((check_type & IGUIConstants.TILE_EDIT_EQUIP) != 0 &&
547	# getAttributeValue("no_pick", defarch) == 0 && ((arch_type >= 13 &&
548	# arch_type <= 16) \|\| arch_type == 33 \|\| arch_type == 34 \|\|
549	# arch_type == 35 \|\| arch_type == 39 \|\| arch_type == 70 \|\|
550	# arch_type == 87 \|\| arch_type == 99 \|\| arch_type == 100 \|\|
551	# arch_type == 104 \|\| arch_type == 109 \|\| arch_type == 113 \|\|
552	# arch_type == 122 \|\| arch_type == 3)) {
553	# // Equipment: weapons/armour/wands/rods
554	# edit_type \|= IGUIConstants.TILE_EDIT_EQUIP;
555	# }
556	#
557	# return(edit_type);
558	#
559	#
560	}
561
562	sub cache_file($$&&) {	833	sub cache_file($$&&) {
563	my ($src, $cache, $load, $create) = @_;	834	my ($src, $cache, $load, $create) = @_;
564		835
565	my ($size, $mtime) = (stat $src)[7,9]	836	my ($size, $mtime) = (stat $src)[7,9]
566	or Carp::croak "$src: $!";	837	or Carp::croak "$src: $!";
…		…
614	}, sub {	885	}, sub {
615	read_arch "$LIB/archetypes"	886	read_arch "$LIB/archetypes"
616	};	887	};
617	}	888	}
618		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
619	=item load_tilecache	920	=item load_tilecache
620		921
621	(Re-)Load %TILE and %FACE.	922	(Re-)Load %TILE and %FACE.
622		923
623	=cut	924	=cut
624		925
625	sub load_tilecache() {	926	sub load_tilecache() {
626	require Gtk2;	927	require Gtk2;
627		928
		929	if (-e "$LIB/crossfire.0") { # Crossfire1 version
628	cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub {	930	cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", \&use_tilecache,
629	$TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"	931	sub {
630	or die "$VARDIR/tilecache.png: $!";
631	*FACE = $_[0];
632	}, sub {
633	require File::Temp;
634
635	my $tile = read_pak "$LIB/crossfire.0";	932	my $tile = read_pak "$LIB/crossfire.0";
636		933
637	my %cache;	934	my %cache;
638		935
639	my $idx = 0;	936	my $idx = 0;
640		937
641	for my $name (sort keys %$tile) {	938	for my $name (sort keys %$tile) {
642	my ($fh, $filename) = File::Temp::tempfile ();	939	my $pb = new Gtk2::Gdk::PixbufLoader;
643	print $fh $tile->{$name};	940	$pb->write ($tile->{$name});
644	close $fh;	941	$pb->close;
645	my $pb = new_from_file Gtk2::Gdk::Pixbuf $filename;	942	my $pb = $pb->get_pixbuf;
646	unlink $filename;
647		943
648	my $tile = $cache{$name} = {	944	my $tile = $cache{$name} = {
649	pb => $pb,	945	pb => $pb,
650	idx => $idx,	946	idx => $idx,
651	w => int $pb->get_width / TILESIZE,	947	w => int $pb->get_width / TILESIZE,
652	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
653	};	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,
654		984	};
655		985
656	$idx += $tile->{w} * $tile->{h};	986	$idx += $tile->{w} * $tile->{h};
657	}
658
659	my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
660
661	while (my ($name, $tile) = each %cache) {
662	my $tpb = delete $tile->{pb};
663	my $ofs = $tile->{idx};
664
665	for my $x (0 .. $tile->{w} - 1) {
666	for my $y (0 .. $tile->{h} - 1) {
667	my $idx = $ofs + $x + $y * $tile->{w};
668	$tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
669	$pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
670	}	987	}
		988
		989	construct_tilecache_pb $idx, \%cache;
		990
		991	\%cache
671	}	992	};
672	}
673
674	$pb->save ("$VARDIR/tilecache.png", "png");
675
676	\%cache
677	};	993	}
678	}	994	}
679		995
680	=head1 AUTHOR	996	=head1 AUTHOR
681		997
682	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.59 by root, Sun Mar 26 11:52:31 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.59 by root, Sun Mar 26 11:52:31 2006 UTC vs.
Revision 1.105 by root, Tue Apr 17 18:50:41 2007 UTC