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

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.17 by root, Wed Feb 22 22:36:45 2006 UTC vs.
Revision 1.88 by root, Sun Feb 18 20:20:58 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 = '0.96';
10		10
11	use strict;	11	use strict;
12		12
13	use base 'Exporter';	13	use base 'Exporter';
14		14
15	use Carp ();	15	use Carp ();
16	use Storable;	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		19
19	#XXX: The map_* procedures scream for a map-object
20
21	our @EXPORT =	20	our @EXPORT = qw(
22	qw(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	);
23		23
		24	use JSON::Syck (); #TODO#d# replace by JSON::PC when it becomes available == working
		25
		26	sub from_json($) {
		27	$JSON::Syck::ImplicitUnicode = 1;
		28	JSON::Syck::Load $_[0]
		29	}
		30
		31	sub to_json($) {
		32	$JSON::Syck::ImplicitUnicode = 0;
		33	JSON::Syck::Dump $_[0]
		34	}
		35
24	our $LIB = $ENV{CROSSFIRE_LIBDIR}	36	our $LIB = $ENV{CROSSFIRE_LIBDIR};
25	or Carp::croak "\$CROSSFIRE_LIBDIR must be set\n";	37
		38	our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire"
		39	: $ENV{AppData} ? "$ENV{APPDATA}/crossfire"
		40	: File::Spec->tmpdir . "/crossfire";
		41
		42	mkdir $VARDIR, 0777;
26		43
27	sub TILESIZE (){ 32 }	44	sub TILESIZE (){ 32 }
28		45
29	our $CACHEDIR;
30	our %ARCH;	46	our %ARCH;
31	our %FACE;	47	our %FACE;
32	our $TILE;	48	our $TILE;
33		49
34	our %FIELD_MULTILINE = (	50	our %FIELD_MULTILINE = (
35	msg => "endmsg",	51	msg => "endmsg",
36	lore => "endlore",	52	lore => "endlore",
		53	maplore => "endmaplore",
37	);	54	);
38		55
39	# not used yet, maybe alphabetical is ok	56	# movement bit type, PITA
		57	our %FIELD_MOVEMENT = map +($_ => undef),
		58	qw(move_type move_block move_allow move_on move_off move_slow);
		59
		60	# same as in server save routine, to (hopefully) be compatible
		61	# to the other editors.
		62	our @FIELD_ORDER_MAP = (qw(
		63	file_format_version
		64	name attach swap_time reset_timeout fixed_resettime difficulty region
		65	shopitems shopgreed shopmin shopmax shoprace
		66	darkness width height enter_x enter_y msg maplore
		67	unique template
		68	outdoor temp pressure humid windspeed winddir sky nosmooth
		69	tile_path_1 tile_path_2 tile_path_3 tile_path_4
		70	));
		71
40	our @FIELD_ORDER = (qw(name name_pl));	72	our @FIELD_ORDER = (qw(
		73	elevation
41		74
		75	name name_pl custom_name attach title race
		76	slaying skill msg lore other_arch face
		77	#todo-events
		78	animation is_animated
		79	str dex con wis pow cha int
		80	hp maxhp sp maxsp grace maxgrace
		81	exp perm_exp expmul
		82	food dam luck wc ac x y speed speed_left move_state attack_movement
		83	nrof level direction type subtype attacktype
		84
		85	resist_physical resist_magic resist_fire resist_electricity
		86	resist_cold resist_confusion resist_acid resist_drain
		87	resist_weaponmagic resist_ghosthit resist_poison resist_slow
		88	resist_paralyze resist_turn_undead resist_fear resist_cancellation
		89	resist_deplete resist_death resist_chaos resist_counterspell
		90	resist_godpower resist_holyword resist_blind resist_internal
		91	resist_life_stealing resist_disease
		92
		93	path_attuned path_repelled path_denied material materialname
		94	value carrying weight invisible state magic
		95	last_heal last_sp last_grace last_eat
		96	connected glow_radius randomitems npx_status npc_program
		97	run_away pick_up container will_apply smoothlevel
		98	current_weapon_script weapontype tooltype elevation client_type
		99	item_power duration range
		100	range_modifier duration_modifier dam_modifier gen_sp_armour
		101	move_type move_block move_allow move_on move_off move_on move_slow move_slow_penalty
		102
		103	alive wiz was_wiz applied unpaid can_use_shield no_pick is_animated monster
		104	friendly generator is_thrown auto_apply treasure player sold see_invisible
		105	can_roll overlay_floor is_turnable is_used_up identified reflecting changing
		106	splitting hitback startequip blocksview undead scared unaggressive
		107	reflect_missile reflect_spell no_magic no_fix_player is_lightable tear_down
		108	run_away pick_up unique no_drop can_cast_spell can_use_scroll can_use_range
		109	can_use_bow can_use_armour can_use_weapon can_use_ring has_ready_range
		110	has_ready_bow xrays is_floor lifesave no_strength sleep stand_still
		111	random_move only_attack confused stealth cursed damned see_anywhere
		112	known_magical known_cursed can_use_skill been_applied has_ready_scroll
		113	can_use_rod can_use_horn make_invisible inv_locked is_wooded is_hilly
		114	has_ready_skill has_ready_weapon no_skill_ident is_blind can_see_in_dark
		115	is_cauldron is_dust no_steal one_hit berserk neutral no_attack no_damage
		116	activate_on_push activate_on_release is_water use_content_on_gen is_buildable
		117
		118	body_range body_arm body_torso body_head body_neck body_skill
		119	body_finger body_shoulder body_foot body_hand body_wrist body_waist
		120	));
		121
		122	our %EVENT_TYPE = (
		123	apply => 1,
		124	attack => 2,
		125	death => 3,
		126	drop => 4,
		127	pickup => 5,
		128	say => 6,
		129	stop => 7,
		130	time => 8,
		131	throw => 9,
		132	trigger => 10,
		133	close => 11,
		134	timer => 12,
		135	);
		136
42	sub MOVE_WALK (){ 0x1 }	137	sub MOVE_WALK (){ 0x01 }
43	sub MOVE_FLY_LOW (){ 0x2 }	138	sub MOVE_FLY_LOW (){ 0x02 }
44	sub MOVE_FLY_HIGH (){ 0x4 }	139	sub MOVE_FLY_HIGH (){ 0x04 }
45	sub MOVE_FLYING (){ 0x6 }	140	sub MOVE_FLYING (){ 0x06 }
46	sub MOVE_SWIM (){ 0x8 }	141	sub MOVE_SWIM (){ 0x08 }
47	sub MOVE_ALL (){ 0xf }	142	sub MOVE_BOAT (){ 0x10 }
		143	sub MOVE_KNOWN (){ 0x1f } # all of above
		144	sub MOVE_ALLBIT (){ 0x10000 }
		145	sub MOVE_ALL (){ 0x1001f } # very special value, more PITA
48		146
		147	sub load_ref($) {
		148	my ($path) = @_;
		149
		150	open my $fh, "<:raw:perlio", $path
		151	or die "$path: $!";
		152	local $/;
		153
		154	thaw <$fh>
		155	}
		156
		157	sub save_ref($$) {
		158	my ($ref, $path) = @_;
		159
		160	open my $fh, ">:raw:perlio", "$path~"
		161	or die "$path~: $!";
		162	print $fh freeze $ref;
		163	close $fh;
		164	rename "$path~", $path
		165	or die "$path: $!";
		166	}
		167
		168	my %attack_mask = (
		169	physical => 0x00000001,
		170	magic => 0x00000002,
		171	fire => 0x00000004,
		172	electricity => 0x00000008,
		173	cold => 0x00000010,
		174	confusion => 0x00000020,
		175	acid => 0x00000040,
		176	drain => 0x00000080,
		177	weaponmagic => 0x00000100,
		178	ghosthit => 0x00000200,
		179	poison => 0x00000400,
		180	slow => 0x00000800,
		181	paralyze => 0x00001000,
		182	turn_undead => 0x00002000,
		183	fear => 0x00004000,
		184	cancellation => 0x00008000,
		185	deplete => 0x00010000,
		186	death => 0x00020000,
		187	chaos => 0x00040000,
		188	counterspell => 0x00080000,
		189	godpower => 0x00100000,
		190	holyword => 0x00200000,
		191	blind => 0x00400000,
		192	internal => 0x00800000,
		193	life_stealing => 0x01000000,
		194	disease => 0x02000000,
		195	);
		196
		197	sub _add_resist($$$) {
		198	my ($ob, $mask, $value) = @_;
		199
		200	while (my ($k, $v) = each %attack_mask) {
		201	$ob->{"resist_$k"} = min 100, max -100, $ob->{"resist_$k"} + $value if $mask & $v;
		202	}
		203	}
		204
		205	my %MATERIAL = reverse
		206	paper => 1,
		207	iron => 2,
		208	glass => 4,
		209	leather => 8,
		210	wood => 16,
		211	organic => 32,
		212	stone => 64,
		213	cloth => 128,
		214	adamant => 256,
		215	liquid => 512,
		216	tin => 1024,
		217	bone => 2048,
		218	ice => 4096,
		219
		220	# guesses
		221	runestone => 12,
		222	bronze => 18,
		223	"ancient wood" => 20,
		224	glass => 36,
		225	marble => 66,
		226	ice => 68,
		227	stone => 70,
		228	stone => 80,
		229	cloth => 136,
		230	ironwood => 144,
		231	adamantium => 258,
		232	glacium => 260,
		233	blood => 544,
		234	;
		235
		236	# object as in "Object xxx", i.e. archetypes
		237	sub normalize_object($) {
		238	my ($ob) = @_;
		239
		240	# convert material bitset to materialname, if possible
		241	if (exists $ob->{material}) {
		242	if (!$ob->{material}) {
		243	delete $ob->{material};
		244	} elsif (exists $ob->{materialname}) {
		245	if ($MATERIAL{$ob->{material}} eq $ob->{materialname}) {
		246	delete $ob->{material};
		247	} else {
		248	warn "object $ob->{_name} has both materialname ($ob->{materialname}) and material ($ob->{material}) set.\n";
		249	delete $ob->{material}; # assume materilname is more specific and nuke material
		250	}
		251	} elsif (my $name = $MATERIAL{$ob->{material}}) {
		252	delete $ob->{material};
		253	$ob->{materialname} = $name;
		254	} else {
		255	warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n";
		256	}
		257	}
		258
		259	# nuke outdated or never supported fields
		260	delete @$ob{qw(
		261	can_knockback can_parry can_impale can_cut can_dam_armour
		262	can_apply pass_thru can_pass_thru
		263	)};
		264
		265	if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; }
		266	if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; }
		267	if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; }
		268
		269	# convert movement strings to bitsets
		270	for my $attr (keys %FIELD_MOVEMENT) {
		271	next unless exists $ob->{$attr};
		272
		273	$ob->{$attr} = MOVE_ALL if $ob->{$attr} == 255; #d# compatibility
		274
		275	next if $ob->{$attr} =~ /^\d+$/;
		276
		277	my $flags = 0;
		278
		279	# assume list
		280	for my $flag (map lc, split /\s+/, $ob->{$attr}) {
		281	$flags \|= MOVE_WALK if $flag eq "walk";
		282	$flags \|= MOVE_FLY_LOW if $flag eq "fly_low";
		283	$flags \|= MOVE_FLY_HIGH if $flag eq "fly_high";
		284	$flags \|= MOVE_FLYING if $flag eq "flying";
		285	$flags \|= MOVE_SWIM if $flag eq "swim";
		286	$flags \|= MOVE_BOAT if $flag eq "boat";
		287	$flags \|= MOVE_ALL if $flag eq "all";
		288
		289	$flags &= ~MOVE_WALK if $flag eq "-walk";
		290	$flags &= ~MOVE_FLY_LOW if $flag eq "-fly_low";
		291	$flags &= ~MOVE_FLY_HIGH if $flag eq "-fly_high";
		292	$flags &= ~MOVE_FLYING if $flag eq "-flying";
		293	$flags &= ~MOVE_SWIM if $flag eq "-swim";
		294	$flags &= ~MOVE_BOAT if $flag eq "-boat";
		295	$flags &= ~MOVE_ALL if $flag eq "-all";
		296	}
		297
		298	$ob->{$attr} = $flags;
		299	}
		300
		301	# convert outdated movement flags to new movement sets
		302	if (defined (my $v = delete $ob->{no_pass})) {
		303	$ob->{move_block} = $v ? MOVE_ALL : 0;
		304	}
		305	if (defined (my $v = delete $ob->{slow_move})) {
		306	$ob->{move_slow} \|= MOVE_WALK;
		307	$ob->{move_slow_penalty} = $v;
		308	}
		309	if (defined (my $v = delete $ob->{walk_on})) {
		310	$ob->{move_on} = MOVE_NONE unless exists $ob->{move_on};
		311	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_WALK
		312	: $ob->{move_on} & ~MOVE_WALK;
		313	}
		314	if (defined (my $v = delete $ob->{walk_off})) {
		315	$ob->{move_off} = MOVE_NONE unless exists $ob->{move_off};
		316	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_WALK
		317	: $ob->{move_off} & ~MOVE_WALK;
		318	}
		319	if (defined (my $v = delete $ob->{fly_on})) {
		320	$ob->{move_on} = MOVE_NONE unless exists $ob->{move_on};
		321	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_FLY_LOW
		322	: $ob->{move_on} & ~MOVE_FLY_LOW;
		323	}
		324	if (defined (my $v = delete $ob->{fly_off})) {
		325	$ob->{move_off} = MOVE_NONE unless exists $ob->{move_off};
		326	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_FLY_LOW
		327	: $ob->{move_off} & ~MOVE_FLY_LOW;
		328	}
		329	if (defined (my $v = delete $ob->{flying})) {
		330	$ob->{move_type} = MOVE_NONE unless exists $ob->{move_type};
		331	$ob->{move_type} = $v ? $ob->{move_type} \| MOVE_FLY_LOW
		332	: $ob->{move_type} & ~MOVE_FLY_LOW;
		333	}
		334
		335	# convert idiotic event_xxx things into objects
		336	while (my ($event, $subtype) = each %EVENT_TYPE) {
		337	if (exists $ob->{"event_${event}_plugin"}) {
		338	push @{$ob->{inventory}}, {
		339	_name => "event_$event",
		340	title => delete $ob->{"event_${event}_plugin"},
		341	slaying => delete $ob->{"event_${event}"},
		342	name => delete $ob->{"event_${event}_options"},
		343	};
		344	}
		345	}
		346
		347	# some archetypes had "+3" instead of the canonical "3", so fix
		348	$ob->{dam} *= 1 if exists $ob->{dam};
		349
		350	$ob
		351	}
		352
		353	# arch as in "arch xxx", ie.. objects
49	sub normalize_arch($) {	354	sub normalize_arch($) {
50	my ($ob) = @_;	355	my ($ob) = @_;
51		356
		357	normalize_object $ob;
		358
52	my $arch = $ARCH{$ob->{_name}}	359	my $arch = $ARCH{$ob->{_name}}
53	or (warn "$ob->{_name}: no such archetype", return $ob);	360	or (warn "$ob->{_name}: no such archetype", return $ob);
54
55	delete $ob->{$_} for qw(can_knockback can_parry can_impale can_cut can_dam_armour can_apply);
56		361
57	if ($arch->{type} == 22) { # map	362	if ($arch->{type} == 22) { # map
58	my %normalize = (	363	my %normalize = (
59	"enter_x" => "hp",	364	"enter_x" => "hp",
60	"enter_y" => "sp",	365	"enter_y" => "sp",
…		…
70	while (my ($k2, $k1) = each %normalize) {	375	while (my ($k2, $k1) = each %normalize) {
71	if (defined (my $v = delete $ob->{$k1})) {	376	if (defined (my $v = delete $ob->{$k1})) {
72	$ob->{$k2} = $v;	377	$ob->{$k2} = $v;
73	}	378	}
74	}	379	}
75	}	380	} else {
76
77	if (defined (my $v = delete $ob->{no_pass})) {
78	$ob->{move_block} = $v ? MOVE_ALL : 0;
79	}
80	if (defined (my $v = delete $ob->{walk_on})) {
81	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_WALK
82	: $ob->{move_on} & ~MOVE_WALK;
83	}
84	if (defined (my $v = delete $ob->{walk_off})) {
85	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_WALK
86	: $ob->{move_off} & ~MOVE_WALK;
87	}
88	if (defined (my $v = delete $ob->{fly_on})) {
89	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_FLY_LOW
90	: $ob->{move_on} & ~MOVE_FLY_LOW;
91	}
92	if (defined (my $v = delete $ob->{fly_off})) {
93	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_FLY_LOW
94	: $ob->{move_off} & ~MOVE_FLY_LOW;
95	}
96	if (defined (my $v = delete $ob->{flying})) {
97	$ob->{move_type} = $v ? $ob->{move_type} \| MOVE_FLY_LOW
98	: $ob->{move_type} & ~MOVE_FLY_LOW;
99	}
100
101	# if value matches archetype default, delete	381	# if value matches archetype default, delete
102	while (my ($k, $v) = each %$ob) {	382	while (my ($k, $v) = each %$ob) {
103	if (exists $arch->{$k} and $arch->{$k} eq $v) {	383	if (exists $arch->{$k} and $arch->{$k} eq $v) {
104	next if $k eq "_name";	384	next if $k eq "_name";
105	delete $ob->{$k};	385	delete $ob->{$k};
106	}	386	}
		387	}
		388	}
		389
		390	# a speciality for the editor
		391	if (exists $ob->{attack_movement}) {
		392	my $am = delete $ob->{attack_movement};
		393	$ob->{attack_movement_bits_0_3} = $am & 15;
		394	$ob->{attack_movement_bits_4_7} = $am & 240;
107	}	395	}
108		396
109	$ob	397	$ob
110	}	398	}
111		399
		400	sub attr_thaw($) {
		401	my ($ob) = @_;
		402
		403	$ob->{attach} = from_json $ob->{attach}
		404	if exists $ob->{attach};
		405
		406	$ob
		407	}
		408
		409	sub attr_freeze($) {
		410	my ($ob) = @_;
		411
		412	$ob->{attach} = Crossfire::to_json $ob->{attach}
		413	if exists $ob->{attach};
		414
		415	$ob
		416	}
		417
112	sub read_pak($;$) {	418	sub read_pak($) {
113	my ($path, $cache) = @_;	419	my ($path) = @_;
114		420
115	eval {
116	defined $cache
117	&& -M $cache < -M $path
118	&& Storable::retrieve $cache
119	} or do {
120	my %pak;	421	my %pak;
121		422
122	open my $fh, "<:raw", $path	423	open my $fh, "<:raw:perlio", $path
123	or Carp::croak "$_[0]: $!";	424	or Carp::croak "$_[0]: $!";
		425	binmode $fh;
124	while (<$fh>) {	426	while (<$fh>) {
125	my ($type, $id, $len, $path) = split;	427	my ($type, $id, $len, $path) = split;
126	$path =~ s/.*\///;	428	$path =~ s/.*\///;
127	read $fh, $pak{$path}, $len;	429	read $fh, $pak{$path}, $len;
128	}	430	}
129		431
130	Storable::nstore \%pak, $cache
131	if defined $cache;
132
133	\%pak	432	\%pak
134	}
135	}	433	}
136		434
137	sub read_arch($;$) {	435	sub read_arch($;$) {
138	my ($path, $cache) = @_;	436	my ($path, $toplevel) = @_;
139		437
140	eval {
141	defined $cache
142	&& -M $cache < -M $path
143	&& Storable::retrieve $cache
144	} or do {
145	my %arc;	438	my %arc;
146	my ($more, $prev);	439	my ($more, $prev);
		440	my $comment;
147		441
148	open my $fh, "<:raw", $path	442	open my $fh, "<:raw:perlio:utf8", $path
149	or Carp::croak "$path: $!";	443	or Carp::croak "$path: $!";
150		444
		445	# binmode $fh;
		446
151	my $parse_block; $parse_block = sub {	447	my $parse_block; $parse_block = sub {
152	my %arc = @_;	448	my %arc = @_;
153
154	while (<$fh>) {
155	s/\s+$//;
156	if (/^end$/i) {
157	last;
158	} elsif (/^arch (\S+)$/) {
159	push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1);
160	} elsif (/^lore$/) {
161	while (<$fh>) {
162	last if /^endlore\s*$/i;
163	$arc{lore} .= $_;
164	}
165	} elsif (/^msg$/) {
166	while (<$fh>) {
167	last if /^endmsg\s*$/i;
168	$arc{msg} .= $_;
169	}
170	} elsif (/^(\S+)\s(.)$/) {
171	$arc{lc $1} = $2;
172	} elsif (/^\s*($\|#)/) {
173	#
174	} else {
175	warn "$path: unparsable line '$_' in arch $arc{_name}";
176	}
177	}
178
179	\%arc
180	};
181		449
182	while (<$fh>) {	450	while (<$fh>) {
183	s/\s+$//;	451	s/\s+$//;
184	if (/^more$/i) {	452	if (/^end$/i) {
185	$more = $prev;	453	last;
		454
186	} elsif (/^object (\S+)$/i) {	455	} elsif (/^arch (\S+)$/i) {
187	my $name = $1;	456	push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
188	my $arc = $parse_block->(_name => $name);
189		457
190	if ($more) {	458	} elsif (/^lore$/i) {
191	$more->{more} = $arc;	459	while (<$fh>) {
192	} else {	460	last if /^endlore\s*$/i;
193	$arc{$name} = $arc;	461	$arc{lore} .= $_;
194	}	462	}
195	$prev = $arc;	463	} elsif (/^msg$/i) {
196	$more = undef;	464	while (<$fh>) {
		465	last if /^endmsg\s*$/i;
		466	$arc{msg} .= $_;
		467	}
		468	} elsif (/^anim$/i) {
		469	while (<$fh>) {
		470	last if /^mina\s*$/i;
		471	chomp;
		472	push @{ $arc{anim} }, $_;
		473	}
197	} elsif (/^arch (\S+)$/i) {	474	} elsif (/^(\S+)\s(.)$/) {
198	push @{ $arc{arch} }, normalize_arch $parse_block->(_name => $1);	475	$arc{lc $1} = $2;
199	} elsif (/^\s*($\|#)/) {	476	} elsif (/^\s*#/) {
		477	$arc{_comment} .= "$_\n";
		478
		479	} elsif (/^\s*$/) {
200	#	480	#
201	} else {	481	} else {
202	warn "$path: unparseable top-level line '$_'";	482	warn "$path: unparsable line '$_' in arch $arc{_name}";
203	}
204	}	483	}
205		484	}
206	undef $parse_block; # work around bug in perl not freeing $fh etc.
207
208	Storable::nstore \%arc, $cache
209	if defined $cache;
210		485
211	\%arc	486	\%arc
212	}	487	};
		488
		489	while (<$fh>) {
		490	s/\s+$//;
		491	if (/^more$/i) {
		492	$more = $prev;
		493	} elsif (/^object (\S+)$/i) {
		494	my $name = $1;
		495	my $arc = attr_thaw normalize_object $parse_block->(_name => $name, _comment => $comment);
		496	undef $comment;
		497	delete $arc{_comment} unless length $arc{_comment};
		498	$arc->{_atype} = 'object';
		499
		500	if ($more) {
		501	$more->{more} = $arc;
		502	} else {
		503	$arc{$name} = $arc;
		504	}
		505	$prev = $arc;
		506	$more = undef;
		507	} elsif (/^arch (\S+)$/i) {
		508	my $name = $1;
		509	my $arc = attr_thaw normalize_arch $parse_block->(_name => $name, _comment => $comment);
		510	undef $comment;
		511	delete $arc{_comment} unless length $arc{_comment};
		512	$arc->{_atype} = 'arch';
		513
		514	if ($more) {
		515	$more->{more} = $arc;
		516	} else {
		517	push @{ $arc{arch} }, $arc;
		518	}
		519	$prev = $arc;
		520	$more = undef;
		521	} elsif ($toplevel && /^(\S+)\s+(.*)$/) {
		522	if ($1 eq "lev_array") {
		523	while (<$fh>) {
		524	last if /^endplst\s*$/;
		525	push @{$toplevel->{lev_array}}, $_+0;
		526	}
		527	} else {
		528	$toplevel->{$1} = $2;
		529	}
		530	} elsif (/^\s*#/) {
		531	$comment .= "$_\n";
		532	} elsif (/^\s*($\|#)/) {
		533	#
		534	} else {
		535	die "$path: unparseable top-level line '$_'";
		536	}
		537	}
		538
		539	undef $parse_block; # work around bug in perl not freeing $fh etc.
		540
		541	\%arc
		542	}
		543
		544	sub archlist_to_string {
		545	my ($arch) = @_;
		546
		547	my $str;
		548
		549	my $append; $append = sub {
		550	my %a = %{$_[0]};
		551
		552	Crossfire::attr_freeze \%a;
		553	Crossfire::normalize_arch \%a;
		554
		555	# undo the bit-split we did before
		556	if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) {
		557	$a{attack_movement} = (delete $a{attack_movement_bits_0_3})
		558	\| (delete $a{attack_movement_bits_4_7});
		559	}
		560
		561	if (my $comment = delete $a{_comment}) {
		562	if ($comment =~ /[^\n\s#]/) {
		563	$str .= $comment;
		564	}
		565	}
		566
		567	$str .= ((exists $a{_atype}) ? $a{_atype} : 'arch'). " $a{_name}\n";
		568
		569	my $inv = delete $a{inventory};
		570	my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some
		571	my $anim = delete $a{anim};
		572
		573	if ($a{_atype} eq 'object') {
		574	$str .= join "\n", "anim", @$anim, "mina\n"
		575	if $anim;
		576	}
		577
		578	my @kv;
		579
		580	for ($a{_name} eq "map"
		581	? @Crossfire::FIELD_ORDER_MAP
		582	: @Crossfire::FIELD_ORDER) {
		583	push @kv, [$_, delete $a{$_}]
		584	if exists $a{$_};
		585	}
		586
		587	for (sort keys %a) {
		588	next if /^_/; # ignore our _-keys
		589	push @kv, [$_, delete $a{$_}];
		590	}
		591
		592	for (@kv) {
		593	my ($k, $v) = @$_;
		594
		595	if (my $end = $Crossfire::FIELD_MULTILINE{$k}) {
		596	$v =~ s/\n$//;
		597	$str .= "$k\n$v\n$end\n";
		598	} elsif (exists $Crossfire::FIELD_MOVEMENT{$k}) {
		599	if ($v & ~Crossfire::MOVE_ALL or !$v) {
		600	$str .= "$k $v\n";
		601
		602	} elsif ($v & Crossfire::MOVE_ALLBIT) {
		603	$str .= "$k all";
		604
		605	$str .= " -walk" unless $v & Crossfire::MOVE_WALK;
		606	$str .= " -fly_low" unless $v & Crossfire::MOVE_FLY_LOW;
		607	$str .= " -fly_high" unless $v & Crossfire::MOVE_FLY_HIGH;
		608	$str .= " -swim" unless $v & Crossfire::MOVE_SWIM;
		609	$str .= " -boat" unless $v & Crossfire::MOVE_BOAT;
		610
		611	$str .= "\n";
		612
		613	} else {
		614	$str .= $k;
		615
		616	$str .= " walk" if $v & Crossfire::MOVE_WALK;
		617	$str .= " fly_low" if $v & Crossfire::MOVE_FLY_LOW;
		618	$str .= " fly_high" if $v & Crossfire::MOVE_FLY_HIGH;
		619	$str .= " swim" if $v & Crossfire::MOVE_SWIM;
		620	$str .= " boat" if $v & Crossfire::MOVE_BOAT;
		621
		622	$str .= "\n";
		623	}
		624	} else {
		625	$str .= "$k $v\n";
		626	}
		627	}
		628
		629	if ($inv) {
		630	$append->($_) for @$inv;
		631	}
		632
		633	$str .= "end\n";
		634
		635	if ($a{_atype} eq 'object') {
		636	if ($more) {
		637	$str .= "more\n";
		638	$append->($more) if $more;
		639	} else {
		640	$str .= "\n";
		641	}
		642	}
		643	};
		644
		645	for (@$arch) {
		646	$append->($_);
		647	}
		648
		649	$str
213	}	650	}
214		651
215	# put all archs into a hash with editor_face as it's key	652	# put all archs into a hash with editor_face as it's key
216	# NOTE: the arrays in the hash values are references to	653	# NOTE: the arrays in the hash values are references to
217	# the archs from $ARCH	654	# the archs from $ARCH
218	sub editor_archs {	655	sub editor_archs {
219	my %paths;	656	my %paths;
220		657
221	for (keys %ARCH) {	658	for (keys %ARCH) {
222	my $arch = $ARCH{$_};	659	my $arch = $ARCH{$_};
223	push @{$paths{$arch->{editor_folder}}}, \$arch;	660	push @{$paths{$arch->{editor_folder}}}, $arch;
224	}	661	}
225		662
226	\%paths	663	\%paths
227	}	664	}
228		665
…		…
238	my ($a) = @_;	675	my ($a) = @_;
239		676
240	my $o = $ARCH{$a->{_name}}	677	my $o = $ARCH{$a->{_name}}
241	or return;	678	or return;
242		679
243	my $face = $FACE{$a->{face} \|\| $o->{face}}	680	my $face = $FACE{$a->{face} \|\| $o->{face} \|\| "blank.111"};
		681	unless ($face) {
		682	$face = $FACE{"blank.x11"}
244	or (warn "no face data found for arch '$a->{_name}'"), return;	683	or (warn "no face data found for arch '$a->{_name}'"), return;
		684	}
245		685
246	if ($face->{w} > 1 \|\| $face->{h} > 1) {	686	if ($face->{w} > 1 \|\| $face->{h} > 1) {
247	# bigface	687	# bigface
248	return (0, 0, $face->{w} - 1, $face->{h} - 1);	688	return (0, 0, $face->{w} - 1, $face->{h} - 1);
249		689
…		…
264	# single face	704	# single face
265	return (0, 0, 0, 0);	705	return (0, 0, 0, 0);
266	}	706	}
267	}	707	}
268		708
269	sub init($) {
270	my ($cachedir) = @_;
271
272	return if %ARCH;
273
274	*ARCH = read_arch "$LIB/archetypes", "$cachedir/archetypes.pst";
275	}
276
277	=item $data = arch_attr $arch	709	=item $type = arch_attr $arch
278		710
279	Returns a hashref describing the object and its attributes. It can contain	711	Returns a hashref describing the object and its attributes. It can contain
280	the following keys:	712	the following keys:
281		713
282	name the name, suitable for display purposes	714	name the name, suitable for display purposes
283	ignore	715	ignore
284	attr	716	attr
285	desc	717	desc
286	use	718	use
287	section => [name => \%attr, name => \%attr]	719	section => [name => \%attr, name => \%attr]
		720	import
288		721
289	=cut	722	=cut
290		723
291	sub arch_attr($) {	724	sub arch_attr($) {
292	my ($arch) = @_;	725	my ($obj) = @_;
293		726
294	require Crossfire::Data;	727	require Crossfire::Data;
295		728
296	my %attr;	729	my $root;
		730	my $attr = { };
		731
		732	my $arch = $ARCH{ $obj->{_name} };
		733	my $type = $obj->{type} \|\| $arch->{type};
297		734
298	if ($arch->{type} > 0) {	735	if ($type > 0) {
299	%attr = %{ $Crossfire::Data::ATTR{$arch->{type}+0} \|\| {} };	736	$root = $Crossfire::Data::ATTR{$type};
300	} else {	737	} else {
301	die;	738	my %a = (%$arch, %$obj);
		739
		740	if ($a{is_floor} && !$a{alive}) {
		741	$root = $Crossfire::Data::TYPE{Floor};
		742	} elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) {
		743	$root = $Crossfire::Data::TYPE{"Monster & NPC"};
		744	} elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) {
		745	$root = $Crossfire::Data::TYPE{Wall};
		746	} elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) {
		747	$root = $Crossfire::Data::TYPE{"Weak Wall"};
		748	} else {
		749	$root = $Crossfire::Data::TYPE{Misc};
		750	}
		751	}
		752
		753	my @import = ($root);
		754
		755	unshift @import, \%Crossfire::Data::DEFAULT_ATTR
		756	unless $type == 116;
		757
		758	my (%ignore);
		759	my (@section_order, %section, @attr_order);
		760
		761	while (my $type = shift @import) {
		762	push @import, @{$type->{import} \|\| []};
		763
		764	$attr->{$_} \|\|= $type->{$_}
		765	for qw(name desc use);
		766
		767	for (@{$type->{ignore} \|\| []}) {
		768	$ignore{$_}++ for ref $_ ? @$_ : $_;
		769	}
		770
		771	for ([general => ($type->{attr} \|\| [])], @{$type->{section} \|\| []}) {
		772	my ($name, $attr) = @$_;
		773	push @section_order, $name;
		774	for (@$attr) {
		775	my ($k, $v) = @$_;
		776	push @attr_order, $k;
		777	$section{$name}{$k} \|\|= $v;
		778	}
		779	}
		780	}
		781
		782	$attr->{section} = [
		783	map !exists $section{$_} ? () : do {
		784	my $attr = delete $section{$_};
		785
		786	[
		787	$_,
		788	map exists $attr->{$_} && !$ignore{$_}
		789	? [$_ => delete $attr->{$_}] : (),
		790	@attr_order
		791	]
		792	},
		793
		794	exists $section{$_} ? [$_ => delete $section{$_}] : (),
		795	@section_order
		796	];
		797
		798	$attr
		799	}
		800
		801	sub cache_file($$&&) {
		802	my ($src, $cache, $load, $create) = @_;
		803
		804	my ($size, $mtime) = (stat $src)[7,9]
		805	or Carp::croak "$src: $!";
		806
		807	if (-e $cache) {
		808	my $ref = eval { load_ref $cache };
		809
		810	if ($ref->{version} == 1
		811	&& $ref->{size} == $size
		812	&& $ref->{mtime} == $mtime
		813	&& eval { $load->($ref->{data}); 1 }) {
		814	return;
		815	}
		816	}
		817
		818	my $ref = {
		819	version => 1,
		820	size => $size,
		821	mtime => $mtime,
		822	data => $create->(),
302	}	823	};
303		824
304	use PApp::Util;	825	$load->($ref->{data});
305	warn PApp::Util::dumpval \%attr;
306	}
307		826
308	sub arch_edit_sections {	827	save_ref $ref, $cache;
309	# if (edit_type == IGUIConstants.TILE_EDIT_NONE)	828	}
310	# edit_type = 0;	829
311	# else if (edit_type != 0) {	830	=item set_libdir $path
312	# // all flags from 'check_type' must be unset in this arch because they get recalculated now	831
313	# edit_type &= ~check_type;	832	Sets the library directory to the given path
		833	(default: $ENV{CROSSFIRE_LIBDIR}).
		834
		835	You have to (re-)load the archetypes and tilecache manually after steting
		836	the library path.
		837
		838	=cut
		839
		840	sub set_libdir($) {
		841	$LIB = $_[0];
		842	}
		843
		844	=item load_archetypes
		845
		846	(Re-)Load archetypes into %ARCH.
		847
		848	=cut
		849
		850	sub load_archetypes() {
		851	cache_file "$LIB/archetypes", "$VARDIR/archetypes.pst", sub {
		852	*ARCH = $_[0];
		853	}, sub {
		854	read_arch "$LIB/archetypes"
		855	};
		856	}
		857
		858	=item load_tilecache
		859
		860	(Re-)Load %TILE and %FACE.
		861
		862	=cut
		863
		864	sub load_tilecache() {
		865	require Gtk2;
		866
		867	cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub {
		868	$TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
		869	or die "$VARDIR/tilecache.png: $!";
		870	*FACE = $_[0];
		871	}, sub {
		872	my $tile = read_pak "$LIB/crossfire.0";
		873
		874	my %cache;
		875
		876	my $idx = 0;
		877
		878	for my $name (sort keys %$tile) {
		879	my $pb = new Gtk2::Gdk::PixbufLoader;
		880	$pb->write ($tile->{$name});
		881	$pb->close;
		882	my $pb = $pb->get_pixbuf;
		883
		884	my $tile = $cache{$name} = {
		885	pb => $pb,
		886	idx => $idx,
		887	w => int $pb->get_width / TILESIZE,
		888	h => int $pb->get_height / TILESIZE,
		889	};
		890
		891
		892	$idx += $tile->{w} * $tile->{h};
314	# }	893	}
315	#	894
		895	my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
		896
		897	while (my ($name, $tile) = each %cache) {
		898	my $tpb = delete $tile->{pb};
		899	my $ofs = $tile->{idx};
		900
		901	for my $x (0 .. $tile->{w} - 1) {
		902	for my $y (0 .. $tile->{h} - 1) {
		903	my $idx = $ofs + $x + $y * $tile->{w};
		904	$tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
		905	$pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
		906	}
		907	}
316	# }	908	}
317	# if ((check_type & IGUIConstants.TILE_EDIT_MONSTER) != 0 &&
318	# getAttributeValue("alive", defarch) == 1 &&
319	# (getAttributeValue("monster", defarch) == 1 \|\|
320	# getAttributeValue("generator", defarch) == 1)) {
321	# // Monster: monsters/npcs/generators
322	# edit_type \|= IGUIConstants.TILE_EDIT_MONSTER;
323	# }
324	# if ((check_type & IGUIConstants.TILE_EDIT_WALL) != 0 &&
325	# arch_type == 0 && getAttributeValue("no_pass", defarch) == 1) {
326	# // Walls
327	# edit_type \|= IGUIConstants.TILE_EDIT_WALL;
328	# }
329	# if ((check_type & IGUIConstants.TILE_EDIT_CONNECTED) != 0 &&
330	# getAttributeValue("connected", defarch) != 0) {
331	# // Connected Objects
332	# edit_type \|= IGUIConstants.TILE_EDIT_CONNECTED;
333	# }
334	# if ((check_type & IGUIConstants.TILE_EDIT_EXIT) != 0 &&
335	# arch_type == 66 \|\| arch_type == 41 \|\| arch_type == 95) {
336	# // Exit: teleporter/exit/trapdoors
337	# edit_type \|= IGUIConstants.TILE_EDIT_EXIT;
338	# }
339	# if ((check_type & IGUIConstants.TILE_EDIT_TREASURE) != 0 &&
340	# getAttributeValue("no_pick", defarch) == 0 && (arch_type == 4 \|\|
341	# arch_type == 5 \|\| arch_type == 36 \|\| arch_type == 60 \|\|
342	# arch_type == 85 \|\| arch_type == 111 \|\| arch_type == 123 \|\|
343	# arch_type == 124 \|\| arch_type == 130)) {
344	# // Treasure: randomtreasure/money/gems/potions/spellbooks/scrolls
345	# edit_type \|= IGUIConstants.TILE_EDIT_TREASURE;
346	# }
347	# if ((check_type & IGUIConstants.TILE_EDIT_DOOR) != 0 &&
348	# arch_type == 20 \|\| arch_type == 23 \|\| arch_type == 26 \|\|
349	# arch_type == 91 \|\| arch_type == 21 \|\| arch_type == 24) {
350	# // Door: door/special door/gates + keys
351	# edit_type \|= IGUIConstants.TILE_EDIT_DOOR;
352	# }
353	# if ((check_type & IGUIConstants.TILE_EDIT_EQUIP) != 0 &&
354	# getAttributeValue("no_pick", defarch) == 0 && ((arch_type >= 13 &&
355	# arch_type <= 16) \|\| arch_type == 33 \|\| arch_type == 34 \|\|
356	# arch_type == 35 \|\| arch_type == 39 \|\| arch_type == 70 \|\|
357	# arch_type == 87 \|\| arch_type == 99 \|\| arch_type == 100 \|\|
358	# arch_type == 104 \|\| arch_type == 109 \|\| arch_type == 113 \|\|
359	# arch_type == 122 \|\| arch_type == 3)) {
360	# // Equipment: weapons/armour/wands/rods
361	# edit_type \|= IGUIConstants.TILE_EDIT_EQUIP;
362	# }
363	#
364	# return(edit_type);
365	#
366	#
367	}
368		909
369	$CACHEDIR \|\|= "$ENV{HOME}/.crossfire";	910	$pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
370		911
371	init $CACHEDIR;	912	\%cache
		913	};
		914	}
372		915
373	=head1 AUTHOR	916	=head1 AUTHOR
374		917
375	Marc Lehmann <schmorp@schmorp.de>	918	Marc Lehmann <schmorp@schmorp.de>
376	http://home.schmorp.de/	919	http://home.schmorp.de/

Diff Legend

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

Comparing deliantra/Deliantra/Deliantra.pm (file contents): Revision 1.17 by root, Wed Feb 22 22:36:45 2006 UTC vs. Revision 1.88 by root, Sun Feb 18 20:20:58 2007 UTC

Diff Legend

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.17 by root, Wed Feb 22 22:36:45 2006 UTC vs.
Revision 1.88 by root, Sun Feb 18 20:20:58 2007 UTC