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

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.68 by elmex, Sun Jul 30 17:29:29 2006 UTC vs.
Revision 1.111 by elmex, Thu Jun 7 14:45:22 2007 UTC

…		…
4		4
5	=cut	5	=cut
6		6
7	package Crossfire;	7	package Crossfire;
8		8
9	our $VERSION = '0.8';	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::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 (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
157	# nuke outdated or never supported fields	366	# nuke outdated or never supported fields
158	delete $ob->{$_} for qw(	367	delete @$ob{qw(
159	can_knockback can_parry can_impale can_cut can_dam_armour	368	can_knockback can_parry can_impale can_cut can_dam_armour
160	can_apply pass_thru can_pass_thru	369	can_apply pass_thru can_pass_thru color_bg color_fg
161	);	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; }
162		375
163	# convert movement strings to bitsets	376	# convert movement strings to bitsets
164	for my $attr (keys %FIELD_MOVEMENT) {	377	for my $attr (keys %FIELD_MOVEMENT) {
165	next unless exists $ob->{$attr};	378	next unless exists $ob->{$attr};
166		379
167	$ob->{$attr} = MOVE_ALL if $ob->{$attr} == 255; #d# compatibility	380	$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	}	381	}
194		382
195	# convert outdated movement flags to new movement sets	383	# convert outdated movement flags to new movement sets
196	if (defined (my $v = delete $ob->{no_pass})) {	384	if (defined (my $v = delete $ob->{no_pass})) {
197	$ob->{move_block} = $v ? MOVE_ALL : 0;	385	$ob->{move_block} = new Crossfire::MoveType $v ? "all" : "";
198	}	386	}
199	if (defined (my $v = delete $ob->{slow_move})) {	387	if (defined (my $v = delete $ob->{slow_move})) {
200	$ob->{move_slow} \|= MOVE_WALK;	388	$ob->{move_slow} += "walk";
201	$ob->{move_slow_penalty} = $v;	389	$ob->{move_slow_penalty} = $v;
202	}	390	}
203	if (defined (my $v = delete $ob->{walk_on})) {	391	if (defined (my $v = delete $ob->{walk_on})) {
204	$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" }
205	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_WALK
206	: $ob->{move_on} & ~MOVE_WALK;
207	}	393	}
208	if (defined (my $v = delete $ob->{walk_off})) {	394	if (defined (my $v = delete $ob->{walk_off})) {
209	$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" }
210	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_WALK
211	: $ob->{move_off} & ~MOVE_WALK;
212	}	396	}
213	if (defined (my $v = delete $ob->{fly_on})) {	397	if (defined (my $v = delete $ob->{fly_on})) {
214	$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" }
215	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_FLY_LOW
216	: $ob->{move_on} & ~MOVE_FLY_LOW;
217	}	399	}
218	if (defined (my $v = delete $ob->{fly_off})) {	400	if (defined (my $v = delete $ob->{fly_off})) {
219	$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" }
220	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_FLY_LOW
221	: $ob->{move_off} & ~MOVE_FLY_LOW;
222	}	402	}
223	if (defined (my $v = delete $ob->{flying})) {	403	if (defined (my $v = delete $ob->{flying})) {
224	$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" }
225	$ob->{move_type} = $v ? $ob->{move_type} \| MOVE_FLY_LOW
226	: $ob->{move_type} & ~MOVE_FLY_LOW;
227	}	405	}
228		406
229	# convert idiotic event_xxx things into objects	407	# convert idiotic event_xxx things into objects
230	while (my ($event, $subtype) = each %EVENT_TYPE) {	408	while (my ($event, $subtype) = each %EVENT_TYPE) {
231	if (exists $ob->{"event_${event}_plugin"}) {	409	if (exists $ob->{"event_${event}_plugin"}) {
…		…
235	slaying => delete $ob->{"event_${event}"},	413	slaying => delete $ob->{"event_${event}"},
236	name => delete $ob->{"event_${event}_options"},	414	name => delete $ob->{"event_${event}_options"},
237	};	415	};
238	}	416	}
239	}	417	}
		418
		419	# some archetypes had "+3" instead of the canonical "3", so fix
		420	$ob->{dam} *= 1 if exists $ob->{dam};
240		421
241	$ob	422	$ob
242	}	423	}
243		424
244	# arch as in "arch xxx", ie.. objects	425	# arch as in "arch xxx", ie.. objects
…		…
286	}	467	}
287		468
288	$ob	469	$ob
289	}	470	}
290		471
		472	sub attr_thaw($) {
		473	my ($ob) = @_;
		474
		475	$ob->{attach} = from_json $ob->{attach}
		476	if exists $ob->{attach};
		477
		478	$ob
		479	}
		480
		481	sub attr_freeze($) {
		482	my ($ob) = @_;
		483
		484	$ob->{attach} = Crossfire::to_json $ob->{attach}
		485	if exists $ob->{attach};
		486
		487	$ob
		488	}
		489
291	sub read_pak($) {	490	sub read_pak($) {
292	my ($path) = @_;	491	my ($path) = @_;
293		492
294	my %pak;	493	my %pak;
295		494
…		…
308	sub read_arch($;$) {	507	sub read_arch($;$) {
309	my ($path, $toplevel) = @_;	508	my ($path, $toplevel) = @_;
310		509
311	my %arc;	510	my %arc;
312	my ($more, $prev);	511	my ($more, $prev);
		512	my $comment;
313		513
314	open my $fh, "<:raw:perlio:utf8", $path	514	open my $fh, "<:raw:perlio:utf8", $path
315	or Carp::croak "$path: $!";	515	or Carp::croak "$path: $!";
316		516
317	# binmode $fh;	517	# binmode $fh;
…		…
321		521
322	while (<$fh>) {	522	while (<$fh>) {
323	s/\s+$//;	523	s/\s+$//;
324	if (/^end$/i) {	524	if (/^end$/i) {
325	last;	525	last;
		526
326	} elsif (/^arch (\S+)$/i) {	527	} elsif (/^arch (\S+)$/i) {
327	push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1);	528	push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
		529
328	} elsif (/^lore$/i) {	530	} elsif (/^lore$/i) {
329	while (<$fh>) {	531	while (<$fh>) {
330	last if /^endlore\s*$/i;	532	last if /^endlore\s*$/i;
331	$arc{lore} .= $_;	533	$arc{lore} .= $_;
332	}	534	}
…		…
341	chomp;	543	chomp;
342	push @{ $arc{anim} }, $_;	544	push @{ $arc{anim} }, $_;
343	}	545	}
344	} elsif (/^(\S+)\s(.)$/) {	546	} elsif (/^(\S+)\s(.)$/) {
345	$arc{lc $1} = $2;	547	$arc{lc $1} = $2;
346	} elsif (/^\s*($\|#)/) {	548	} elsif (/^\s*#/) {
		549	$arc{_comment} .= "$_\n";
		550
		551	} elsif (/^\s*$/) {
347	#	552	#
348	} else {	553	} else {
349	warn "$path: unparsable line '$_' in arch $arc{_name}";	554	warn "$path: unparsable line '$_' in arch $arc{_name}";
350	}	555	}
351	}	556	}
…		…
357	s/\s+$//;	562	s/\s+$//;
358	if (/^more$/i) {	563	if (/^more$/i) {
359	$more = $prev;	564	$more = $prev;
360	} elsif (/^object (\S+)$/i) {	565	} elsif (/^object (\S+)$/i) {
361	my $name = $1;	566	my $name = $1;
362	my $arc = 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';
363		571
364	if ($more) {	572	if ($more) {
365	$more->{more} = $arc;	573	$more->{more} = $arc;
366	} else {	574	} else {
367	$arc{$name} = $arc;	575	$arc{$name} = $arc;
368	}	576	}
369	$prev = $arc;	577	$prev = $arc;
370	$more = undef;	578	$more = undef;
371	} elsif (/^arch (\S+)$/i) {	579	} elsif (/^arch (\S+)$/i) {
372	my $name = $1;	580	my $name = $1;
373	my $arc = 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';
374		585
375	if ($more) {	586	if ($more) {
376	$more->{more} = $arc;	587	$more->{more} = $arc;
377	} else {	588	} else {
378	push @{ $arc{arch} }, $arc;	589	push @{ $arc{arch} }, $arc;
…		…
386	push @{$toplevel->{lev_array}}, $_+0;	597	push @{$toplevel->{lev_array}}, $_+0;
387	}	598	}
388	} else {	599	} else {
389	$toplevel->{$1} = $2;	600	$toplevel->{$1} = $2;
390	}	601	}
		602	} elsif (/^\s*#/) {
		603	$comment .= "$_\n";
391	} elsif (/^\s*($\|#)/) {	604	} elsif (/^\s*($\|#)/) {
392	#	605	#
393	} else {	606	} else {
394	die "$path: unparseable top-level line '$_'";	607	die "$path: unparseable top-level line '$_'";
395	}	608	}
396	}	609	}
397		610
398	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.
399		612
400	\%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
401	}	696	}
402		697
403	# 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
404	# NOTE: the arrays in the hash values are references to	699	# NOTE: the arrays in the hash values are references to
405	# the archs from $ARCH	700	# the archs from $ARCH
…		…
426	my ($a) = @_;	721	my ($a) = @_;
427		722
428	my $o = $ARCH{$a->{_name}}	723	my $o = $ARCH{$a->{_name}}
429	or return;	724	or return;
430		725
431	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"}
432	or (warn "no face data found for arch '$a->{_name}'"), return;	729	or (warn "no face data found for arch '$a->{_name}'"), return;
		730	}
433		731
434	if ($face->{w} > 1 \|\| $face->{h} > 1) {	732	if ($face->{w} > 1 \|\| $face->{h} > 1) {
435	# bigface	733	# bigface
436	return (0, 0, $face->{w} - 1, $face->{h} - 1);	734	return (0, 0, $face->{w} - 1, $face->{h} - 1);
437		735
…		…
544	];	842	];
545		843
546	$attr	844	$attr
547	}	845	}
548		846
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($$&&) {	847	sub cache_file($$&&) {
611	my ($src, $cache, $load, $create) = @_;	848	my ($src, $cache, $load, $create) = @_;
612		849
613	my ($size, $mtime) = (stat $src)[7,9]	850	my ($size, $mtime) = (stat $src)[7,9]
614	or Carp::croak "$src: $!";	851	or Carp::croak "$src: $!";
…		…
662	}, sub {	899	}, sub {
663	read_arch "$LIB/archetypes"	900	read_arch "$LIB/archetypes"
664	};	901	};
665	}	902	}
666		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
667	=item load_tilecache	934	=item load_tilecache
668		935
669	(Re-)Load %TILE and %FACE.	936	(Re-)Load %TILE and %FACE.
670		937
671	=cut	938	=cut
672		939
673	sub load_tilecache() {	940	sub load_tilecache() {
674	require Gtk2;	941	require Gtk2;
675		942
676	cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub {	943	if (-e "$LIB/facedata") { # Crossfire TRT faces
677	$TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"	944	cache_file "$LIB/facedata", "$VARDIR/tilecache.pst", \&use_tilecache,
678	or die "$VARDIR/tilecache.png: $!";	945	sub {
679	*FACE = $_[0];
680	}, sub {
681	my $tile = read_pak "$LIB/crossfire.0";
682
683	my %cache;	946	my %cache;
		947	my $facedata = Storable::retrieve "$LIB/facedata";
684		948
		949	$facedata->{version} == 2
		950	or die "$LIB/facedata: version mismatch, cannot proceed.";
		951
		952	my $faces = $facedata->{faceinfo};
685	my $idx = 0;	953	my $idx = 0;
686		954
687	for my $name (sort keys %$tile) {	955	for (sort keys %$faces) {
		956	my ($face, $info) = ($_, $faces->{$_});
		957
688	my $pb = new Gtk2::Gdk::PixbufLoader;	958	my $pb = new Gtk2::Gdk::PixbufLoader;
689	$pb->write ($tile->{$name});	959	$pb->write ($info->{data32});
690	$pb->close;	960	$pb->close;
691	my $pb = $pb->get_pixbuf;	961	my $pb = $pb->get_pixbuf;
692		962
693	my $tile = $cache{$name} = {	963	my $tile = $cache{$face} = {
694	pb => $pb,	964	pb => $pb,
695	idx => $idx,	965	idx => $idx,
696	w => int $pb->get_width / TILESIZE,	966	w => int $pb->get_width / TILESIZE,
697	h => int $pb->get_height / TILESIZE,	967	h => int $pb->get_height / TILESIZE,
		968	};
		969
		970	$idx += $tile->{w} * $tile->{h};
		971	}
		972
		973	construct_tilecache_pb $idx, \%cache;
		974
		975	\%cache
698	};	976	};
		977
		978	} elsif (-e "$LIB/crossfire.0") { # Crossfire1 version
		979	cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", \&use_tilecache,
		980	sub {
		981	my $tile = read_pak "$LIB/crossfire.0";
		982
		983	my %cache;
		984
		985	my $idx = 0;
		986
		987	for my $name (sort keys %$tile) {
		988	my $pb = new Gtk2::Gdk::PixbufLoader;
		989	$pb->write ($tile->{$name});
		990	$pb->close;
		991	my $pb = $pb->get_pixbuf;
		992
		993	my $tile = $cache{$name} = {
		994	pb => $pb,
		995	idx => $idx,
		996	w => int $pb->get_width / TILESIZE,
		997	h => int $pb->get_height / TILESIZE,
699		998	};
700		999
701	$idx += $tile->{w} * $tile->{h};	1000	$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	}	1001	}
		1002
		1003	construct_tilecache_pb $idx, \%cache;
		1004
		1005	\%cache
716	}	1006	};
717	}
718		1007
719	$pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
720
721	\%cache
722	};	1008	}
723	}	1009	}
724		1010
725	=head1 AUTHOR	1011	=head1 AUTHOR
726		1012
727	Marc Lehmann <schmorp@schmorp.de>	1013	Marc Lehmann <schmorp@schmorp.de>

Diff Legend

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

Comparing deliantra/Deliantra/Deliantra.pm (file contents): Revision 1.68 by elmex, Sun Jul 30 17:29:29 2006 UTC vs. Revision 1.111 by elmex, Thu Jun 7 14:45:22 2007 UTC

Diff Legend

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.68 by elmex, Sun Jul 30 17:29:29 2006 UTC vs.
Revision 1.111 by elmex, Thu Jun 7 14:45:22 2007 UTC