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

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.70 by root, Sun Aug 27 16:33:19 2006 UTC vs.
Revision 1.110 by root, Mon May 28 21:33:28 2007 UTC

…		…
4		4
5	=cut	5	=cut
6		6
7	package Crossfire;	7	package Crossfire;
8		8
9	our $VERSION = '0.9';	9	our $VERSION = '0.99';
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::Syck (); #TODO#d# replace by JSON::PC when it becomes available == working	24	use JSON::XS qw(from_json to_json);
25
26	sub from_json($) {
27	$JSON::Syck::ImplicitUnicode = 1;
28	JSON::Syck::Load $_[0]
29	}
30
31	sub to_json($) {
32	$JSON::Syck::ImplicitUnicode = 0;
33	JSON::Syck::Dump $_[0]
34	}
35		25
36	our $LIB = $ENV{CROSSFIRE_LIBDIR};	26	our $LIB = $ENV{CROSSFIRE_LIBDIR};
37		27
38	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";
39		31
40	mkdir $VARDIR, 0777;	32	mkdir $VARDIR, 0777;
41		33
42	sub TILESIZE (){ 32 }	34	sub TILESIZE (){ 32 }
43		35
…		…
56	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);
57		49
58	# same as in server save routine, to (hopefully) be compatible	50	# same as in server save routine, to (hopefully) be compatible
59	# to the other editors.	51	# to the other editors.
60	our @FIELD_ORDER_MAP = (qw(	52	our @FIELD_ORDER_MAP = (qw(
		53	file_format_version
61	name attach swap_time reset_timeout fixed_resettime difficulty region	54	name attach swap_time reset_timeout fixed_resettime difficulty region
62	shopitems shopgreed shopmin shopmax shoprace	55	shopitems shopgreed shopmin shopmax shoprace
63	darkness width height enter_x enter_y msg maplore	56	darkness width height enter_x enter_y msg maplore
64	unique template	57	unique template
65	outdoor temp pressure humid windspeed winddir sky nosmooth	58	outdoor temp pressure humid windspeed winddir sky nosmooth
66	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
67	));	60	));
68		61
69	our @FIELD_ORDER = (qw(	62	our @FIELD_ORDER = (qw(
		63	inherit
		64
70	elevation	65	elevation
71		66
72	name name_pl custom_name attach title race	67	name name_pl custom_name attach title race
73	slaying skill msg lore other_arch face	68	slaying skill msg lore other_arch
74	#todo-events
75	animation is_animated	69	face animation is_animated
		70	magicmap smoothlevel smoothface
76	str dex con wis pow cha int	71	str dex con wis pow cha int
77	hp maxhp sp maxsp grace maxgrace	72	hp maxhp sp maxsp grace maxgrace
78	exp perm_exp expmul	73	exp perm_exp expmul
79	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
80	nrof level direction type subtype attacktype	75	nrof level direction type subtype attacktype
…		…
88	resist_life_stealing resist_disease	83	resist_life_stealing resist_disease
89		84
90	path_attuned path_repelled path_denied material materialname	85	path_attuned path_repelled path_denied material materialname
91	value carrying weight invisible state magic	86	value carrying weight invisible state magic
92	last_heal last_sp last_grace last_eat	87	last_heal last_sp last_grace last_eat
93	connected glow_radius randomitems npx_status npc_program	88	connected glow_radius randomitems tresure_env npx_status npc_program
94	run_away pick_up container will_apply smoothlevel	89	run_away pick_up container will_apply smoothlevel
95	current_weapon_script weapontype tooltype elevation client_type	90	current_weapon_script weapontype tooltype elevation client_type
96	item_power duration range	91	item_power duration range
97	range_modifier duration_modifier dam_modifier gen_sp_armour	92	range_modifier duration_modifier dam_modifier gen_sp_armour
98	move_type move_block move_allow move_on move_off move_on move_slow move_slow_penalty	93	move_type move_block move_allow move_on move_off move_on move_slow move_slow_penalty
…		…
109	known_magical known_cursed can_use_skill been_applied has_ready_scroll	104	known_magical known_cursed can_use_skill been_applied has_ready_scroll
110	can_use_rod can_use_horn make_invisible inv_locked is_wooded is_hilly	105	can_use_rod can_use_horn make_invisible inv_locked is_wooded is_hilly
111	has_ready_skill has_ready_weapon no_skill_ident is_blind can_see_in_dark	106	has_ready_skill has_ready_weapon no_skill_ident is_blind can_see_in_dark
112	is_cauldron is_dust no_steal one_hit berserk neutral no_attack no_damage	107	is_cauldron is_dust no_steal one_hit berserk neutral no_attack no_damage
113	activate_on_push activate_on_release is_water use_content_on_gen is_buildable	108	activate_on_push activate_on_release is_water use_content_on_gen is_buildable
		109	precious
114		110
115	body_range body_arm body_torso body_head body_neck body_skill	111	body_range body_arm body_torso body_head body_neck body_skill
116	body_finger body_shoulder body_foot body_hand body_wrist body_waist	112	body_finger body_shoulder body_foot body_hand body_wrist body_waist
117	));	113	));
118		114
…		…
135	sub MOVE_FLY_LOW (){ 0x02 }	131	sub MOVE_FLY_LOW (){ 0x02 }
136	sub MOVE_FLY_HIGH (){ 0x04 }	132	sub MOVE_FLY_HIGH (){ 0x04 }
137	sub MOVE_FLYING (){ 0x06 }	133	sub MOVE_FLYING (){ 0x06 }
138	sub MOVE_SWIM (){ 0x08 }	134	sub MOVE_SWIM (){ 0x08 }
139	sub MOVE_BOAT (){ 0x10 }	135	sub MOVE_BOAT (){ 0x10 }
		136	sub MOVE_SHIP (){ 0x20 }
140	sub MOVE_KNOWN (){ 0x1f } # all of above	137	sub MOVE_KNOWN (){ 0x3f } # all of above
141	sub MOVE_ALLBIT (){ 0x10000 }
142	sub MOVE_ALL (){ 0x1001f } # very special value, more PITA	138	sub MOVE_ALL (){ 0x10000 } # very special value
		139
		140	our %MOVE_TYPE = (
		141	walk => MOVE_WALK,
		142	fly_low => MOVE_FLY_LOW,
		143	fly_high => MOVE_FLY_HIGH,
		144	flying => MOVE_FLYING,
		145	swim => MOVE_SWIM,
		146	boat => MOVE_BOAT,
		147	ship => MOVE_SHIP,
		148	all => MOVE_ALL,
		149	);
		150
		151	our @MOVE_TYPE = keys %MOVE_TYPE;
		152
		153	{
		154	package Crossfire::MoveType;
		155
		156	use overload
		157	'=' => sub { bless [@{$_[0]}], ref $_[0] },
		158	'""' => \&as_string,
		159	'>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef },
		160	'+=' => sub { $_[0][0] \|= $MOVE_TYPE{$_[1]}; $_[0][1] \|= $MOVE_TYPE{$_[1]}; &normalise },
		161	'-=' => sub { $_[0][0] \|= $MOVE_TYPE{$_[1]}; $_[0][1] &= ~$MOVE_TYPE{$_[1]}; &normalise },
		162	'/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise },
		163	'x=' => sub {
		164	my $cur = $_[0] >= $_[1];
		165	if (!defined $cur) {
		166	if ($_[0] >= "all") {
		167	$_[0] -= $_[1];
		168	} else {
		169	$_[0] += $_[1];
		170	}
		171	} elsif ($cur) {
		172	$_[0] -= $_[1];
		173	} else {
		174	$_[0] /= $_[1];
		175	}
		176
		177	$_[0]
		178	},
		179	'eq' => sub { "$_[0]" eq "$_[1]" },
		180	'ne' => sub { "$_[0]" ne "$_[1]" },
		181	;
		182	}
		183
		184	sub Crossfire::MoveType::new {
		185	my ($class, $string) = @_;
		186
		187	my $mask;
		188	my $value;
		189
		190	if ($string =~ /^\s\d+\s$/) {
		191	$mask = MOVE_ALL;
		192	$value = $string+0;
		193	} else {
		194	for (split /\s+/, lc $string) {
		195	if (s/^-//) {
		196	$mask \|= $MOVE_TYPE{$_};
		197	$value &= ~$MOVE_TYPE{$_};
		198	} else {
		199	$mask \|= $MOVE_TYPE{$_};
		200	$value \|= $MOVE_TYPE{$_};
		201	}
		202	}
		203	}
		204
		205	(bless [$mask, $value], $class)->normalise
		206	}
		207
		208	sub Crossfire::MoveType::normalise {
		209	my ($self) = @_;
		210
		211	if ($self->[0] & MOVE_ALL) {
		212	my $mask = ~(($self->[1] & MOVE_ALL ? $self->[1] : ~$self->[1]) & $self->[0] & ~MOVE_ALL);
		213	$self->[0] &= $mask;
		214	$self->[1] &= $mask;
		215	}
		216
		217	$self->[1] &= $self->[0];
		218
		219	$self
		220	}
		221
		222	sub Crossfire::MoveType::as_string {
		223	my ($self) = @_;
		224
		225	my @res;
		226
		227	my ($mask, $value) = @$self;
		228
		229	for (@Crossfire::MOVE_TYPE) {
		230	my $bit = $Crossfire::MOVE_TYPE{$_};
		231	if (($mask & $bit) == $bit && (($value & $bit) == $bit \|\| ($value & $bit) == 0)) {
		232	$mask &= ~$bit;
		233	push @res, $value & $bit ? $_ : "-$_";
		234	}
		235	}
		236
		237	join " ", @res
		238	}
143		239
144	sub load_ref($) {	240	sub load_ref($) {
145	my ($path) = @_;	241	my ($path) = @_;
146		242
147	open my $fh, "<:raw:perlio", $path	243	open my $fh, "<:raw:perlio", $path
…		…
160	close $fh;	256	close $fh;
161	rename "$path~", $path	257	rename "$path~", $path
162	or die "$path: $!";	258	or die "$path: $!";
163	}	259	}
164		260
		261	my %attack_mask = (
		262	physical => 0x00000001,
		263	magic => 0x00000002,
		264	fire => 0x00000004,
		265	electricity => 0x00000008,
		266	cold => 0x00000010,
		267	confusion => 0x00000020,
		268	acid => 0x00000040,
		269	drain => 0x00000080,
		270	weaponmagic => 0x00000100,
		271	ghosthit => 0x00000200,
		272	poison => 0x00000400,
		273	slow => 0x00000800,
		274	paralyze => 0x00001000,
		275	turn_undead => 0x00002000,
		276	fear => 0x00004000,
		277	cancellation => 0x00008000,
		278	deplete => 0x00010000,
		279	death => 0x00020000,
		280	chaos => 0x00040000,
		281	counterspell => 0x00080000,
		282	godpower => 0x00100000,
		283	holyword => 0x00200000,
		284	blind => 0x00400000,
		285	internal => 0x00800000,
		286	life_stealing => 0x01000000,
		287	disease => 0x02000000,
		288	);
		289
		290	sub _add_resist($$$) {
		291	my ($ob, $mask, $value) = @_;
		292
		293	while (my ($k, $v) = each %attack_mask) {
		294	$ob->{"resist_$k"} = min 100, max -100, $ob->{"resist_$k"} + $value if $mask & $v;
		295	}
		296	}
		297
		298	my %MATERIAL = reverse
		299	paper => 1,
		300	iron => 2,
		301	glass => 4,
		302	leather => 8,
		303	wood => 16,
		304	organic => 32,
		305	stone => 64,
		306	cloth => 128,
		307	adamant => 256,
		308	liquid => 512,
		309	tin => 1024,
		310	bone => 2048,
		311	ice => 4096,
		312
		313	# guesses
		314	runestone => 12,
		315	bronze => 18,
		316	"ancient wood" => 20,
		317	glass => 36,
		318	marble => 66,
		319	ice => 68,
		320	stone => 70,
		321	stone => 80,
		322	cloth => 136,
		323	ironwood => 144,
		324	adamantium => 258,
		325	glacium => 260,
		326	blood => 544,
		327	;
		328
165	# object as in "Object xxx", i.e. archetypes	329	# object as in "Object xxx", i.e. archetypes
166	sub normalize_object($) {	330	sub normalize_object($) {
167	my ($ob) = @_;	331	my ($ob) = @_;
168		332
		333	# convert material bitset to materialname, if possible
		334	if (exists $ob->{material}) {
		335	if (!$ob->{material}) {
		336	delete $ob->{material};
		337	} elsif (exists $ob->{materialname}) {
		338	if ($MATERIAL{$ob->{material}} eq $ob->{materialname}) {
		339	delete $ob->{material};
		340	} else {
		341	warn "object $ob->{_name} has both materialname ($ob->{materialname}) and material ($ob->{material}) set.\n";
		342	delete $ob->{material}; # assume materilname is more specific and nuke material
		343	}
		344	} elsif (my $name = $MATERIAL{$ob->{material}}) {
		345	delete $ob->{material};
		346	$ob->{materialname} = $name;
		347	} else {
		348	warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n";
		349	}
		350	}
		351
		352	# check whether attachment is the same as in the archetype
		353	if (exists $ob->{attach}) {
		354	my $arch = $ARCH{$ob->{_name}};
		355	my $js = JSON::XS->new->utf8->canonical (1);
		356
		357	if (defined $arch->{attach}
		358	&& $js->encode ($js->decode ($ob->{attach})) eq $js->encode ($arch->{attach})) {
		359	delete $ob->{attach}
		360	}
		361	}
		362
		363	# color_fg is used as default for magicmap if magicmap does not exist
		364	$ob->{magicmap} \|\|= delete $ob->{color_fg} if exists $ob->{color_fg};
		365
169	# nuke outdated or never supported fields	366	# nuke outdated or never supported fields
170	delete $ob->{$_} for qw(	367	delete @$ob{qw(
171	can_knockback can_parry can_impale can_cut can_dam_armour	368	can_knockback can_parry can_impale can_cut can_dam_armour
172	can_apply pass_thru can_pass_thru	369	can_apply pass_thru can_pass_thru color_bg color_fg
173	);	370	)};
		371
		372	if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; }
		373	if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; }
		374	if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; }
174		375
175	# convert movement strings to bitsets	376	# convert movement strings to bitsets
176	for my $attr (keys %FIELD_MOVEMENT) {	377	for my $attr (keys %FIELD_MOVEMENT) {
177	next unless exists $ob->{$attr};	378	next unless exists $ob->{$attr};
178		379
179	$ob->{$attr} = MOVE_ALL if $ob->{$attr} == 255; #d# compatibility	380	$ob->{$attr} = new Crossfire::MoveType $ob->{$attr};
180
181	next if $ob->{$attr} =~ /^\d+$/;
182
183	my $flags = 0;
184
185	# assume list
186	for my $flag (map lc, split /\s+/, $ob->{$attr}) {
187	$flags \|= MOVE_WALK if $flag eq "walk";
188	$flags \|= MOVE_FLY_LOW if $flag eq "fly_low";
189	$flags \|= MOVE_FLY_HIGH if $flag eq "fly_high";
190	$flags \|= MOVE_FLYING if $flag eq "flying";
191	$flags \|= MOVE_SWIM if $flag eq "swim";
192	$flags \|= MOVE_BOAT if $flag eq "boat";
193	$flags \|= MOVE_ALL if $flag eq "all";
194
195	$flags &= ~MOVE_WALK if $flag eq "-walk";
196	$flags &= ~MOVE_FLY_LOW if $flag eq "-fly_low";
197	$flags &= ~MOVE_FLY_HIGH if $flag eq "-fly_high";
198	$flags &= ~MOVE_FLYING if $flag eq "-flying";
199	$flags &= ~MOVE_SWIM if $flag eq "-swim";
200	$flags &= ~MOVE_BOAT if $flag eq "-boat";
201	$flags &= ~MOVE_ALL if $flag eq "-all";
202	}
203
204	$ob->{$attr} = $flags;
205	}	381	}
206		382
207	# convert outdated movement flags to new movement sets	383	# convert outdated movement flags to new movement sets
208	if (defined (my $v = delete $ob->{no_pass})) {	384	if (defined (my $v = delete $ob->{no_pass})) {
209	$ob->{move_block} = $v ? MOVE_ALL : 0;	385	$ob->{move_block} = new Crossfire::MoveType $v ? "all" : "";
210	}	386	}
211	if (defined (my $v = delete $ob->{slow_move})) {	387	if (defined (my $v = delete $ob->{slow_move})) {
212	$ob->{move_slow} \|= MOVE_WALK;	388	$ob->{move_slow} += "walk";
213	$ob->{move_slow_penalty} = $v;	389	$ob->{move_slow_penalty} = $v;
214	}	390	}
215	if (defined (my $v = delete $ob->{walk_on})) {	391	if (defined (my $v = delete $ob->{walk_on})) {
216	$ob->{move_on} = MOVE_ALL unless exists $ob->{move_on};	392	$ob->{move_on} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" }
217	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_WALK
218	: $ob->{move_on} & ~MOVE_WALK;
219	}	393	}
220	if (defined (my $v = delete $ob->{walk_off})) {	394	if (defined (my $v = delete $ob->{walk_off})) {
221	$ob->{move_off} = MOVE_ALL unless exists $ob->{move_off};	395	$ob->{move_off} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" }
222	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_WALK
223	: $ob->{move_off} & ~MOVE_WALK;
224	}	396	}
225	if (defined (my $v = delete $ob->{fly_on})) {	397	if (defined (my $v = delete $ob->{fly_on})) {
226	$ob->{move_on} = MOVE_ALL unless exists $ob->{move_on};	398	$ob->{move_on} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "fly_low" } else { $ob->{move_on} -= "fly_low" }
227	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_FLY_LOW
228	: $ob->{move_on} & ~MOVE_FLY_LOW;
229	}	399	}
230	if (defined (my $v = delete $ob->{fly_off})) {	400	if (defined (my $v = delete $ob->{fly_off})) {
231	$ob->{move_off} = MOVE_ALL unless exists $ob->{move_off};	401	$ob->{move_off} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "fly_low" } else { $ob->{move_off} -= "fly_low" }
232	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_FLY_LOW
233	: $ob->{move_off} & ~MOVE_FLY_LOW;
234	}	402	}
235	if (defined (my $v = delete $ob->{flying})) {	403	if (defined (my $v = delete $ob->{flying})) {
236	$ob->{move_type} = MOVE_ALL unless exists $ob->{move_type};	404	$ob->{move_type} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_type} += "fly_low" } else { $ob->{move_type} -= "fly_low" }
237	$ob->{move_type} = $v ? $ob->{move_type} \| MOVE_FLY_LOW
238	: $ob->{move_type} & ~MOVE_FLY_LOW;
239	}	405	}
240		406
241	# convert idiotic event_xxx things into objects	407	# convert idiotic event_xxx things into objects
242	while (my ($event, $subtype) = each %EVENT_TYPE) {	408	while (my ($event, $subtype) = each %EVENT_TYPE) {
243	if (exists $ob->{"event_${event}_plugin"}) {	409	if (exists $ob->{"event_${event}_plugin"}) {
…		…
247	slaying => delete $ob->{"event_${event}"},	413	slaying => delete $ob->{"event_${event}"},
248	name => delete $ob->{"event_${event}_options"},	414	name => delete $ob->{"event_${event}_options"},
249	};	415	};
250	}	416	}
251	}	417	}
		418
		419	# some archetypes had "+3" instead of the canonical "3", so fix
		420	$ob->{dam} *= 1 if exists $ob->{dam};
252		421
253	$ob	422	$ob
254	}	423	}
255		424
256	# arch as in "arch xxx", ie.. objects	425	# arch as in "arch xxx", ie.. objects
…		…
338	sub read_arch($;$) {	507	sub read_arch($;$) {
339	my ($path, $toplevel) = @_;	508	my ($path, $toplevel) = @_;
340		509
341	my %arc;	510	my %arc;
342	my ($more, $prev);	511	my ($more, $prev);
		512	my $comment;
343		513
344	open my $fh, "<:raw:perlio:utf8", $path	514	open my $fh, "<:raw:perlio:utf8", $path
345	or Carp::croak "$path: $!";	515	or Carp::croak "$path: $!";
346		516
347	# binmode $fh;	517	# binmode $fh;
…		…
351		521
352	while (<$fh>) {	522	while (<$fh>) {
353	s/\s+$//;	523	s/\s+$//;
354	if (/^end$/i) {	524	if (/^end$/i) {
355	last;	525	last;
		526
356	} elsif (/^arch (\S+)$/i) {	527	} elsif (/^arch (\S+)$/i) {
357	push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);	528	push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
		529
358	} elsif (/^lore$/i) {	530	} elsif (/^lore$/i) {
359	while (<$fh>) {	531	while (<$fh>) {
360	last if /^endlore\s*$/i;	532	last if /^endlore\s*$/i;
361	$arc{lore} .= $_;	533	$arc{lore} .= $_;
362	}	534	}
…		…
371	chomp;	543	chomp;
372	push @{ $arc{anim} }, $_;	544	push @{ $arc{anim} }, $_;
373	}	545	}
374	} elsif (/^(\S+)\s(.)$/) {	546	} elsif (/^(\S+)\s(.)$/) {
375	$arc{lc $1} = $2;	547	$arc{lc $1} = $2;
376	} elsif (/^\s*($\|#)/) {	548	} elsif (/^\s*#/) {
		549	$arc{_comment} .= "$_\n";
		550
		551	} elsif (/^\s*$/) {
377	#	552	#
378	} else {	553	} else {
379	warn "$path: unparsable line '$_' in arch $arc{_name}";	554	warn "$path: unparsable line '$_' in arch $arc{_name}";
380	}	555	}
381	}	556	}
…		…
387	s/\s+$//;	562	s/\s+$//;
388	if (/^more$/i) {	563	if (/^more$/i) {
389	$more = $prev;	564	$more = $prev;
390	} elsif (/^object (\S+)$/i) {	565	} elsif (/^object (\S+)$/i) {
391	my $name = $1;	566	my $name = $1;
392	my $arc = attr_thaw normalize_object $parse_block->(_name => $name);	567	my $arc = attr_thaw normalize_object $parse_block->(_name => $name, _comment => $comment);
		568	undef $comment;
		569	delete $arc{_comment} unless length $arc{_comment};
		570	$arc->{_atype} = 'object';
393		571
394	if ($more) {	572	if ($more) {
395	$more->{more} = $arc;	573	$more->{more} = $arc;
396	} else {	574	} else {
397	$arc{$name} = $arc;	575	$arc{$name} = $arc;
398	}	576	}
399	$prev = $arc;	577	$prev = $arc;
400	$more = undef;	578	$more = undef;
401	} elsif (/^arch (\S+)$/i) {	579	} elsif (/^arch (\S+)$/i) {
402	my $name = $1;	580	my $name = $1;
403	my $arc = attr_thaw normalize_arch $parse_block->(_name => $name);	581	my $arc = attr_thaw normalize_arch $parse_block->(_name => $name, _comment => $comment);
		582	undef $comment;
		583	delete $arc{_comment} unless length $arc{_comment};
		584	$arc->{_atype} = 'arch';
404		585
405	if ($more) {	586	if ($more) {
406	$more->{more} = $arc;	587	$more->{more} = $arc;
407	} else {	588	} else {
408	push @{ $arc{arch} }, $arc;	589	push @{ $arc{arch} }, $arc;
…		…
416	push @{$toplevel->{lev_array}}, $_+0;	597	push @{$toplevel->{lev_array}}, $_+0;
417	}	598	}
418	} else {	599	} else {
419	$toplevel->{$1} = $2;	600	$toplevel->{$1} = $2;
420	}	601	}
		602	} elsif (/^\s*#/) {
		603	$comment .= "$_\n";
421	} elsif (/^\s*($\|#)/) {	604	} elsif (/^\s*($\|#)/) {
422	#	605	#
423	} else {	606	} else {
424	die "$path: unparseable top-level line '$_'";	607	die "$path: unparseable top-level line '$_'";
425	}	608	}
426	}	609	}
427		610
428	undef $parse_block; # work around bug in perl not freeing $fh etc.	611	undef $parse_block; # work around bug in perl not freeing $fh etc.
429		612
430	\%arc	613	\%arc
		614	}
		615
		616	sub archlist_to_string {
		617	my ($arch) = @_;
		618
		619	my $str;
		620
		621	my $append; $append = sub {
		622	my %a = %{$_[0]};
		623
		624	Crossfire::attr_freeze \%a;
		625	Crossfire::normalize_arch \%a;
		626
		627	# undo the bit-split we did before
		628	if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) {
		629	$a{attack_movement} = (delete $a{attack_movement_bits_0_3})
		630	\| (delete $a{attack_movement_bits_4_7});
		631	}
		632
		633	if (my $comment = delete $a{_comment}) {
		634	if ($comment =~ /[^\n\s#]/) {
		635	$str .= $comment;
		636	}
		637	}
		638
		639	$str .= ((exists $a{_atype}) ? $a{_atype} : 'arch'). " $a{_name}\n";
		640
		641	my $inv = delete $a{inventory};
		642	my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some
		643	my $anim = delete $a{anim};
		644
		645	if ($a{_atype} eq 'object') {
		646	$str .= join "\n", "anim", @$anim, "mina\n"
		647	if $anim;
		648	}
		649
		650	my @kv;
		651
		652	for ($a{_name} eq "map"
		653	? @Crossfire::FIELD_ORDER_MAP
		654	: @Crossfire::FIELD_ORDER) {
		655	push @kv, [$_, delete $a{$_}]
		656	if exists $a{$_};
		657	}
		658
		659	for (sort keys %a) {
		660	next if /^_/; # ignore our _-keys
		661	push @kv, [$_, delete $a{$_}];
		662	}
		663
		664	for (@kv) {
		665	my ($k, $v) = @$_;
		666
		667	if (my $end = $Crossfire::FIELD_MULTILINE{$k}) {
		668	$v =~ s/\n$//;
		669	$str .= "$k\n$v\n$end\n";
		670	} else {
		671	$str .= "$k $v\n";
		672	}
		673	}
		674
		675	if ($inv) {
		676	$append->($_) for @$inv;
		677	}
		678
		679	$str .= "end\n";
		680
		681	if ($a{_atype} eq 'object') {
		682	if ($more) {
		683	$str .= "more\n";
		684	$append->($more) if $more;
		685	} else {
		686	$str .= "\n";
		687	}
		688	}
		689	};
		690
		691	for (@$arch) {
		692	$append->($_);
		693	}
		694
		695	$str
431	}	696	}
432		697
433	# put all archs into a hash with editor_face as it's key	698	# put all archs into a hash with editor_face as it's key
434	# NOTE: the arrays in the hash values are references to	699	# NOTE: the arrays in the hash values are references to
435	# the archs from $ARCH	700	# the archs from $ARCH
…		…
456	my ($a) = @_;	721	my ($a) = @_;
457		722
458	my $o = $ARCH{$a->{_name}}	723	my $o = $ARCH{$a->{_name}}
459	or return;	724	or return;
460		725
461	my $face = $FACE{$a->{face} \|\| $o->{face} \|\| "blank.111"}	726	my $face = $FACE{$a->{face} \|\| $o->{face} \|\| "blank.111"};
		727	unless ($face) {
		728	$face = $FACE{"blank.x11"}
462	or (warn "no face data found for arch '$a->{_name}'"), return;	729	or (warn "no face data found for arch '$a->{_name}'"), return;
		730	}
463		731
464	if ($face->{w} > 1 \|\| $face->{h} > 1) {	732	if ($face->{w} > 1 \|\| $face->{h} > 1) {
465	# bigface	733	# bigface
466	return (0, 0, $face->{w} - 1, $face->{h} - 1);	734	return (0, 0, $face->{w} - 1, $face->{h} - 1);
467		735
…		…
574	];	842	];
575		843
576	$attr	844	$attr
577	}	845	}
578		846
579	sub arch_edit_sections {
580	# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
581	# edit_type = 0;
582	# else if (edit_type != 0) {
583	# // all flags from 'check_type' must be unset in this arch because they get recalculated now
584	# edit_type &= ~check_type;
585	# }
586	#
587	# }
588	# if ((check_type & IGUIConstants.TILE_EDIT_MONSTER) != 0 &&
589	# getAttributeValue("alive", defarch) == 1 &&
590	# (getAttributeValue("monster", defarch) == 1 \|\|
591	# getAttributeValue("generator", defarch) == 1)) {
592	# // Monster: monsters/npcs/generators
593	# edit_type \|= IGUIConstants.TILE_EDIT_MONSTER;
594	# }
595	# if ((check_type & IGUIConstants.TILE_EDIT_WALL) != 0 &&
596	# arch_type == 0 && getAttributeValue("no_pass", defarch) == 1) {
597	# // Walls
598	# edit_type \|= IGUIConstants.TILE_EDIT_WALL;
599	# }
600	# if ((check_type & IGUIConstants.TILE_EDIT_CONNECTED) != 0 &&
601	# getAttributeValue("connected", defarch) != 0) {
602	# // Connected Objects
603	# edit_type \|= IGUIConstants.TILE_EDIT_CONNECTED;
604	# }
605	# if ((check_type & IGUIConstants.TILE_EDIT_EXIT) != 0 &&
606	# arch_type == 66 \|\| arch_type == 41 \|\| arch_type == 95) {
607	# // Exit: teleporter/exit/trapdoors
608	# edit_type \|= IGUIConstants.TILE_EDIT_EXIT;
609	# }
610	# if ((check_type & IGUIConstants.TILE_EDIT_TREASURE) != 0 &&
611	# getAttributeValue("no_pick", defarch) == 0 && (arch_type == 4 \|\|
612	# arch_type == 5 \|\| arch_type == 36 \|\| arch_type == 60 \|\|
613	# arch_type == 85 \|\| arch_type == 111 \|\| arch_type == 123 \|\|
614	# arch_type == 124 \|\| arch_type == 130)) {
615	# // Treasure: randomtreasure/money/gems/potions/spellbooks/scrolls
616	# edit_type \|= IGUIConstants.TILE_EDIT_TREASURE;
617	# }
618	# if ((check_type & IGUIConstants.TILE_EDIT_DOOR) != 0 &&
619	# arch_type == 20 \|\| arch_type == 23 \|\| arch_type == 26 \|\|
620	# arch_type == 91 \|\| arch_type == 21 \|\| arch_type == 24) {
621	# // Door: door/special door/gates + keys
622	# edit_type \|= IGUIConstants.TILE_EDIT_DOOR;
623	# }
624	# if ((check_type & IGUIConstants.TILE_EDIT_EQUIP) != 0 &&
625	# getAttributeValue("no_pick", defarch) == 0 && ((arch_type >= 13 &&
626	# arch_type <= 16) \|\| arch_type == 33 \|\| arch_type == 34 \|\|
627	# arch_type == 35 \|\| arch_type == 39 \|\| arch_type == 70 \|\|
628	# arch_type == 87 \|\| arch_type == 99 \|\| arch_type == 100 \|\|
629	# arch_type == 104 \|\| arch_type == 109 \|\| arch_type == 113 \|\|
630	# arch_type == 122 \|\| arch_type == 3)) {
631	# // Equipment: weapons/armour/wands/rods
632	# edit_type \|= IGUIConstants.TILE_EDIT_EQUIP;
633	# }
634	#
635	# return(edit_type);
636	#
637	#
638	}
639
640	sub cache_file($$&&) {	847	sub cache_file($$&&) {
641	my ($src, $cache, $load, $create) = @_;	848	my ($src, $cache, $load, $create) = @_;
642		849
643	my ($size, $mtime) = (stat $src)[7,9]	850	my ($size, $mtime) = (stat $src)[7,9]
644	or Carp::croak "$src: $!";	851	or Carp::croak "$src: $!";
…		…
692	}, sub {	899	}, sub {
693	read_arch "$LIB/archetypes"	900	read_arch "$LIB/archetypes"
694	};	901	};
695	}	902	}
696		903
		904	sub construct_tilecache_pb {
		905	my ($idx, $cache) = @_;
		906
		907	my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
		908
		909	while (my ($name, $tile) = each %$cache) {
		910	my $tpb = delete $tile->{pb};
		911	my $ofs = $tile->{idx};
		912
		913	for my $x (0 .. $tile->{w} - 1) {
		914	for my $y (0 .. $tile->{h} - 1) {
		915	my $idx = $ofs + $x + $y * $tile->{w};
		916	$tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
		917	$pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
		918	}
		919	}
		920	}
		921
		922	$pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
		923
		924	$cache
		925	}
		926
		927	sub use_tilecache {
		928	my ($face) = @_;
		929	$TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
		930	or die "$VARDIR/tilecache.png: $!";
		931	*FACE = $_[0];
		932	}
		933
697	=item load_tilecache	934	=item load_tilecache
698		935
699	(Re-)Load %TILE and %FACE.	936	(Re-)Load %TILE and %FACE.
700		937
701	=cut	938	=cut
702		939
703	sub load_tilecache() {	940	sub load_tilecache() {
704	require Gtk2;	941	require Gtk2;
705		942
		943	if (-e "$LIB/crossfire.0") { # Crossfire1 version
706	cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub {	944	cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", \&use_tilecache,
707	$TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"	945	sub {
708	or die "$VARDIR/tilecache.png: $!";
709	*FACE = $_[0];
710	}, sub {
711	my $tile = read_pak "$LIB/crossfire.0";	946	my $tile = read_pak "$LIB/crossfire.0";
712		947
713	my %cache;	948	my %cache;
714		949
715	my $idx = 0;	950	my $idx = 0;
716		951
717	for my $name (sort keys %$tile) {	952	for my $name (sort keys %$tile) {
718	my $pb = new Gtk2::Gdk::PixbufLoader;	953	my $pb = new Gtk2::Gdk::PixbufLoader;
719	$pb->write ($tile->{$name});	954	$pb->write ($tile->{$name});
720	$pb->close;	955	$pb->close;
721	my $pb = $pb->get_pixbuf;	956	my $pb = $pb->get_pixbuf;
722		957
723	my $tile = $cache{$name} = {	958	my $tile = $cache{$name} = {
724	pb => $pb,	959	pb => $pb,
725	idx => $idx,	960	idx => $idx,
726	w => int $pb->get_width / TILESIZE,	961	w => int $pb->get_width / TILESIZE,
727	h => int $pb->get_height / TILESIZE,	962	h => int $pb->get_height / TILESIZE,
		963	};
		964
		965	$idx += $tile->{w} * $tile->{h};
		966	}
		967
		968	construct_tilecache_pb $idx, \%cache;
		969
		970	\%cache
728	};	971	};
		972
		973	} else { # Crossfire+ version
		974	cache_file "$LIB/facedata", "$VARDIR/tilecache.pst", \&use_tilecache,
		975	sub {
		976	my %cache;
		977	my $facedata = Storable::retrieve "$LIB/facedata";
		978
		979	$facedata->{version} == 2
		980	or die "$LIB/facedata: version mismatch, cannot proceed.";
		981
		982	my $faces = $facedata->{faceinfo};
		983	my $idx = 0;
		984
		985	for (sort keys %$faces) {
		986	my ($face, $info) = ($_, $faces->{$_});
		987
		988	my $pb = new Gtk2::Gdk::PixbufLoader;
		989	$pb->write ($info->{data32});
		990	$pb->close;
		991	my $pb = $pb->get_pixbuf;
		992
		993	my $tile = $cache{$face} = {
		994	pb => $pb,
		995	idx => $idx,
		996	w => int $pb->get_width / TILESIZE,
		997	h => int $pb->get_height / TILESIZE,
729		998	};
730		999
731	$idx += $tile->{w} * $tile->{h};	1000	$idx += $tile->{w} * $tile->{h};
732	}
733
734	my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
735
736	while (my ($name, $tile) = each %cache) {
737	my $tpb = delete $tile->{pb};
738	my $ofs = $tile->{idx};
739
740	for my $x (0 .. $tile->{w} - 1) {
741	for my $y (0 .. $tile->{h} - 1) {
742	my $idx = $ofs + $x + $y * $tile->{w};
743	$tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
744	$pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
745	}	1001	}
		1002
		1003	construct_tilecache_pb $idx, \%cache;
		1004
		1005	\%cache
746	}	1006	};
747	}
748
749	$pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
750
751	\%cache
752	};	1007	}
753	}	1008	}
754		1009
755	=head1 AUTHOR	1010	=head1 AUTHOR
756		1011
757	Marc Lehmann <schmorp@schmorp.de>	1012	Marc Lehmann <schmorp@schmorp.de>

Diff Legend

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

Comparing deliantra/Deliantra/Deliantra.pm (file contents): Revision 1.70 by root, Sun Aug 27 16:33:19 2006 UTC vs. Revision 1.110 by root, Mon May 28 21:33:28 2007 UTC

Diff Legend

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.70 by root, Sun Aug 27 16:33:19 2006 UTC vs.
Revision 1.110 by root, Mon May 28 21:33:28 2007 UTC