[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.118 by root, Wed Dec 5 11:39:26 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 = '1.13';
10		10
11	use strict;	11	use strict;
12		12
13	use base 'Exporter';	13	use base 'Exporter';
14		14
…		…
16	use File::Spec;	16	use File::Spec;
17	use List::Util qw(min max);	17	use List::Util qw(min max);
18	use Storable qw(freeze thaw);	18	use Storable qw(freeze thaw);
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
		22	ARCH $TILE FACE *FACEDATA
		23	TILESIZE CACHESTRIDE
		24	editor_archs arch_extents
22	);	25	);
23		26
		27	use JSON::XS qw(decode_json encode_json);
		28
24	our $LIB = $ENV{CROSSFIRE_LIBDIR};	29	our $LIB = $ENV{CROSSFIRE_LIBDIR};
25		30
26	our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire" : File::Spec->tmpdir . "/crossfire";	31	our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire"
		32	: $ENV{AppData} ? "$ENV{APPDATA}/crossfire"
		33	: File::Spec->tmpdir . "/crossfire";
27		34
28	mkdir $VARDIR, 0777;	35	mkdir $VARDIR, 0777;
29		36
30	sub TILESIZE (){ 32 }	37	sub TILESIZE (){ 32 }
		38	sub CACHESTRIDE (){ 64 }
31		39
32	our %ARCH;	40	our %ARCH;
		41	our %FACE; # face32
33	our %FACE;	42	our %FACEDATA;
34	our $TILE;	43	our $TILE;
35		44
36	our %FIELD_MULTILINE = (	45	our %FIELD_MULTILINE = (
37	msg => "endmsg",	46	msg => "endmsg",
38	lore => "endlore",	47	lore => "endlore",
…		…
44	qw(move_type move_block move_allow move_on move_off move_slow);	53	qw(move_type move_block move_allow move_on move_off move_slow);
45		54
46	# same as in server save routine, to (hopefully) be compatible	55	# same as in server save routine, to (hopefully) be compatible
47	# to the other editors.	56	# to the other editors.
48	our @FIELD_ORDER_MAP = (qw(	57	our @FIELD_ORDER_MAP = (qw(
		58	file_format_version
49	name swap_time reset_timeout fixed_resettime difficulty region	59	name attach swap_time reset_timeout fixed_resettime difficulty region
50	shopitems shopgreed shopmin shopmax shoprace	60	shopitems shopgreed shopmin shopmax shoprace
51	darkness width height enter_x enter_y msg maplore	61	darkness width height enter_x enter_y msg maplore
52	unique template	62	unique template
53	outdoor temp pressure humid windspeed winddir sky nosmooth	63	outdoor temp pressure humid windspeed winddir sky nosmooth
54	tile_path_1 tile_path_2 tile_path_3 tile_path_4	64	tile_path_1 tile_path_2 tile_path_3 tile_path_4
55	));	65	));
56		66
57	our @FIELD_ORDER = (qw(	67	our @FIELD_ORDER = (qw(
		68	inherit
		69
58	elevation	70	elevation
59		71
60	name name_pl custom_name title race	72	name name_pl custom_name attach title race
61	slaying skill msg lore other_arch face	73	slaying skill msg lore other_arch
62	#todo-events
63	animation is_animated	74	face animation is_animated
		75	magicmap smoothlevel smoothface
64	str dex con wis pow cha int	76	str dex con wis pow cha int
65	hp maxhp sp maxsp grace maxgrace	77	hp maxhp sp maxsp grace maxgrace
66	exp perm_exp expmul	78	exp perm_exp expmul
67	food dam luck wc ac x y speed speed_left move_state attack_movement	79	food dam luck wc ac x y speed speed_left move_state attack_movement
68	nrof level direction type subtype attacktype	80	nrof level direction type subtype attacktype
…		…
76	resist_life_stealing resist_disease	88	resist_life_stealing resist_disease
77		89
78	path_attuned path_repelled path_denied material materialname	90	path_attuned path_repelled path_denied material materialname
79	value carrying weight invisible state magic	91	value carrying weight invisible state magic
80	last_heal last_sp last_grace last_eat	92	last_heal last_sp last_grace last_eat
81	connected glow_radius randomitems npx_status npc_program	93	connected glow_radius randomitems tresure_env npx_status npc_program
82	run_away pick_up container will_apply smoothlevel	94	run_away pick_up container will_apply smoothlevel
83	current_weapon_script weapontype tooltype elevation client_type	95	current_weapon_script weapontype tooltype elevation client_type
84	item_power duration range	96	item_power duration range
85	range_modifier duration_modifier dam_modifier gen_sp_armour	97	range_modifier duration_modifier dam_modifier gen_sp_armour
86	move_type move_block move_allow move_on move_off move_on move_slow move_slow_penalty	98	move_type move_block move_allow move_on move_off move_on move_slow move_slow_penalty
…		…
97	known_magical known_cursed can_use_skill been_applied has_ready_scroll	109	known_magical known_cursed can_use_skill been_applied has_ready_scroll
98	can_use_rod can_use_horn make_invisible inv_locked is_wooded is_hilly	110	can_use_rod can_use_horn make_invisible inv_locked is_wooded is_hilly
99	has_ready_skill has_ready_weapon no_skill_ident is_blind can_see_in_dark	111	has_ready_skill has_ready_weapon no_skill_ident is_blind can_see_in_dark
100	is_cauldron is_dust no_steal one_hit berserk neutral no_attack no_damage	112	is_cauldron is_dust no_steal one_hit berserk neutral no_attack no_damage
101	activate_on_push activate_on_release is_water use_content_on_gen is_buildable	113	activate_on_push activate_on_release is_water use_content_on_gen is_buildable
		114	precious
102		115
103	body_range body_arm body_torso body_head body_neck body_skill	116	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	117	body_finger body_shoulder body_foot body_hand body_wrist body_waist
105	));	118	));
		119
		120	our %EVENT_TYPE = (
		121	apply => 1,
		122	attack => 2,
		123	death => 3,
		124	drop => 4,
		125	pickup => 5,
		126	say => 6,
		127	stop => 7,
		128	time => 8,
		129	throw => 9,
		130	trigger => 10,
		131	close => 11,
		132	timer => 12,
		133	);
106		134
107	sub MOVE_WALK (){ 0x01 }	135	sub MOVE_WALK (){ 0x01 }
108	sub MOVE_FLY_LOW (){ 0x02 }	136	sub MOVE_FLY_LOW (){ 0x02 }
109	sub MOVE_FLY_HIGH (){ 0x04 }	137	sub MOVE_FLY_HIGH (){ 0x04 }
110	sub MOVE_FLYING (){ 0x06 }	138	sub MOVE_FLYING (){ 0x06 }
111	sub MOVE_SWIM (){ 0x08 }	139	sub MOVE_SWIM (){ 0x08 }
112	sub MOVE_BOAT (){ 0x10 }	140	sub MOVE_BOAT (){ 0x10 }
		141	sub MOVE_SHIP (){ 0x20 }
113	sub MOVE_KNOWN (){ 0x1f } # all of above	142	sub MOVE_KNOWN (){ 0x3f } # all of above
114	sub MOVE_ALLBIT (){ 0x10000 }
115	sub MOVE_ALL (){ 0x1001f } # very special value, more PITA	143	sub MOVE_ALL (){ 0x10000 } # very special value
		144
		145	our %MOVE_TYPE = (
		146	walk => MOVE_WALK,
		147	fly_low => MOVE_FLY_LOW,
		148	fly_high => MOVE_FLY_HIGH,
		149	flying => MOVE_FLYING,
		150	swim => MOVE_SWIM,
		151	boat => MOVE_BOAT,
		152	ship => MOVE_SHIP,
		153	all => MOVE_ALL,
		154	);
		155
		156	our @MOVE_TYPE = keys %MOVE_TYPE;
		157
		158	{
		159	package Crossfire::MoveType;
		160
		161	use overload
		162	'=' => sub { bless [@{$_[0]}], ref $_[0] },
		163	'""' => \&as_string,
		164	'>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef },
		165	'+=' => sub { $_[0][0] \|= $MOVE_TYPE{$_[1]}; $_[0][1] \|= $MOVE_TYPE{$_[1]}; &normalise },
		166	'-=' => sub { $_[0][0] \|= $MOVE_TYPE{$_[1]}; $_[0][1] &= ~$MOVE_TYPE{$_[1]}; &normalise },
		167	'/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise },
		168	'x=' => sub {
		169	my $cur = $_[0] >= $_[1];
		170	if (!defined $cur) {
		171	if ($_[0] >= "all") {
		172	$_[0] -= $_[1];
		173	} else {
		174	$_[0] += $_[1];
		175	}
		176	} elsif ($cur) {
		177	$_[0] -= $_[1];
		178	} else {
		179	$_[0] /= $_[1];
		180	}
		181
		182	$_[0]
		183	},
		184	'eq' => sub { "$_[0]" eq "$_[1]" },
		185	'ne' => sub { "$_[0]" ne "$_[1]" },
		186	;
		187	}
		188
		189	sub Crossfire::MoveType::new {
		190	my ($class, $string) = @_;
		191
		192	my $mask;
		193	my $value;
		194
		195	if ($string =~ /^\s\d+\s$/) {
		196	$mask = MOVE_ALL;
		197	$value = $string+0;
		198	} else {
		199	for (split /\s+/, lc $string) {
		200	if (s/^-//) {
		201	$mask \|= $MOVE_TYPE{$_};
		202	$value &= ~$MOVE_TYPE{$_};
		203	} else {
		204	$mask \|= $MOVE_TYPE{$_};
		205	$value \|= $MOVE_TYPE{$_};
		206	}
		207	}
		208	}
		209
		210	(bless [$mask, $value], $class)->normalise
		211	}
		212
		213	sub Crossfire::MoveType::normalise {
		214	my ($self) = @_;
		215
		216	if ($self->[0] & MOVE_ALL) {
		217	my $mask = ~(($self->[1] & MOVE_ALL ? $self->[1] : ~$self->[1]) & $self->[0] & ~MOVE_ALL);
		218	$self->[0] &= $mask;
		219	$self->[1] &= $mask;
		220	}
		221
		222	$self->[1] &= $self->[0];
		223
		224	$self
		225	}
		226
		227	sub Crossfire::MoveType::as_string {
		228	my ($self) = @_;
		229
		230	my @res;
		231
		232	my ($mask, $value) = @$self;
		233
		234	for (@Crossfire::MOVE_TYPE) {
		235	my $bit = $Crossfire::MOVE_TYPE{$_};
		236	if (($mask & $bit) == $bit && (($value & $bit) == $bit \|\| ($value & $bit) == 0)) {
		237	$mask &= ~$bit;
		238	push @res, $value & $bit ? $_ : "-$_";
		239	}
		240	}
		241
		242	join " ", @res
		243	}
116		244
117	sub load_ref($) {	245	sub load_ref($) {
118	my ($path) = @_;	246	my ($path) = @_;
119		247
120	open my $fh, "<", $path	248	open my $fh, "<:raw:perlio", $path
121	or die "$path: $!";	249	or die "$path: $!";
122	binmode $fh;
123	local $/;	250	local $/;
124		251
125	thaw <$fh>	252	thaw <$fh>
126	}	253	}
127		254
128	sub save_ref($$) {	255	sub save_ref($$) {
129	my ($ref, $path) = @_;	256	my ($ref, $path) = @_;
130		257
131	open my $fh, ">", "$path~"	258	open my $fh, ">:raw:perlio", "$path~"
132	or die "$path~: $!";	259	or die "$path~: $!";
133	binmode $fh;
134	print $fh freeze $ref;	260	print $fh freeze $ref;
135	close $fh;	261	close $fh;
136	rename "$path~", $path	262	rename "$path~", $path
137	or die "$path: $!";	263	or die "$path: $!";
138	}	264	}
139		265
		266	my %attack_mask = (
		267	physical => 0x00000001,
		268	magic => 0x00000002,
		269	fire => 0x00000004,
		270	electricity => 0x00000008,
		271	cold => 0x00000010,
		272	confusion => 0x00000020,
		273	acid => 0x00000040,
		274	drain => 0x00000080,
		275	weaponmagic => 0x00000100,
		276	ghosthit => 0x00000200,
		277	poison => 0x00000400,
		278	slow => 0x00000800,
		279	paralyze => 0x00001000,
		280	turn_undead => 0x00002000,
		281	fear => 0x00004000,
		282	cancellation => 0x00008000,
		283	deplete => 0x00010000,
		284	death => 0x00020000,
		285	chaos => 0x00040000,
		286	counterspell => 0x00080000,
		287	godpower => 0x00100000,
		288	holyword => 0x00200000,
		289	blind => 0x00400000,
		290	internal => 0x00800000,
		291	life_stealing => 0x01000000,
		292	disease => 0x02000000,
		293	);
		294
		295	sub _add_resist($$$) {
		296	my ($ob, $mask, $value) = @_;
		297
		298	while (my ($k, $v) = each %attack_mask) {
		299	$ob->{"resist_$k"} = min 100, max -100, $ob->{"resist_$k"} + $value if $mask & $v;
		300	}
		301	}
		302
		303	my %MATERIAL = reverse
		304	paper => 1,
		305	iron => 2,
		306	glass => 4,
		307	leather => 8,
		308	wood => 16,
		309	organic => 32,
		310	stone => 64,
		311	cloth => 128,
		312	adamant => 256,
		313	liquid => 512,
		314	tin => 1024,
		315	bone => 2048,
		316	ice => 4096,
		317
		318	# guesses
		319	runestone => 12,
		320	bronze => 18,
		321	"ancient wood" => 20,
		322	glass => 36,
		323	marble => 66,
		324	ice => 68,
		325	stone => 70,
		326	stone => 80,
		327	cloth => 136,
		328	ironwood => 144,
		329	adamantium => 258,
		330	glacium => 260,
		331	blood => 544,
		332	;
		333
		334	# object as in "Object xxx", i.e. archetypes
140	sub normalize_object($) {	335	sub normalize_object($) {
141	my ($ob) = @_;	336	my ($ob) = @_;
142		337
		338	# convert material bitset to materialname, if possible
		339	if (exists $ob->{material}) {
		340	if (!$ob->{material}) {
		341	delete $ob->{material};
		342	} elsif (exists $ob->{materialname}) {
		343	if ($MATERIAL{$ob->{material}} eq $ob->{materialname}) {
		344	delete $ob->{material};
		345	} else {
		346	warn "object $ob->{_name} has both materialname ($ob->{materialname}) and material ($ob->{material}) set.\n";
		347	delete $ob->{material}; # assume materilname is more specific and nuke material
		348	}
		349	} elsif (my $name = $MATERIAL{$ob->{material}}) {
		350	delete $ob->{material};
		351	$ob->{materialname} = $name;
		352	} else {
		353	warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n";
		354	}
		355	}
		356
		357	# check whether attachment is the same as in the archetype
		358	if (exists $ob->{attach}) {
		359	my $arch = $ARCH{$ob->{_name}};
		360	my $js = JSON::XS->new->utf8->canonical (1);
		361
		362	if (defined $arch->{attach}
		363	&& $js->encode ($js->decode ($ob->{attach})) eq $js->encode ($arch->{attach})) {
		364	delete $ob->{attach}
		365	}
		366	}
		367
		368	# color_fg is used as default for magicmap if magicmap does not exist
		369	$ob->{magicmap} \|\|= delete $ob->{color_fg} if exists $ob->{color_fg};
		370
		371	# nuke outdated or never supported fields
143	delete $ob->{$_} for qw(	372	delete @$ob{qw(
144	can_knockback can_parry can_impale can_cut can_dam_armour	373	can_knockback can_parry can_impale can_cut can_dam_armour
145	can_apply pass_thru can_pass_thru	374	can_apply pass_thru can_pass_thru color_bg color_fg
146	);	375	)};
147		376
		377	if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; }
		378	if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; }
		379	if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; }
		380
		381	# convert movement strings to bitsets
148	for my $attr (keys %FIELD_MOVEMENT) {	382	for my $attr (keys %FIELD_MOVEMENT) {
149	next unless exists $ob->{$attr};	383	next unless exists $ob->{$attr};
150		384
151	$ob->{$attr} = MOVE_ALL if $ob->{$attr} == 255; #d# compatibility	385	$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	}	386	}
178		387
		388	# convert outdated movement flags to new movement sets
179	if (defined (my $v = delete $ob->{no_pass})) {	389	if (defined (my $v = delete $ob->{no_pass})) {
180	$ob->{move_block} = $v ? MOVE_ALL : 0;	390	$ob->{move_block} = new Crossfire::MoveType $v ? "all" : "";
181	}	391	}
182	if (defined (my $v = delete $ob->{slow_move})) {	392	if (defined (my $v = delete $ob->{slow_move})) {
183	$ob->{move_slow} \|= MOVE_WALK;	393	$ob->{move_slow} += "walk";
184	$ob->{move_slow_penalty} = $v;	394	$ob->{move_slow_penalty} = $v;
185	}	395	}
186	if (defined (my $v = delete $ob->{walk_on})) {	396	if (defined (my $v = delete $ob->{walk_on})) {
187	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_WALK	397	$ob->{move_on} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" }
188	: $ob->{move_on} & ~MOVE_WALK;
189	}	398	}
190	if (defined (my $v = delete $ob->{walk_off})) {	399	if (defined (my $v = delete $ob->{walk_off})) {
191	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_WALK	400	$ob->{move_off} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" }
192	: $ob->{move_off} & ~MOVE_WALK;
193	}	401	}
194	if (defined (my $v = delete $ob->{fly_on})) {	402	if (defined (my $v = delete $ob->{fly_on})) {
195	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_FLY_LOW	403	$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	}	404	}
198	if (defined (my $v = delete $ob->{fly_off})) {	405	if (defined (my $v = delete $ob->{fly_off})) {
199	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_FLY_LOW	406	$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	}	407	}
202	if (defined (my $v = delete $ob->{flying})) {	408	if (defined (my $v = delete $ob->{flying})) {
203	$ob->{move_type} = $v ? $ob->{move_type} \| MOVE_FLY_LOW	409	$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	}	410	}
		411
		412	# convert idiotic event_xxx things into objects
		413	while (my ($event, $subtype) = each %EVENT_TYPE) {
		414	if (exists $ob->{"event_${event}_plugin"}) {
		415	push @{$ob->{inventory}}, {
		416	_name => "event_$event",
		417	title => delete $ob->{"event_${event}_plugin"},
		418	slaying => delete $ob->{"event_${event}"},
		419	name => delete $ob->{"event_${event}_options"},
		420	};
		421	}
		422	}
		423
		424	# some archetypes had "+3" instead of the canonical "3", so fix
		425	$ob->{dam} *= 1 if exists $ob->{dam};
206		426
207	$ob	427	$ob
208	}	428	}
209		429
		430	# arch as in "arch xxx", ie.. objects
210	sub normalize_arch($) {	431	sub normalize_arch($) {
211	my ($ob) = @_;	432	my ($ob) = @_;
212		433
213	normalize_object $ob;	434	normalize_object $ob;
214		435
…		…
251	}	472	}
252		473
253	$ob	474	$ob
254	}	475	}
255		476
		477	sub attr_thaw($) {
		478	my ($ob) = @_;
		479
		480	$ob->{attach} = decode_json $ob->{attach}
		481	if exists $ob->{attach};
		482
		483	$ob
		484	}
		485
		486	sub attr_freeze($) {
		487	my ($ob) = @_;
		488
		489	$ob->{attach} = Crossfire::encode_json $ob->{attach}
		490	if exists $ob->{attach};
		491
		492	$ob
		493	}
		494
256	sub read_pak($) {	495	sub read_pak($) {
257	my ($path) = @_;	496	my ($path) = @_;
258		497
259	my %pak;	498	my %pak;
260		499
261	open my $fh, "<", $path	500	open my $fh, "<:raw:perlio", $path
262	or Carp::croak "$_[0]: $!";	501	or Carp::croak "$_[0]: $!";
263	binmode $fh;	502	binmode $fh;
264	while (<$fh>) {	503	while (<$fh>) {
265	my ($type, $id, $len, $path) = split;	504	my ($type, $id, $len, $path) = split;
266	$path =~ s/.*\///;	505	$path =~ s/.*\///;
…		…
268	}	507	}
269		508
270	\%pak	509	\%pak
271	}	510	}
272		511
273	sub read_arch($) {	512	sub read_arch($;$) {
274	my ($path) = @_;	513	my ($path, $toplevel) = @_;
275		514
276	my %arc;	515	my %arc;
277	my ($more, $prev);	516	my ($more, $prev);
		517	my $comment;
278		518
279	open my $fh, "<", $path	519	open my $fh, "<:raw:perlio:utf8", $path
280	or Carp::croak "$path: $!";	520	or Carp::croak "$path: $!";
281		521
282	binmode $fh;	522	# binmode $fh;
283		523
284	my $parse_block; $parse_block = sub {	524	my $parse_block; $parse_block = sub {
285	my %arc = @_;	525	my %arc = @_;
286		526
287	while (<$fh>) {	527	while (<$fh>) {
288	s/\s+$//;	528	s/\s+$//;
289	if (/^end$/i) {	529	if (/^end$/i) {
290	last;	530	last;
		531
291	} elsif (/^arch (\S+)$/i) {	532	} elsif (/^arch (\S+)$/i) {
292	push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1);	533	push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
		534
293	} elsif (/^lore$/i) {	535	} elsif (/^lore$/i) {
294	while (<$fh>) {	536	while (<$fh>) {
295	last if /^endlore\s*$/i;	537	last if /^endlore\s*$/i;
296	$arc{lore} .= $_;	538	$arc{lore} .= $_;
297	}	539	}
298	} elsif (/^msg$/i) {	540	} elsif (/^msg$/i) {
299	while (<$fh>) {	541	while (<$fh>) {
300	last if /^endmsg\s*$/i;	542	last if /^endmsg\s*$/i;
301	$arc{msg} .= $_;	543	$arc{msg} .= $_;
302	}	544	}
		545	} elsif (/^anim$/i) {
		546	while (<$fh>) {
		547	last if /^mina\s*$/i;
		548	chomp;
		549	push @{ $arc{anim} }, $_;
		550	}
303	} elsif (/^(\S+)\s(.)$/) {	551	} elsif (/^(\S+)\s(.)$/) {
304	$arc{lc $1} = $2;	552	$arc{lc $1} = $2;
305	} elsif (/^\s*($\|#)/) {	553	} elsif (/^\s*#/) {
		554	$arc{_comment} .= "$_\n";
		555
		556	} elsif (/^\s*$/) {
306	#	557	#
307	} else {	558	} else {
308	warn "$path: unparsable line '$_' in arch $arc{_name}";	559	warn "$path: unparsable line '$_' in arch $arc{_name}";
309	}	560	}
310	}	561	}
…		…
316	s/\s+$//;	567	s/\s+$//;
317	if (/^more$/i) {	568	if (/^more$/i) {
318	$more = $prev;	569	$more = $prev;
319	} elsif (/^object (\S+)$/i) {	570	} elsif (/^object (\S+)$/i) {
320	my $name = $1;	571	my $name = $1;
321	my $arc = normalize_object $parse_block->(_name => $name);	572	my $arc = attr_thaw normalize_object $parse_block->(_name => $name, _comment => $comment);
		573	undef $comment;
		574	delete $arc{_comment} unless length $arc{_comment};
		575	$arc->{_atype} = 'object';
322		576
323	if ($more) {	577	if ($more) {
324	$more->{more} = $arc;	578	$more->{more} = $arc;
325	} else {	579	} else {
326	$arc{$name} = $arc;	580	$arc{$name} = $arc;
327	}	581	}
328	$prev = $arc;	582	$prev = $arc;
329	$more = undef;	583	$more = undef;
330	} elsif (/^arch (\S+)$/i) {	584	} elsif (/^arch (\S+)$/i) {
331	my $name = $1;	585	my $name = $1;
332	my $arc = normalize_arch $parse_block->(_name => $name);	586	my $arc = attr_thaw normalize_arch $parse_block->(_name => $name, _comment => $comment);
		587	undef $comment;
		588	delete $arc{_comment} unless length $arc{_comment};
		589	$arc->{_atype} = 'arch';
333		590
334	if ($more) {	591	if ($more) {
335	$more->{more} = $arc;	592	$more->{more} = $arc;
336	} else {	593	} else {
337	push @{ $arc{arch} }, $arc;	594	push @{ $arc{arch} }, $arc;
338	}	595	}
339	$prev = $arc;	596	$prev = $arc;
340	$more = undef;	597	$more = undef;
		598	} elsif ($toplevel && /^(\S+)\s+(.*)$/) {
		599	if ($1 eq "lev_array") {
		600	while (<$fh>) {
		601	last if /^endplst\s*$/;
		602	push @{$toplevel->{lev_array}}, $_+0;
		603	}
		604	} else {
		605	$toplevel->{$1} = $2;
		606	}
		607	} elsif (/^\s*#/) {
		608	$comment .= "$_\n";
341	} elsif (/^\s*($\|#)/) {	609	} elsif (/^\s*($\|#)/) {
342	#	610	#
343	} else {	611	} else {
344	warn "$path: unparseable top-level line '$_'";	612	die "$path: unparseable top-level line '$_'";
345	}	613	}
346	}	614	}
347		615
348	undef $parse_block; # work around bug in perl not freeing $fh etc.	616	undef $parse_block; # work around bug in perl not freeing $fh etc.
349		617
350	\%arc	618	\%arc
		619	}
		620
		621	sub archlist_to_string {
		622	my ($arch) = @_;
		623
		624	my $str;
		625
		626	my $append; $append = sub {
		627	my %a = %{$_[0]};
		628
		629	Crossfire::attr_freeze \%a;
		630	Crossfire::normalize_arch \%a;
		631
		632	# undo the bit-split we did before
		633	if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) {
		634	$a{attack_movement} = (delete $a{attack_movement_bits_0_3})
		635	\| (delete $a{attack_movement_bits_4_7});
		636	}
		637
		638	if (my $comment = delete $a{_comment}) {
		639	if ($comment =~ /[^\n\s#]/) {
		640	$str .= $comment;
		641	}
		642	}
		643
		644	$str .= ((exists $a{_atype}) ? $a{_atype} : 'arch'). " $a{_name}\n";
		645
		646	my $inv = delete $a{inventory};
		647	my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some
		648	my $anim = delete $a{anim};
		649
		650	if ($a{_atype} eq 'object') {
		651	$str .= join "\n", "anim", @$anim, "mina\n"
		652	if $anim;
		653	}
		654
		655	my @kv;
		656
		657	for ($a{_name} eq "map"
		658	? @Crossfire::FIELD_ORDER_MAP
		659	: @Crossfire::FIELD_ORDER) {
		660	push @kv, [$_, delete $a{$_}]
		661	if exists $a{$_};
		662	}
		663
		664	for (sort keys %a) {
		665	next if /^_/; # ignore our _-keys
		666	push @kv, [$_, delete $a{$_}];
		667	}
		668
		669	for (@kv) {
		670	my ($k, $v) = @$_;
		671
		672	if (my $end = $Crossfire::FIELD_MULTILINE{$k}) {
		673	$v =~ s/\n$//;
		674	$str .= "$k\n$v\n$end\n";
		675	} else {
		676	$str .= "$k $v\n";
		677	}
		678	}
		679
		680	if ($inv) {
		681	$append->($_) for @$inv;
		682	}
		683
		684	$str .= "end\n";
		685
		686	if ($a{_atype} eq 'object') {
		687	if ($more) {
		688	$str .= "more\n";
		689	$append->($more) if $more;
		690	} else {
		691	$str .= "\n";
		692	}
		693	}
		694	};
		695
		696	for (@$arch) {
		697	$append->($_);
		698	}
		699
		700	$str
351	}	701	}
352		702
353	# put all archs into a hash with editor_face as it's key	703	# put all archs into a hash with editor_face as it's key
354	# NOTE: the arrays in the hash values are references to	704	# NOTE: the arrays in the hash values are references to
355	# the archs from $ARCH	705	# the archs from $ARCH
356	sub editor_archs {	706	sub editor_archs {
357	my %paths;	707	my %paths;
358		708
359	for (keys %ARCH) {	709	for (keys %ARCH) {
360	my $arch = $ARCH{$_};	710	my $arch = $ARCH{$_};
361	push @{$paths{$arch->{editor_folder}}}, \$arch;	711	push @{$paths{$arch->{editor_folder}}}, $arch;
362	}	712	}
363		713
364	\%paths	714	\%paths
365	}	715	}
366		716
…		…
376	my ($a) = @_;	726	my ($a) = @_;
377		727
378	my $o = $ARCH{$a->{_name}}	728	my $o = $ARCH{$a->{_name}}
379	or return;	729	or return;
380		730
381	my $face = $FACE{$a->{face} \|\| $o->{face} \|\| "blank.111"}	731	my $face = $FACE{$a->{face} \|\| $o->{face} \|\| "blank.111"};
		732	unless ($face) {
		733	$face = $FACE{"blank.x11"}
382	or (warn "no face data found for arch '$a->{_name}'"), return;	734	or (warn "no face data found for arch '$a->{_name}'"), return;
		735	}
383		736
384	if ($face->{w} > 1 \|\| $face->{h} > 1) {	737	if ($face->{w} > 1 \|\| $face->{h} > 1) {
385	# bigface	738	# bigface
386	return (0, 0, $face->{w} - 1, $face->{h} - 1);	739	return (0, 0, $face->{w} - 1, $face->{h} - 1);
387		740
…		…
431	my $type = $obj->{type} \|\| $arch->{type};	784	my $type = $obj->{type} \|\| $arch->{type};
432		785
433	if ($type > 0) {	786	if ($type > 0) {
434	$root = $Crossfire::Data::ATTR{$type};	787	$root = $Crossfire::Data::ATTR{$type};
435	} else {	788	} else {
		789	my %a = (%$arch, %$obj);
		790
		791	if ($a{is_floor} && !$a{alive}) {
		792	$root = $Crossfire::Data::TYPE{Floor};
		793	} elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) {
		794	$root = $Crossfire::Data::TYPE{"Monster & NPC"};
		795	} elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) {
		796	$root = $Crossfire::Data::TYPE{Wall};
		797	} elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) {
		798	$root = $Crossfire::Data::TYPE{"Weak Wall"};
		799	} else {
436	$root = $Crossfire::Data::TYPE{Misc};	800	$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	}	801	}
451	}	802	}
452		803
453	my @import = ($root);	804	my @import = ($root);
454		805
…		…
457		808
458	my (%ignore);	809	my (%ignore);
459	my (@section_order, %section, @attr_order);	810	my (@section_order, %section, @attr_order);
460		811
461	while (my $type = shift @import) {	812	while (my $type = shift @import) {
		813	push @import,
		814	grep $_,
		815	map $Crossfire::Data::TYPE{$_},
462	push @import, @{$type->{import} \|\| []};	816	@{$type->{import} \|\| []};
463		817
464	$attr->{$_} \|\|= $type->{$_}	818	$attr->{$_} \|\|= $type->{$_}
465	for qw(name desc use);	819	for qw(name desc use);
466		820
467	for (@{$type->{ignore} \|\| []}) {	821	for (@{$type->{ignore} \|\| []}) {
…		…
496	];	850	];
497		851
498	$attr	852	$attr
499	}	853	}
500		854
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($$&&) {	855	sub cache_file($$&&) {
563	my ($src, $cache, $load, $create) = @_;	856	my ($src, $cache, $load, $create) = @_;
564		857
565	my ($size, $mtime) = (stat $src)[7,9]	858	my ($size, $mtime) = (stat $src)[7,9]
566	or Carp::croak "$src: $!";	859	or Carp::croak "$src: $!";
…		…
614	}, sub {	907	}, sub {
615	read_arch "$LIB/archetypes"	908	read_arch "$LIB/archetypes"
616	};	909	};
617	}	910	}
618		911
		912	sub construct_tilecache_pb {
		913	my ($idx, $cache) = @_;
		914
		915	my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, CACHESTRIDE * TILESIZE, TILESIZE * int +($idx + CACHESTRIDE - 1) / CACHESTRIDE;
		916
		917	while (my ($name, $tile) = each %$cache) {
		918	my $tpb = delete $tile->{pb};
		919	my $ofs = $tile->{idx};
		920
		921	for my $x (0 .. $tile->{w} - 1) {
		922	for my $y (0 .. $tile->{h} - 1) {
		923	my $idx = $ofs + $x + $y * $tile->{w};
		924	$tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
		925	$pb, ($idx % CACHESTRIDE) * TILESIZE, TILESIZE * int $idx / CACHESTRIDE);
		926	}
		927	}
		928	}
		929
		930	$pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
		931
		932	$cache
		933	}
		934
		935	sub use_tilecache {
		936	my ($face) = @_;
		937	$TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
		938	or die "$VARDIR/tilecache.png: $!";
		939	*FACE = $_[0];
		940	}
		941
619	=item load_tilecache	942	=item load_tilecache
620		943
621	(Re-)Load %TILE and %FACE.	944	(Re-)Load %TILE and %FACE.
622		945
623	=cut	946	=cut
624		947
625	sub load_tilecache() {	948	sub load_tilecache() {
626	require Gtk2;	949	require Gtk2;
627		950
628	cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub {	951	cache_file "$LIB/facedata", "$VARDIR/tilecache.pst", \&use_tilecache,
629	$TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
630	or die "$VARDIR/tilecache.png: $!";
631	*FACE = $_[0];
632	}, sub {	952	sub {
633	require File::Temp;
634
635	my $tile = read_pak "$LIB/crossfire.0";
636
637	my %cache;	953	my %cache;
		954	my $facedata = Storable::retrieve "$LIB/facedata";
638		955
		956	$facedata->{version} == 2
		957	or die "$LIB/facedata: version mismatch, cannot proceed.";
		958
		959	my $faces = $facedata->{faceinfo};
639	my $idx = 0;	960	my $idx = 0;
640		961
641	for my $name (sort keys %$tile) {	962	for (sort keys %$faces) {
642	my ($fh, $filename) = File::Temp::tempfile ();	963	my ($face, $info) = ($_, $faces->{$_});
643	print $fh $tile->{$name};	964
644	close $fh;
645	my $pb = new_from_file Gtk2::Gdk::Pixbuf $filename;	965	my $pb = new Gtk2::Gdk::PixbufLoader;
646	unlink $filename;	966	$pb->write ($info->{data32});
		967	$pb->close;
		968	my $pb = $pb->get_pixbuf;
647		969
648	my $tile = $cache{$name} = {	970	my $tile = $cache{$face} = {
649	pb => $pb,	971	pb => $pb,
650	idx => $idx,	972	idx => $idx,
651	w => int $pb->get_width / TILESIZE,	973	w => int $pb->get_width / TILESIZE,
652	h => int $pb->get_height / TILESIZE,	974	h => int $pb->get_height / TILESIZE,
653	};	975	};
654
655		976
656	$idx += $tile->{w} * $tile->{h};	977	$idx += $tile->{w} * $tile->{h};
		978	}
		979
		980	construct_tilecache_pb $idx, \%cache;
		981
		982	\%cache
657	}	983	};
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	}
671	}
672	}
673
674	$pb->save ("$VARDIR/tilecache.png", "png");
675
676	\%cache
677	};
678	}	984	}
679		985
680	=head1 AUTHOR	986	=head1 AUTHOR
681		987
682	Marc Lehmann <schmorp@schmorp.de>	988	Marc Lehmann <schmorp@schmorp.de>
…		…
686	http://www.ta-sa.org/	992	http://www.ta-sa.org/
687		993
688	=cut	994	=cut
689		995
690	1	996	1
		997

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.118 by root, Wed Dec 5 11:39:26 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.118 by root, Wed Dec 5 11:39:26 2007 UTC