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

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.54 by root, Thu Mar 23 06:45:23 2006 UTC vs.
Revision 1.116 by root, Thu Nov 8 01:21:54 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.11';
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(from_json to_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",
39	maplore => "endmaplore",	48	maplore => "endmaplore",
40	);	49	);
41		50
		51	# movement bit type, PITA
		52	our %FIELD_MOVEMENT = map +($_ => undef),
		53	qw(move_type move_block move_allow move_on move_off move_slow);
		54
42	# same as in server save routine, to (hopefully) be compatible	55	# same as in server save routine, to (hopefully) be compatible
43	# to the other editors.	56	# to the other editors.
		57	our @FIELD_ORDER_MAP = (qw(
		58	file_format_version
		59	name attach swap_time reset_timeout fixed_resettime difficulty region
		60	shopitems shopgreed shopmin shopmax shoprace
		61	darkness width height enter_x enter_y msg maplore
		62	unique template
		63	outdoor temp pressure humid windspeed winddir sky nosmooth
		64	tile_path_1 tile_path_2 tile_path_3 tile_path_4
		65	));
		66
44	our @FIELD_ORDER = (qw(	67	our @FIELD_ORDER = (qw(
		68	inherit
		69
		70	elevation
		71
45	name name_pl custom_name title race	72	name name_pl custom_name attach title race
46	slaying skill msg lore other_arch face	73	slaying skill msg lore other_arch
47	#events
48	animation is_animated	74	face animation is_animated
		75	magicmap smoothlevel smoothface
49	Str Dex Con Wis Pow Cha Int	76	str dex con wis pow cha int
50	hp maxhp sp maxsp grace maxgrace	77	hp maxhp sp maxsp grace maxgrace
51	exp perm_exp expmul	78	exp perm_exp expmul
52	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
53	nrof level direction type subtype	80	nrof level direction type subtype attacktype
54		81
55	resist_physical resist_magic resist_fire resist_electricity	82	resist_physical resist_magic resist_fire resist_electricity
56	resist_cold resist_confusion resist_acid resist_drain	83	resist_cold resist_confusion resist_acid resist_drain
57	resist_weaponmagic resist_ghosthit resist_poison resist_slow	84	resist_weaponmagic resist_ghosthit resist_poison resist_slow
58	resist_paralyze resist_turn_undead resist_fear resist_cancellation	85	resist_paralyze resist_turn_undead resist_fear resist_cancellation
…		…
61	resist_life_stealing resist_disease	88	resist_life_stealing resist_disease
62		89
63	path_attuned path_repelled path_denied material materialname	90	path_attuned path_repelled path_denied material materialname
64	value carrying weight invisible state magic	91	value carrying weight invisible state magic
65	last_heal last_sp last_grace last_eat	92	last_heal last_sp last_grace last_eat
66	connected glow_radius randomitems npx_status npc_program	93	connected glow_radius randomitems tresure_env npx_status npc_program
67	run_away pick_up container will_apply smoothlevel	94	run_away pick_up container will_apply smoothlevel
68	current_weapon_script weapontype tooltype elevation client_type	95	current_weapon_script weapontype tooltype elevation client_type
69	item_power duration range	96	item_power duration range
70	range_modifier duration_modifier dam_modifier gen_sp_armour	97	range_modifier duration_modifier dam_modifier gen_sp_armour
71	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
…		…
82	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
83	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
84	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
85	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
86	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
87		115
88	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
89	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
90	));	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	);
91		134
92	sub MOVE_WALK (){ 0x01 }	135	sub MOVE_WALK (){ 0x01 }
93	sub MOVE_FLY_LOW (){ 0x02 }	136	sub MOVE_FLY_LOW (){ 0x02 }
94	sub MOVE_FLY_HIGH (){ 0x04 }	137	sub MOVE_FLY_HIGH (){ 0x04 }
95	sub MOVE_FLYING (){ 0x06 }	138	sub MOVE_FLYING (){ 0x06 }
96	sub MOVE_SWIM (){ 0x08 }	139	sub MOVE_SWIM (){ 0x08 }
97	sub MOVE_BOAT (){ 0x10 }	140	sub MOVE_BOAT (){ 0x10 }
98	sub MOVE_ALL (){ 0xff }	141	sub MOVE_SHIP (){ 0x20 }
		142	sub MOVE_KNOWN (){ 0x3f } # all of above
		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	}
99		244
100	sub load_ref($) {	245	sub load_ref($) {
101	my ($path) = @_;	246	my ($path) = @_;
102		247
103	open my $fh, "<", $path	248	open my $fh, "<:raw:perlio", $path
104	or die "$path: $!";	249	or die "$path: $!";
105	binmode $fh;
106	local $/;	250	local $/;
107		251
108	thaw <$fh>	252	thaw <$fh>
109	}	253	}
110		254
111	sub save_ref($$) {	255	sub save_ref($$) {
112	my ($ref, $path) = @_;	256	my ($ref, $path) = @_;
113		257
114	open my $fh, ">", "$path~"	258	open my $fh, ">:raw:perlio", "$path~"
115	or die "$path~: $!";	259	or die "$path~: $!";
116	binmode $fh;
117	print $fh freeze $ref;	260	print $fh freeze $ref;
118	close $fh;	261	close $fh;
119	rename "$path~", $path	262	rename "$path~", $path
120	or die "$path: $!";	263	or die "$path: $!";
121	}	264	}
122		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
123	sub normalize_object($) {	335	sub normalize_object($) {
124	my ($ob) = @_;	336	my ($ob) = @_;
125		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
126	delete $ob->{$_} for qw(	372	delete @$ob{qw(
127	can_knockback can_parry can_impale can_cut can_dam_armour	373	can_knockback can_parry can_impale can_cut can_dam_armour
128	can_apply pass_thru can_pass_thru	374	can_apply pass_thru can_pass_thru color_bg color_fg
129	);	375	)};
130		376
131	for my $attr (qw(move_type move_block move_allow move_on move_off move_slow)) {	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
		382	for my $attr (keys %FIELD_MOVEMENT) {
132	next unless exists $ob->{$attr};	383	next unless exists $ob->{$attr};
133	next if $ob->{$attr} =~ /^\d+$/;
134		384
135	my $flags = 0;	385	$ob->{$attr} = new Crossfire::MoveType $ob->{$attr};
136
137	# assume list
138	for my $flag (map lc, split /\s+/, $ob->{$attr}) {
139	$flags \|= MOVE_WALK if $flag eq "walk";
140	$flags \|= MOVE_FLY_LOW if $flag eq "fly_low";
141	$flags \|= MOVE_FLY_HIGH if $flag eq "fly_high";
142	$flags \|= MOVE_FLYING if $flag eq "flying";
143	$flags \|= MOVE_SWIM if $flag eq "swim";
144	$flags \|= MOVE_BOAT if $flag eq "boat";
145	$flags \|= MOVE_ALL if $flag eq "all";
146
147	$flags &= ~MOVE_WALK if $flag eq "-walk";
148	$flags &= ~MOVE_FLY_LOW if $flag eq "-fly_low";
149	$flags &= ~MOVE_FLY_HIGH if $flag eq "-fly_high";
150	$flags &= ~MOVE_FLYING if $flag eq "-flying";
151	$flags &= ~MOVE_SWIM if $flag eq "-swim";
152	$flags &= ~MOVE_BOAT if $flag eq "-boat";
153	$flags &= ~MOVE_ALL if $flag eq "-all";
154	}
155
156	$ob->{$attr} = $flags;
157	}	386	}
158		387
		388	# convert outdated movement flags to new movement sets
159	if (defined (my $v = delete $ob->{no_pass})) {	389	if (defined (my $v = delete $ob->{no_pass})) {
160	$ob->{move_block} = $v ? MOVE_ALL : 0;	390	$ob->{move_block} = new Crossfire::MoveType $v ? "all" : "";
161	}	391	}
162	if (defined (my $v = delete $ob->{slow_move})) {	392	if (defined (my $v = delete $ob->{slow_move})) {
163	$ob->{move_slow} \|= MOVE_WALK;	393	$ob->{move_slow} += "walk";
164	$ob->{move_slow_penalty} = $v;	394	$ob->{move_slow_penalty} = $v;
165	}	395	}
166	if (defined (my $v = delete $ob->{walk_on})) {	396	if (defined (my $v = delete $ob->{walk_on})) {
167	$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" }
168	: $ob->{move_on} & ~MOVE_WALK;
169	}	398	}
170	if (defined (my $v = delete $ob->{walk_off})) {	399	if (defined (my $v = delete $ob->{walk_off})) {
171	$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" }
172	: $ob->{move_off} & ~MOVE_WALK;
173	}	401	}
174	if (defined (my $v = delete $ob->{fly_on})) {	402	if (defined (my $v = delete $ob->{fly_on})) {
175	$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" }
176	: $ob->{move_on} & ~MOVE_FLY_LOW;
177	}	404	}
178	if (defined (my $v = delete $ob->{fly_off})) {	405	if (defined (my $v = delete $ob->{fly_off})) {
179	$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" }
180	: $ob->{move_off} & ~MOVE_FLY_LOW;
181	}	407	}
182	if (defined (my $v = delete $ob->{flying})) {	408	if (defined (my $v = delete $ob->{flying})) {
183	$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" }
184	: $ob->{move_type} & ~MOVE_FLY_LOW;
185	}	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};
186		426
187	$ob	427	$ob
188	}	428	}
189		429
		430	# arch as in "arch xxx", ie.. objects
190	sub normalize_arch($) {	431	sub normalize_arch($) {
191	my ($ob) = @_;	432	my ($ob) = @_;
192		433
193	normalize_object $ob;	434	normalize_object $ob;
194		435
…		…
221	delete $ob->{$k};	462	delete $ob->{$k};
222	}	463	}
223	}	464	}
224	}	465	}
225		466
		467	# a speciality for the editor
		468	if (exists $ob->{attack_movement}) {
		469	my $am = delete $ob->{attack_movement};
		470	$ob->{attack_movement_bits_0_3} = $am & 15;
		471	$ob->{attack_movement_bits_4_7} = $am & 240;
		472	}
		473
		474	$ob
		475	}
		476
		477	sub attr_thaw($) {
		478	my ($ob) = @_;
		479
		480	$ob->{attach} = from_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::to_json $ob->{attach}
		490	if exists $ob->{attach};
		491
226	$ob	492	$ob
227	}	493	}
228		494
229	sub read_pak($) {	495	sub read_pak($) {
230	my ($path) = @_;	496	my ($path) = @_;
231		497
232	my %pak;	498	my %pak;
233		499
234	open my $fh, "<", $path	500	open my $fh, "<:raw:perlio", $path
235	or Carp::croak "$_[0]: $!";	501	or Carp::croak "$_[0]: $!";
236	binmode $fh;	502	binmode $fh;
237	while (<$fh>) {	503	while (<$fh>) {
238	my ($type, $id, $len, $path) = split;	504	my ($type, $id, $len, $path) = split;
239	$path =~ s/.*\///;	505	$path =~ s/.*\///;
…		…
241	}	507	}
242		508
243	\%pak	509	\%pak
244	}	510	}
245		511
246	sub read_arch($) {	512	sub read_arch($;$) {
247	my ($path) = @_;	513	my ($path, $toplevel) = @_;
248		514
249	my %arc;	515	my %arc;
250	my ($more, $prev);	516	my ($more, $prev);
		517	my $comment;
251		518
252	open my $fh, "<", $path	519	open my $fh, "<:raw:perlio:utf8", $path
253	or Carp::croak "$path: $!";	520	or Carp::croak "$path: $!";
254		521
255	binmode $fh;	522	# binmode $fh;
256		523
257	my $parse_block; $parse_block = sub {	524	my $parse_block; $parse_block = sub {
258	my %arc = @_;	525	my %arc = @_;
259		526
260	while (<$fh>) {	527	while (<$fh>) {
261	s/\s+$//;	528	s/\s+$//;
262	if (/^end$/i) {	529	if (/^end$/i) {
263	last;	530	last;
		531
264	} elsif (/^arch (\S+)$/) {	532	} elsif (/^arch (\S+)$/i) {
265	push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1);	533	push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
		534
266	} elsif (/^lore$/) {	535	} elsif (/^lore$/i) {
267	while (<$fh>) {	536	while (<$fh>) {
268	last if /^endlore\s*$/i;	537	last if /^endlore\s*$/i;
269	$arc{lore} .= $_;	538	$arc{lore} .= $_;
270	}	539	}
271	} elsif (/^msg$/) {	540	} elsif (/^msg$/i) {
272	while (<$fh>) {	541	while (<$fh>) {
273	last if /^endmsg\s*$/i;	542	last if /^endmsg\s*$/i;
274	$arc{msg} .= $_;	543	$arc{msg} .= $_;
275	}	544	}
		545	} elsif (/^anim$/i) {
		546	while (<$fh>) {
		547	last if /^mina\s*$/i;
		548	chomp;
		549	push @{ $arc{anim} }, $_;
		550	}
276	} elsif (/^(\S+)\s(.)$/) {	551	} elsif (/^(\S+)\s(.)$/) {
277	$arc{lc $1} = $2;	552	$arc{lc $1} = $2;
278	} elsif (/^\s*($\|#)/) {	553	} elsif (/^\s*#/) {
		554	$arc{_comment} .= "$_\n";
		555
		556	} elsif (/^\s*$/) {
279	#	557	#
280	} else {	558	} else {
281	warn "$path: unparsable line '$_' in arch $arc{_name}";	559	warn "$path: unparsable line '$_' in arch $arc{_name}";
282	}	560	}
283	}	561	}
…		…
289	s/\s+$//;	567	s/\s+$//;
290	if (/^more$/i) {	568	if (/^more$/i) {
291	$more = $prev;	569	$more = $prev;
292	} elsif (/^object (\S+)$/i) {	570	} elsif (/^object (\S+)$/i) {
293	my $name = $1;	571	my $name = $1;
294	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';
295		576
296	if ($more) {	577	if ($more) {
297	$more->{more} = $arc;	578	$more->{more} = $arc;
298	} else {	579	} else {
299	$arc{$name} = $arc;	580	$arc{$name} = $arc;
300	}	581	}
301	$prev = $arc;	582	$prev = $arc;
302	$more = undef;	583	$more = undef;
303	} elsif (/^arch (\S+)$/i) {	584	} elsif (/^arch (\S+)$/i) {
304	push @{ $arc{arch} }, normalize_arch $parse_block->(_name => $1);	585	my $name = $1;
		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';
		590
		591	if ($more) {
		592	$more->{more} = $arc;
		593	} else {
		594	push @{ $arc{arch} }, $arc;
		595	}
		596	$prev = $arc;
		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";
305	} elsif (/^\s*($\|#)/) {	609	} elsif (/^\s*($\|#)/) {
306	#	610	#
307	} else {	611	} else {
308	warn "$path: unparseable top-level line '$_'";	612	die "$path: unparseable top-level line '$_'";
309	}	613	}
310	}	614	}
311		615
312	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.
313		617
314	\%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
315	}	701	}
316		702
317	# 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
318	# NOTE: the arrays in the hash values are references to	704	# NOTE: the arrays in the hash values are references to
319	# the archs from $ARCH	705	# the archs from $ARCH
320	sub editor_archs {	706	sub editor_archs {
321	my %paths;	707	my %paths;
322		708
323	for (keys %ARCH) {	709	for (keys %ARCH) {
324	my $arch = $ARCH{$_};	710	my $arch = $ARCH{$_};
325	push @{$paths{$arch->{editor_folder}}}, \$arch;	711	push @{$paths{$arch->{editor_folder}}}, $arch;
326	}	712	}
327		713
328	\%paths	714	\%paths
329	}	715	}
330		716
…		…
340	my ($a) = @_;	726	my ($a) = @_;
341		727
342	my $o = $ARCH{$a->{_name}}	728	my $o = $ARCH{$a->{_name}}
343	or return;	729	or return;
344		730
345	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"}
346	or (warn "no face data found for arch '$a->{_name}'"), return;	734	or (warn "no face data found for arch '$a->{_name}'"), return;
		735	}
347		736
348	if ($face->{w} > 1 \|\| $face->{h} > 1) {	737	if ($face->{w} > 1 \|\| $face->{h} > 1) {
349	# bigface	738	# bigface
350	return (0, 0, $face->{w} - 1, $face->{h} - 1);	739	return (0, 0, $face->{w} - 1, $face->{h} - 1);
351		740
…		…
395	my $type = $obj->{type} \|\| $arch->{type};	784	my $type = $obj->{type} \|\| $arch->{type};
396		785
397	if ($type > 0) {	786	if ($type > 0) {
398	$root = $Crossfire::Data::ATTR{$type};	787	$root = $Crossfire::Data::ATTR{$type};
399	} 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 {
400	$root = $Crossfire::Data::TYPE{Misc};	800	$root = $Crossfire::Data::TYPE{Misc};
401
402	type:
403	for (@Crossfire::Data::ATTR0) {
404	my $req = $_->{required}
405	or die "internal error: ATTR0 without 'required'";
406
407	keys %$req;
408	while (my ($k, $v) = each %$req) {
409	next type
410	unless $obj->{$k} == $v \|\| $arch->{$k} == $v;
411	}
412
413	$root = $_;
414	}	801	}
415	}	802	}
416		803
417	my @import = ($root);	804	my @import = ($root);
418		805
…		…
421		808
422	my (%ignore);	809	my (%ignore);
423	my (@section_order, %section, @attr_order);	810	my (@section_order, %section, @attr_order);
424		811
425	while (my $type = shift @import) {	812	while (my $type = shift @import) {
		813	push @import,
		814	grep $_,
		815	map $Crossfire::Data::TYPE{$_},
426	push @import, @{$type->{import} \|\| []};	816	@{$type->{import} \|\| []};
427		817
428	$attr->{$_} \|\|= $type->{$_}	818	$attr->{$_} \|\|= $type->{$_}
429	for qw(name desc use);	819	for qw(name desc use);
430		820
431	for (@{$type->{ignore} \|\| []}) {	821	for (@{$type->{ignore} \|\| []}) {
…		…
460	];	850	];
461		851
462	$attr	852	$attr
463	}	853	}
464		854
465	sub arch_edit_sections {
466	# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
467	# edit_type = 0;
468	# else if (edit_type != 0) {
469	# // all flags from 'check_type' must be unset in this arch because they get recalculated now
470	# edit_type &= ~check_type;
471	# }
472	#
473	# }
474	# if ((check_type & IGUIConstants.TILE_EDIT_MONSTER) != 0 &&
475	# getAttributeValue("alive", defarch) == 1 &&
476	# (getAttributeValue("monster", defarch) == 1 \|\|
477	# getAttributeValue("generator", defarch) == 1)) {
478	# // Monster: monsters/npcs/generators
479	# edit_type \|= IGUIConstants.TILE_EDIT_MONSTER;
480	# }
481	# if ((check_type & IGUIConstants.TILE_EDIT_WALL) != 0 &&
482	# arch_type == 0 && getAttributeValue("no_pass", defarch) == 1) {
483	# // Walls
484	# edit_type \|= IGUIConstants.TILE_EDIT_WALL;
485	# }
486	# if ((check_type & IGUIConstants.TILE_EDIT_CONNECTED) != 0 &&
487	# getAttributeValue("connected", defarch) != 0) {
488	# // Connected Objects
489	# edit_type \|= IGUIConstants.TILE_EDIT_CONNECTED;
490	# }
491	# if ((check_type & IGUIConstants.TILE_EDIT_EXIT) != 0 &&
492	# arch_type == 66 \|\| arch_type == 41 \|\| arch_type == 95) {
493	# // Exit: teleporter/exit/trapdoors
494	# edit_type \|= IGUIConstants.TILE_EDIT_EXIT;
495	# }
496	# if ((check_type & IGUIConstants.TILE_EDIT_TREASURE) != 0 &&
497	# getAttributeValue("no_pick", defarch) == 0 && (arch_type == 4 \|\|
498	# arch_type == 5 \|\| arch_type == 36 \|\| arch_type == 60 \|\|
499	# arch_type == 85 \|\| arch_type == 111 \|\| arch_type == 123 \|\|
500	# arch_type == 124 \|\| arch_type == 130)) {
501	# // Treasure: randomtreasure/money/gems/potions/spellbooks/scrolls
502	# edit_type \|= IGUIConstants.TILE_EDIT_TREASURE;
503	# }
504	# if ((check_type & IGUIConstants.TILE_EDIT_DOOR) != 0 &&
505	# arch_type == 20 \|\| arch_type == 23 \|\| arch_type == 26 \|\|
506	# arch_type == 91 \|\| arch_type == 21 \|\| arch_type == 24) {
507	# // Door: door/special door/gates + keys
508	# edit_type \|= IGUIConstants.TILE_EDIT_DOOR;
509	# }
510	# if ((check_type & IGUIConstants.TILE_EDIT_EQUIP) != 0 &&
511	# getAttributeValue("no_pick", defarch) == 0 && ((arch_type >= 13 &&
512	# arch_type <= 16) \|\| arch_type == 33 \|\| arch_type == 34 \|\|
513	# arch_type == 35 \|\| arch_type == 39 \|\| arch_type == 70 \|\|
514	# arch_type == 87 \|\| arch_type == 99 \|\| arch_type == 100 \|\|
515	# arch_type == 104 \|\| arch_type == 109 \|\| arch_type == 113 \|\|
516	# arch_type == 122 \|\| arch_type == 3)) {
517	# // Equipment: weapons/armour/wands/rods
518	# edit_type \|= IGUIConstants.TILE_EDIT_EQUIP;
519	# }
520	#
521	# return(edit_type);
522	#
523	#
524	}
525
526	sub cache_file($$&&) {	855	sub cache_file($$&&) {
527	my ($src, $cache, $load, $create) = @_;	856	my ($src, $cache, $load, $create) = @_;
528		857
529	my ($size, $mtime) = (stat $src)[7,9]	858	my ($size, $mtime) = (stat $src)[7,9]
530	or Carp::croak "$src: $!";	859	or Carp::croak "$src: $!";
…		…
578	}, sub {	907	}, sub {
579	read_arch "$LIB/archetypes"	908	read_arch "$LIB/archetypes"
580	};	909	};
581	}	910	}
582		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
583	=item load_tilecache	942	=item load_tilecache
584		943
585	(Re-)Load %TILE and %FACE.	944	(Re-)Load %TILE and %FACE.
586		945
587	=cut	946	=cut
588		947
589	sub load_tilecache() {	948	sub load_tilecache() {
590	require Gtk2;	949	require Gtk2;
591		950
592	cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub {	951	cache_file "$LIB/facedata", "$VARDIR/tilecache.pst", \&use_tilecache,
593	$TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
594	or die "$VARDIR/tilecache.png: $!";
595	*FACE = $_[0];
596	}, sub {	952	sub {
597	require File::Temp;
598
599	my $tile = read_pak "$LIB/crossfire.0";
600
601	my %cache;	953	my %cache;
		954	my $facedata = Storable::retrieve "$LIB/facedata";
602		955
		956	$facedata->{version} == 2
		957	or die "$LIB/facedata: version mismatch, cannot proceed.";
		958
		959	my $faces = $facedata->{faceinfo};
603	my $idx = 0;	960	my $idx = 0;
604		961
605	for my $name (sort keys %$tile) {	962	for (sort keys %$faces) {
606	my ($fh, $filename) = File::Temp::tempfile ();	963	my ($face, $info) = ($_, $faces->{$_});
607	print $fh $tile->{$name};	964
608	close $fh;
609	my $pb = new_from_file Gtk2::Gdk::Pixbuf $filename;	965	my $pb = new Gtk2::Gdk::PixbufLoader;
610	unlink $filename;	966	$pb->write ($info->{data32});
		967	$pb->close;
		968	my $pb = $pb->get_pixbuf;
611		969
612	my $tile = $cache{$name} = {	970	my $tile = $cache{$face} = {
613	pb => $pb,	971	pb => $pb,
614	idx => $idx,	972	idx => $idx,
615	w => int $pb->get_width / TILESIZE,	973	w => int $pb->get_width / TILESIZE,
616	h => int $pb->get_height / TILESIZE,	974	h => int $pb->get_height / TILESIZE,
617	};	975	};
618
619		976
620	$idx += $tile->{w} * $tile->{h};	977	$idx += $tile->{w} * $tile->{h};
		978	}
		979
		980	construct_tilecache_pb $idx, \%cache;
		981
		982	\%cache
621	}	983	};
622
623	my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
624
625	while (my ($name, $tile) = each %cache) {
626	my $tpb = delete $tile->{pb};
627	my $ofs = $tile->{idx};
628
629	for my $x (0 .. $tile->{w} - 1) {
630	for my $y (0 .. $tile->{h} - 1) {
631	my $idx = $ofs + $x + $y * $tile->{w};
632	$tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
633	$pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
634	}
635	}
636	}
637
638	$pb->save ("$VARDIR/tilecache.png", "png");
639
640	\%cache
641	};
642	}	984	}
643		985
644	=head1 AUTHOR	986	=head1 AUTHOR
645		987
646	Marc Lehmann <schmorp@schmorp.de>	988	Marc Lehmann <schmorp@schmorp.de>
…		…
650	http://www.ta-sa.org/	992	http://www.ta-sa.org/
651		993
652	=cut	994	=cut
653		995
654	1	996	1
		997

Diff Legend

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

Comparing deliantra/Deliantra/Deliantra.pm (file contents): Revision 1.54 by root, Thu Mar 23 06:45:23 2006 UTC vs. Revision 1.116 by root, Thu Nov 8 01:21:54 2007 UTC

Diff Legend

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.54 by root, Thu Mar 23 06:45:23 2006 UTC vs.
Revision 1.116 by root, Thu Nov 8 01:21:54 2007 UTC