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

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.69 by root, Thu Aug 3 10:51:26 2006 UTC vs.
Revision 1.108 by elmex, Wed May 23 20:21: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.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
…		…
76	resist_life_stealing resist_disease	83	resist_life_stealing resist_disease
77		84
78	path_attuned path_repelled path_denied material materialname	85	path_attuned path_repelled path_denied material materialname
79	value carrying weight invisible state magic	86	value carrying weight invisible state magic
80	last_heal last_sp last_grace last_eat	87	last_heal last_sp last_grace last_eat
81	connected glow_radius randomitems npx_status npc_program	88	connected glow_radius randomitems tresure_env npx_status npc_program
82	run_away pick_up container will_apply smoothlevel	89	run_away pick_up container will_apply smoothlevel
83	current_weapon_script weapontype tooltype elevation client_type	90	current_weapon_script weapontype tooltype elevation client_type
84	item_power duration range	91	item_power duration range
85	range_modifier duration_modifier dam_modifier gen_sp_armour	92	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	93	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	104	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	105	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	106	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	107	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	108	activate_on_push activate_on_release is_water use_content_on_gen is_buildable
		109	precious
102		110
103	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
104	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
105	));	113	));
106		114
…		…
123	sub MOVE_FLY_LOW (){ 0x02 }	131	sub MOVE_FLY_LOW (){ 0x02 }
124	sub MOVE_FLY_HIGH (){ 0x04 }	132	sub MOVE_FLY_HIGH (){ 0x04 }
125	sub MOVE_FLYING (){ 0x06 }	133	sub MOVE_FLYING (){ 0x06 }
126	sub MOVE_SWIM (){ 0x08 }	134	sub MOVE_SWIM (){ 0x08 }
127	sub MOVE_BOAT (){ 0x10 }	135	sub MOVE_BOAT (){ 0x10 }
		136	sub MOVE_SHIP (){ 0x20 }
128	sub MOVE_KNOWN (){ 0x1f } # all of above	137	sub MOVE_KNOWN (){ 0x3f } # all of above
129	sub MOVE_ALLBIT (){ 0x10000 }
130	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	}
131		239
132	sub load_ref($) {	240	sub load_ref($) {
133	my ($path) = @_;	241	my ($path) = @_;
134		242
135	open my $fh, "<:raw:perlio", $path	243	open my $fh, "<:raw:perlio", $path
…		…
148	close $fh;	256	close $fh;
149	rename "$path~", $path	257	rename "$path~", $path
150	or die "$path: $!";	258	or die "$path: $!";
151	}	259	}
152		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
153	# object as in "Object xxx", i.e. archetypes	329	# object as in "Object xxx", i.e. archetypes
154	sub normalize_object($) {	330	sub normalize_object($) {
155	my ($ob) = @_;	331	my ($ob) = @_;
156		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 ($js->encode ($js->decode ($ob->{attach})) eq $js->encode ($arch->{attach})) {
		358	delete $ob->{attach}
		359	}
		360	}
		361
		362	# color_fg is used as default for magicmap if magicmap does not exist
		363	$ob->{magicmap} \|\|= delete $ob->{color_fg} if exists $ob->{color_fg};
		364
157	# nuke outdated or never supported fields	365	# nuke outdated or never supported fields
158	delete $ob->{$_} for qw(	366	delete @$ob{qw(
159	can_knockback can_parry can_impale can_cut can_dam_armour	367	can_knockback can_parry can_impale can_cut can_dam_armour
160	can_apply pass_thru can_pass_thru	368	can_apply pass_thru can_pass_thru color_bg color_fg
161	);	369	)};
		370
		371	if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; }
		372	if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; }
		373	if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; }
162		374
163	# convert movement strings to bitsets	375	# convert movement strings to bitsets
164	for my $attr (keys %FIELD_MOVEMENT) {	376	for my $attr (keys %FIELD_MOVEMENT) {
165	next unless exists $ob->{$attr};	377	next unless exists $ob->{$attr};
166		378
167	$ob->{$attr} = MOVE_ALL if $ob->{$attr} == 255; #d# compatibility	379	$ob->{$attr} = new Crossfire::MoveType $ob->{$attr};
168
169	next if $ob->{$attr} =~ /^\d+$/;
170
171	my $flags = 0;
172
173	# assume list
174	for my $flag (map lc, split /\s+/, $ob->{$attr}) {
175	$flags \|= MOVE_WALK if $flag eq "walk";
176	$flags \|= MOVE_FLY_LOW if $flag eq "fly_low";
177	$flags \|= MOVE_FLY_HIGH if $flag eq "fly_high";
178	$flags \|= MOVE_FLYING if $flag eq "flying";
179	$flags \|= MOVE_SWIM if $flag eq "swim";
180	$flags \|= MOVE_BOAT if $flag eq "boat";
181	$flags \|= MOVE_ALL if $flag eq "all";
182
183	$flags &= ~MOVE_WALK if $flag eq "-walk";
184	$flags &= ~MOVE_FLY_LOW if $flag eq "-fly_low";
185	$flags &= ~MOVE_FLY_HIGH if $flag eq "-fly_high";
186	$flags &= ~MOVE_FLYING if $flag eq "-flying";
187	$flags &= ~MOVE_SWIM if $flag eq "-swim";
188	$flags &= ~MOVE_BOAT if $flag eq "-boat";
189	$flags &= ~MOVE_ALL if $flag eq "-all";
190	}
191
192	$ob->{$attr} = $flags;
193	}	380	}
194		381
195	# convert outdated movement flags to new movement sets	382	# convert outdated movement flags to new movement sets
196	if (defined (my $v = delete $ob->{no_pass})) {	383	if (defined (my $v = delete $ob->{no_pass})) {
197	$ob->{move_block} = $v ? MOVE_ALL : 0;	384	$ob->{move_block} = new Crossfire::MoveType $v ? "all" : "";
198	}	385	}
199	if (defined (my $v = delete $ob->{slow_move})) {	386	if (defined (my $v = delete $ob->{slow_move})) {
200	$ob->{move_slow} \|= MOVE_WALK;	387	$ob->{move_slow} += "walk";
201	$ob->{move_slow_penalty} = $v;	388	$ob->{move_slow_penalty} = $v;
202	}	389	}
203	if (defined (my $v = delete $ob->{walk_on})) {	390	if (defined (my $v = delete $ob->{walk_on})) {
204	$ob->{move_on} = MOVE_ALL unless exists $ob->{move_on};	391	$ob->{move_on} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" }
205	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_WALK
206	: $ob->{move_on} & ~MOVE_WALK;
207	}	392	}
208	if (defined (my $v = delete $ob->{walk_off})) {	393	if (defined (my $v = delete $ob->{walk_off})) {
209	$ob->{move_off} = MOVE_ALL unless exists $ob->{move_off};	394	$ob->{move_off} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" }
210	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_WALK
211	: $ob->{move_off} & ~MOVE_WALK;
212	}	395	}
213	if (defined (my $v = delete $ob->{fly_on})) {	396	if (defined (my $v = delete $ob->{fly_on})) {
214	$ob->{move_on} = MOVE_ALL unless exists $ob->{move_on};	397	$ob->{move_on} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "fly_low" } else { $ob->{move_on} -= "fly_low" }
215	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_FLY_LOW
216	: $ob->{move_on} & ~MOVE_FLY_LOW;
217	}	398	}
218	if (defined (my $v = delete $ob->{fly_off})) {	399	if (defined (my $v = delete $ob->{fly_off})) {
219	$ob->{move_off} = MOVE_ALL unless exists $ob->{move_off};	400	$ob->{move_off} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "fly_low" } else { $ob->{move_off} -= "fly_low" }
220	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_FLY_LOW
221	: $ob->{move_off} & ~MOVE_FLY_LOW;
222	}	401	}
223	if (defined (my $v = delete $ob->{flying})) {	402	if (defined (my $v = delete $ob->{flying})) {
224	$ob->{move_type} = MOVE_ALL unless exists $ob->{move_type};	403	$ob->{move_type} \|\|= new Crossfire::MoveType; if ($v) { $ob->{move_type} += "fly_low" } else { $ob->{move_type} -= "fly_low" }
225	$ob->{move_type} = $v ? $ob->{move_type} \| MOVE_FLY_LOW
226	: $ob->{move_type} & ~MOVE_FLY_LOW;
227	}	404	}
228		405
229	# convert idiotic event_xxx things into objects	406	# convert idiotic event_xxx things into objects
230	while (my ($event, $subtype) = each %EVENT_TYPE) {	407	while (my ($event, $subtype) = each %EVENT_TYPE) {
231	if (exists $ob->{"event_${event}_plugin"}) {	408	if (exists $ob->{"event_${event}_plugin"}) {
…		…
235	slaying => delete $ob->{"event_${event}"},	412	slaying => delete $ob->{"event_${event}"},
236	name => delete $ob->{"event_${event}_options"},	413	name => delete $ob->{"event_${event}_options"},
237	};	414	};
238	}	415	}
239	}	416	}
		417
		418	# some archetypes had "+3" instead of the canonical "3", so fix
		419	$ob->{dam} *= 1 if exists $ob->{dam};
240		420
241	$ob	421	$ob
242	}	422	}
243		423
244	# arch as in "arch xxx", ie.. objects	424	# arch as in "arch xxx", ie.. objects
…		…
286	}	466	}
287		467
288	$ob	468	$ob
289	}	469	}
290		470
		471	sub attr_thaw($) {
		472	my ($ob) = @_;
		473
		474	$ob->{attach} = from_json $ob->{attach}
		475	if exists $ob->{attach};
		476
		477	$ob
		478	}
		479
		480	sub attr_freeze($) {
		481	my ($ob) = @_;
		482
		483	$ob->{attach} = Crossfire::to_json $ob->{attach}
		484	if exists $ob->{attach};
		485
		486	$ob
		487	}
		488
291	sub read_pak($) {	489	sub read_pak($) {
292	my ($path) = @_;	490	my ($path) = @_;
293		491
294	my %pak;	492	my %pak;
295		493
…		…
308	sub read_arch($;$) {	506	sub read_arch($;$) {
309	my ($path, $toplevel) = @_;	507	my ($path, $toplevel) = @_;
310		508
311	my %arc;	509	my %arc;
312	my ($more, $prev);	510	my ($more, $prev);
		511	my $comment;
313		512
314	open my $fh, "<:raw:perlio:utf8", $path	513	open my $fh, "<:raw:perlio:utf8", $path
315	or Carp::croak "$path: $!";	514	or Carp::croak "$path: $!";
316		515
317	# binmode $fh;	516	# binmode $fh;
…		…
321		520
322	while (<$fh>) {	521	while (<$fh>) {
323	s/\s+$//;	522	s/\s+$//;
324	if (/^end$/i) {	523	if (/^end$/i) {
325	last;	524	last;
		525
326	} elsif (/^arch (\S+)$/i) {	526	} elsif (/^arch (\S+)$/i) {
327	push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1);	527	push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
		528
328	} elsif (/^lore$/i) {	529	} elsif (/^lore$/i) {
329	while (<$fh>) {	530	while (<$fh>) {
330	last if /^endlore\s*$/i;	531	last if /^endlore\s*$/i;
331	$arc{lore} .= $_;	532	$arc{lore} .= $_;
332	}	533	}
…		…
341	chomp;	542	chomp;
342	push @{ $arc{anim} }, $_;	543	push @{ $arc{anim} }, $_;
343	}	544	}
344	} elsif (/^(\S+)\s(.)$/) {	545	} elsif (/^(\S+)\s(.)$/) {
345	$arc{lc $1} = $2;	546	$arc{lc $1} = $2;
346	} elsif (/^\s*($\|#)/) {	547	} elsif (/^\s*#/) {
		548	$arc{_comment} .= "$_\n";
		549
		550	} elsif (/^\s*$/) {
347	#	551	#
348	} else {	552	} else {
349	warn "$path: unparsable line '$_' in arch $arc{_name}";	553	warn "$path: unparsable line '$_' in arch $arc{_name}";
350	}	554	}
351	}	555	}
…		…
357	s/\s+$//;	561	s/\s+$//;
358	if (/^more$/i) {	562	if (/^more$/i) {
359	$more = $prev;	563	$more = $prev;
360	} elsif (/^object (\S+)$/i) {	564	} elsif (/^object (\S+)$/i) {
361	my $name = $1;	565	my $name = $1;
362	my $arc = normalize_object $parse_block->(_name => $name);	566	my $arc = attr_thaw normalize_object $parse_block->(_name => $name, _comment => $comment);
		567	undef $comment;
		568	delete $arc{_comment} unless length $arc{_comment};
		569	$arc->{_atype} = 'object';
363		570
364	if ($more) {	571	if ($more) {
365	$more->{more} = $arc;	572	$more->{more} = $arc;
366	} else {	573	} else {
367	$arc{$name} = $arc;	574	$arc{$name} = $arc;
368	}	575	}
369	$prev = $arc;	576	$prev = $arc;
370	$more = undef;	577	$more = undef;
371	} elsif (/^arch (\S+)$/i) {	578	} elsif (/^arch (\S+)$/i) {
372	my $name = $1;	579	my $name = $1;
373	my $arc = normalize_arch $parse_block->(_name => $name);	580	my $arc = attr_thaw normalize_arch $parse_block->(_name => $name, _comment => $comment);
		581	undef $comment;
		582	delete $arc{_comment} unless length $arc{_comment};
		583	$arc->{_atype} = 'arch';
374		584
375	if ($more) {	585	if ($more) {
376	$more->{more} = $arc;	586	$more->{more} = $arc;
377	} else {	587	} else {
378	push @{ $arc{arch} }, $arc;	588	push @{ $arc{arch} }, $arc;
…		…
386	push @{$toplevel->{lev_array}}, $_+0;	596	push @{$toplevel->{lev_array}}, $_+0;
387	}	597	}
388	} else {	598	} else {
389	$toplevel->{$1} = $2;	599	$toplevel->{$1} = $2;
390	}	600	}
		601	} elsif (/^\s*#/) {
		602	$comment .= "$_\n";
391	} elsif (/^\s*($\|#)/) {	603	} elsif (/^\s*($\|#)/) {
392	#	604	#
393	} else {	605	} else {
394	die "$path: unparseable top-level line '$_'";	606	die "$path: unparseable top-level line '$_'";
395	}	607	}
396	}	608	}
397		609
398	undef $parse_block; # work around bug in perl not freeing $fh etc.	610	undef $parse_block; # work around bug in perl not freeing $fh etc.
399		611
400	\%arc	612	\%arc
		613	}
		614
		615	sub archlist_to_string {
		616	my ($arch) = @_;
		617
		618	my $str;
		619
		620	my $append; $append = sub {
		621	my %a = %{$_[0]};
		622
		623	Crossfire::attr_freeze \%a;
		624	Crossfire::normalize_arch \%a;
		625
		626	# undo the bit-split we did before
		627	if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) {
		628	$a{attack_movement} = (delete $a{attack_movement_bits_0_3})
		629	\| (delete $a{attack_movement_bits_4_7});
		630	}
		631
		632	if (my $comment = delete $a{_comment}) {
		633	if ($comment =~ /[^\n\s#]/) {
		634	$str .= $comment;
		635	}
		636	}
		637
		638	$str .= ((exists $a{_atype}) ? $a{_atype} : 'arch'). " $a{_name}\n";
		639
		640	my $inv = delete $a{inventory};
		641	my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some
		642	my $anim = delete $a{anim};
		643
		644	if ($a{_atype} eq 'object') {
		645	$str .= join "\n", "anim", @$anim, "mina\n"
		646	if $anim;
		647	}
		648
		649	my @kv;
		650
		651	for ($a{_name} eq "map"
		652	? @Crossfire::FIELD_ORDER_MAP
		653	: @Crossfire::FIELD_ORDER) {
		654	push @kv, [$_, delete $a{$_}]
		655	if exists $a{$_};
		656	}
		657
		658	for (sort keys %a) {
		659	next if /^_/; # ignore our _-keys
		660	push @kv, [$_, delete $a{$_}];
		661	}
		662
		663	for (@kv) {
		664	my ($k, $v) = @$_;
		665
		666	if (my $end = $Crossfire::FIELD_MULTILINE{$k}) {
		667	$v =~ s/\n$//;
		668	$str .= "$k\n$v\n$end\n";
		669	} else {
		670	$str .= "$k $v\n";
		671	}
		672	}
		673
		674	if ($inv) {
		675	$append->($_) for @$inv;
		676	}
		677
		678	$str .= "end\n";
		679
		680	if ($a{_atype} eq 'object') {
		681	if ($more) {
		682	$str .= "more\n";
		683	$append->($more) if $more;
		684	} else {
		685	$str .= "\n";
		686	}
		687	}
		688	};
		689
		690	for (@$arch) {
		691	$append->($_);
		692	}
		693
		694	$str
401	}	695	}
402		696
403	# put all archs into a hash with editor_face as it's key	697	# put all archs into a hash with editor_face as it's key
404	# NOTE: the arrays in the hash values are references to	698	# NOTE: the arrays in the hash values are references to
405	# the archs from $ARCH	699	# the archs from $ARCH
…		…
426	my ($a) = @_;	720	my ($a) = @_;
427		721
428	my $o = $ARCH{$a->{_name}}	722	my $o = $ARCH{$a->{_name}}
429	or return;	723	or return;
430		724
431	my $face = $FACE{$a->{face} \|\| $o->{face} \|\| "blank.111"}	725	my $face = $FACE{$a->{face} \|\| $o->{face} \|\| "blank.111"};
		726	unless ($face) {
		727	$face = $FACE{"blank.x11"}
432	or (warn "no face data found for arch '$a->{_name}'"), return;	728	or (warn "no face data found for arch '$a->{_name}'"), return;
		729	}
433		730
434	if ($face->{w} > 1 \|\| $face->{h} > 1) {	731	if ($face->{w} > 1 \|\| $face->{h} > 1) {
435	# bigface	732	# bigface
436	return (0, 0, $face->{w} - 1, $face->{h} - 1);	733	return (0, 0, $face->{w} - 1, $face->{h} - 1);
437		734
…		…
544	];	841	];
545		842
546	$attr	843	$attr
547	}	844	}
548		845
549	sub arch_edit_sections {
550	# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
551	# edit_type = 0;
552	# else if (edit_type != 0) {
553	# // all flags from 'check_type' must be unset in this arch because they get recalculated now
554	# edit_type &= ~check_type;
555	# }
556	#
557	# }
558	# if ((check_type & IGUIConstants.TILE_EDIT_MONSTER) != 0 &&
559	# getAttributeValue("alive", defarch) == 1 &&
560	# (getAttributeValue("monster", defarch) == 1 \|\|
561	# getAttributeValue("generator", defarch) == 1)) {
562	# // Monster: monsters/npcs/generators
563	# edit_type \|= IGUIConstants.TILE_EDIT_MONSTER;
564	# }
565	# if ((check_type & IGUIConstants.TILE_EDIT_WALL) != 0 &&
566	# arch_type == 0 && getAttributeValue("no_pass", defarch) == 1) {
567	# // Walls
568	# edit_type \|= IGUIConstants.TILE_EDIT_WALL;
569	# }
570	# if ((check_type & IGUIConstants.TILE_EDIT_CONNECTED) != 0 &&
571	# getAttributeValue("connected", defarch) != 0) {
572	# // Connected Objects
573	# edit_type \|= IGUIConstants.TILE_EDIT_CONNECTED;
574	# }
575	# if ((check_type & IGUIConstants.TILE_EDIT_EXIT) != 0 &&
576	# arch_type == 66 \|\| arch_type == 41 \|\| arch_type == 95) {
577	# // Exit: teleporter/exit/trapdoors
578	# edit_type \|= IGUIConstants.TILE_EDIT_EXIT;
579	# }
580	# if ((check_type & IGUIConstants.TILE_EDIT_TREASURE) != 0 &&
581	# getAttributeValue("no_pick", defarch) == 0 && (arch_type == 4 \|\|
582	# arch_type == 5 \|\| arch_type == 36 \|\| arch_type == 60 \|\|
583	# arch_type == 85 \|\| arch_type == 111 \|\| arch_type == 123 \|\|
584	# arch_type == 124 \|\| arch_type == 130)) {
585	# // Treasure: randomtreasure/money/gems/potions/spellbooks/scrolls
586	# edit_type \|= IGUIConstants.TILE_EDIT_TREASURE;
587	# }
588	# if ((check_type & IGUIConstants.TILE_EDIT_DOOR) != 0 &&
589	# arch_type == 20 \|\| arch_type == 23 \|\| arch_type == 26 \|\|
590	# arch_type == 91 \|\| arch_type == 21 \|\| arch_type == 24) {
591	# // Door: door/special door/gates + keys
592	# edit_type \|= IGUIConstants.TILE_EDIT_DOOR;
593	# }
594	# if ((check_type & IGUIConstants.TILE_EDIT_EQUIP) != 0 &&
595	# getAttributeValue("no_pick", defarch) == 0 && ((arch_type >= 13 &&
596	# arch_type <= 16) \|\| arch_type == 33 \|\| arch_type == 34 \|\|
597	# arch_type == 35 \|\| arch_type == 39 \|\| arch_type == 70 \|\|
598	# arch_type == 87 \|\| arch_type == 99 \|\| arch_type == 100 \|\|
599	# arch_type == 104 \|\| arch_type == 109 \|\| arch_type == 113 \|\|
600	# arch_type == 122 \|\| arch_type == 3)) {
601	# // Equipment: weapons/armour/wands/rods
602	# edit_type \|= IGUIConstants.TILE_EDIT_EQUIP;
603	# }
604	#
605	# return(edit_type);
606	#
607	#
608	}
609
610	sub cache_file($$&&) {	846	sub cache_file($$&&) {
611	my ($src, $cache, $load, $create) = @_;	847	my ($src, $cache, $load, $create) = @_;
612		848
613	my ($size, $mtime) = (stat $src)[7,9]	849	my ($size, $mtime) = (stat $src)[7,9]
614	or Carp::croak "$src: $!";	850	or Carp::croak "$src: $!";
…		…
662	}, sub {	898	}, sub {
663	read_arch "$LIB/archetypes"	899	read_arch "$LIB/archetypes"
664	};	900	};
665	}	901	}
666		902
		903	sub construct_tilecache_pb {
		904	my ($idx, $cache) = @_;
		905
		906	my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
		907
		908	while (my ($name, $tile) = each %$cache) {
		909	my $tpb = delete $tile->{pb};
		910	my $ofs = $tile->{idx};
		911
		912	for my $x (0 .. $tile->{w} - 1) {
		913	for my $y (0 .. $tile->{h} - 1) {
		914	my $idx = $ofs + $x + $y * $tile->{w};
		915	$tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
		916	$pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
		917	}
		918	}
		919	}
		920
		921	$pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
		922
		923	$cache
		924	}
		925
		926	sub use_tilecache {
		927	my ($face) = @_;
		928	$TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
		929	or die "$VARDIR/tilecache.png: $!";
		930	*FACE = $_[0];
		931	}
		932
667	=item load_tilecache	933	=item load_tilecache
668		934
669	(Re-)Load %TILE and %FACE.	935	(Re-)Load %TILE and %FACE.
670		936
671	=cut	937	=cut
672		938
673	sub load_tilecache() {	939	sub load_tilecache() {
674	require Gtk2;	940	require Gtk2;
675		941
		942	if (-e "$LIB/crossfire.0") { # Crossfire1 version
676	cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub {	943	cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", \&use_tilecache,
677	$TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"	944	sub {
678	or die "$VARDIR/tilecache.png: $!";
679	*FACE = $_[0];
680	}, sub {
681	my $tile = read_pak "$LIB/crossfire.0";	945	my $tile = read_pak "$LIB/crossfire.0";
682		946
683	my %cache;	947	my %cache;
684		948
685	my $idx = 0;	949	my $idx = 0;
686		950
687	for my $name (sort keys %$tile) {	951	for my $name (sort keys %$tile) {
688	my $pb = new Gtk2::Gdk::PixbufLoader;	952	my $pb = new Gtk2::Gdk::PixbufLoader;
689	$pb->write ($tile->{$name});	953	$pb->write ($tile->{$name});
690	$pb->close;	954	$pb->close;
691	my $pb = $pb->get_pixbuf;	955	my $pb = $pb->get_pixbuf;
692		956
693	my $tile = $cache{$name} = {	957	my $tile = $cache{$name} = {
694	pb => $pb,	958	pb => $pb,
695	idx => $idx,	959	idx => $idx,
696	w => int $pb->get_width / TILESIZE,	960	w => int $pb->get_width / TILESIZE,
697	h => int $pb->get_height / TILESIZE,	961	h => int $pb->get_height / TILESIZE,
		962	};
		963
		964	$idx += $tile->{w} * $tile->{h};
		965	}
		966
		967	construct_tilecache_pb $idx, \%cache;
		968
		969	\%cache
698	};	970	};
		971
		972	} else { # Crossfire+ version
		973	cache_file "$LIB/facedata", "$VARDIR/tilecache.pst", \&use_tilecache,
		974	sub {
		975	my %cache;
		976	my $facedata = Storable::retrieve "$LIB/facedata";
		977
		978	$facedata->{version} == 2
		979	or die "$LIB/facedata: version mismatch, cannot proceed.";
		980
		981	my $faces = $facedata->{faceinfo};
		982	my $idx = 0;
		983
		984	for (sort keys %$faces) {
		985	my ($face, $info) = ($_, $faces->{$_});
		986
		987	my $pb = new Gtk2::Gdk::PixbufLoader;
		988	$pb->write ($info->{data32});
		989	$pb->close;
		990	my $pb = $pb->get_pixbuf;
		991
		992	my $tile = $cache{$face} = {
		993	pb => $pb,
		994	idx => $idx,
		995	w => int $pb->get_width / TILESIZE,
		996	h => int $pb->get_height / TILESIZE,
699		997	};
700		998
701	$idx += $tile->{w} * $tile->{h};	999	$idx += $tile->{w} * $tile->{h};
702	}
703
704	my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
705
706	while (my ($name, $tile) = each %cache) {
707	my $tpb = delete $tile->{pb};
708	my $ofs = $tile->{idx};
709
710	for my $x (0 .. $tile->{w} - 1) {
711	for my $y (0 .. $tile->{h} - 1) {
712	my $idx = $ofs + $x + $y * $tile->{w};
713	$tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
714	$pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
715	}	1000	}
		1001
		1002	construct_tilecache_pb $idx, \%cache;
		1003
		1004	\%cache
716	}	1005	};
717	}
718
719	$pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
720
721	\%cache
722	};	1006	}
723	}	1007	}
724		1008
725	=head1 AUTHOR	1009	=head1 AUTHOR
726		1010
727	Marc Lehmann <schmorp@schmorp.de>	1011	Marc Lehmann <schmorp@schmorp.de>

Diff Legend

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

Comparing deliantra/Deliantra/Deliantra.pm (file contents): Revision 1.69 by root, Thu Aug 3 10:51:26 2006 UTC vs. Revision 1.108 by elmex, Wed May 23 20:21:28 2007 UTC

Diff Legend

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.69 by root, Thu Aug 3 10:51:26 2006 UTC vs.
Revision 1.108 by elmex, Wed May 23 20:21:28 2007 UTC