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

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.82 by root, Tue Feb 6 23:53:26 2007 UTC vs.
Revision 1.147 by root, Wed Nov 7 12:04:36 2018 UTC

…		…
1	=head1 NAME	1	=head1 NAME
2		2
3	Crossfire - Crossfire maphandling	3	Deliantra - Deliantra suppport module to read/write archetypes, maps etc.
		4
		5	=over 4
4		6
5	=cut	7	=cut
6		8
7	package Crossfire;	9	package Deliantra;
8		10
9	our $VERSION = '0.96';	11	our $VERSION = '2.01';
10		12
11	use strict;	13	use common::sense;
12		14
13	use base 'Exporter';	15	use base 'Exporter';
14		16
15	use Carp ();	17	use Carp ();
16	use File::Spec;	18	use File::Spec;
17	use List::Util qw(min max);	19	use List::Util qw(min max);
18	use Storable qw(freeze thaw);	20	use Storable qw(freeze thaw);
19		21
20	our @EXPORT = qw(	22	our @EXPORT = qw(
21	read_pak read_arch ARCH TILESIZE $TILE FACE editor_archs arch_extents	23	read_pak read_arch
		24	ARCH $TILE FACE *FACEDATA
		25	TILESIZE CACHESTRIDE
		26	editor_archs arch_extents
22	);	27	);
23		28
24	use JSON::Syck (); #TODO#d# replace by JSON::PC when it becomes available == working	29	use JSON::XS qw(decode_json encode_json);
25		30
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
36	our $LIB = $ENV{CROSSFIRE_LIBDIR};	31	our $LIB = $ENV{DELIANTRA_LIBDIR};
37		32
38	our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire"	33	our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.deliantra"
39	: $ENV{AppData} ? "$ENV{APPDATA}/crossfire"	34	: $ENV{AppData} ? "$ENV{APPDATA}/deliantra"
40	: File::Spec->tmpdir . "/crossfire";	35	: File::Spec->tmpdir . "/deliantra";
41		36
42	mkdir $VARDIR, 0777;	37	mkdir $VARDIR, 0777;
43		38
44	sub TILESIZE (){ 32 }	39	sub TILESIZE (){ 32 }
		40	sub CACHESTRIDE (){ 64 }
45		41
46	our %ARCH;	42	our %ARCH;
		43	our %FACE; # face32
47	our %FACE;	44	our %FACEDATA;
48	our $TILE;	45	our $TILE;
49		46
50	our %FIELD_MULTILINE = (	47	our %FIELD_MULTILINE = (
51	msg => "endmsg",	48	msg => "endmsg",
52	lore => "endlore",	49	lore => "endlore",
58	qw(move_type move_block move_allow move_on move_off move_slow);	55	qw(move_type move_block move_allow move_on move_off move_slow);
59		56
60	# same as in server save routine, to (hopefully) be compatible	57	# same as in server save routine, to (hopefully) be compatible
61	# to the other editors.	58	# to the other editors.
62	our @FIELD_ORDER_MAP = (qw(	59	our @FIELD_ORDER_MAP = (qw(
		60	file_format_version
63	name attach swap_time reset_timeout fixed_resettime difficulty region	61	name attach swap_time reset_timeout fixed_resettime difficulty
		62	region music
64	shopitems shopgreed shopmin shopmax shoprace	63	shopitems shopgreed shopmin shopmax shoprace
65	darkness width height enter_x enter_y msg maplore	64	darkness width height enter_x enter_y msg maplore
66	unique template	65	unique template
67	outdoor temp pressure humid windspeed winddir sky nosmooth	66	outdoor temp pressure humid windspeed winddir sky nosmooth
68	tile_path_1 tile_path_2 tile_path_3 tile_path_4	67	tile_path_1 tile_path_2 tile_path_3 tile_path_4
69	));	68	));
70		69
71	our @FIELD_ORDER = (qw(	70	our @FIELD_ORDER = (qw(
		71	inherit
		72
72	elevation	73	elevation
73		74
74	name name_pl custom_name attach title race	75	name name_pl custom_name attach title race
75	slaying skill msg lore other_arch face	76	slaying skill msg lore other_arch
76	#todo-events	77	sound sound_destroy face animation is_animated
77	animation is_animated	78	magicmap glyph smoothlevel smoothface
78	str dex con wis pow cha int	79	str dex con wis pow cha int
79	hp maxhp sp maxsp grace maxgrace	80	hp maxhp sp maxsp grace maxgrace
80	exp perm_exp expmul	81	exp perm_exp expmul
81	food dam luck wc ac x y speed speed_left move_state attack_movement	82	food dam luck wc ac x y speed speed_left move_state attack_movement
82	nrof level direction type subtype attacktype	83	nrof level direction type subtype attacktype
…		…
90	resist_life_stealing resist_disease	91	resist_life_stealing resist_disease
91		92
92	path_attuned path_repelled path_denied material materialname	93	path_attuned path_repelled path_denied material materialname
93	value carrying weight invisible state magic	94	value carrying weight invisible state magic
94	last_heal last_sp last_grace last_eat	95	last_heal last_sp last_grace last_eat
95	connected glow_radius randomitems npx_status npc_program	96	connected glow_radius randomitems tresure_env npx_status npc_program
96	run_away pick_up container will_apply smoothlevel	97	run_away pick_up container will_apply smoothlevel
97	current_weapon_script weapontype tooltype elevation client_type	98	current_weapon_script weapontype tooltype elevation client_type
98	item_power duration range	99	item_power duration range
99	range_modifier duration_modifier dam_modifier gen_sp_armour	100	range_modifier duration_modifier dam_modifier gen_sp_armour
100	move_type move_block move_allow move_on move_off move_on move_slow move_slow_penalty	101	move_type move_block move_allow move_on move_off move_on move_slow move_slow_penalty
…		…
111	known_magical known_cursed can_use_skill been_applied has_ready_scroll	112	known_magical known_cursed can_use_skill been_applied has_ready_scroll
112	can_use_rod can_use_horn make_invisible inv_locked is_wooded is_hilly	113	can_use_rod can_use_horn make_invisible inv_locked is_wooded is_hilly
113	has_ready_skill has_ready_weapon no_skill_ident is_blind can_see_in_dark	114	has_ready_skill has_ready_weapon no_skill_ident is_blind can_see_in_dark
114	is_cauldron is_dust no_steal one_hit berserk neutral no_attack no_damage	115	is_cauldron is_dust no_steal one_hit berserk neutral no_attack no_damage
115	activate_on_push activate_on_release is_water use_content_on_gen is_buildable	116	activate_on_push activate_on_release is_water use_content_on_gen is_buildable
		117	precious
116		118
117	body_range body_arm body_torso body_head body_neck body_skill	119	body_range body_arm body_torso body_head body_neck body_skill
118	body_finger body_shoulder body_foot body_hand body_wrist body_waist	120	body_finger body_shoulder body_foot body_hand body_wrist body_waist
119	));	121	));
120		122
…		…
131	trigger => 10,	133	trigger => 10,
132	close => 11,	134	close => 11,
133	timer => 12,	135	timer => 12,
134	);	136	);
135		137
		138	# 1 up 2 right 4 down 8 left
		139	our %WALLDIR = (
		140	0 => 0,
		141	1_2 => 1,
		142	1_4 => 2,
		143	2_2_1 => 3,
		144	1_1 => 4,
		145	2_1_1 => 5,
		146	2_2_2 => 6,
		147	3_2 => 7,
		148	1_3 => 8,
		149	2_2_4 => 9,
		150	2_1_2 => 10,
		151	3_1 => 11,
		152	2_2_3 => 12,
		153	3_4 => 13,
		154	3_3 => 14,
		155	4 => 15,
		156	);
		157
136	sub MOVE_WALK (){ 0x01 }	158	sub MOVE_WALK (){ 0x01 }
137	sub MOVE_FLY_LOW (){ 0x02 }	159	sub MOVE_FLY_LOW (){ 0x02 }
138	sub MOVE_FLY_HIGH (){ 0x04 }	160	sub MOVE_FLY_HIGH (){ 0x04 }
139	sub MOVE_FLYING (){ 0x06 }	161	sub MOVE_FLYING (){ 0x06 }
140	sub MOVE_SWIM (){ 0x08 }	162	sub MOVE_SWIM (){ 0x08 }
141	sub MOVE_BOAT (){ 0x10 }	163	sub MOVE_BOAT (){ 0x10 }
		164	sub MOVE_SHIP (){ 0x20 }
142	sub MOVE_KNOWN (){ 0x1f } # all of above	165	sub MOVE_KNOWN (){ 0x3f } # all of above
143	sub MOVE_ALLBIT (){ 0x10000 }
144	sub MOVE_ALL (){ 0x1001f } # very special value, more PITA	166	sub MOVE_ALL (){ 0x10000 } # very special value
		167
		168	our %MOVE_TYPE = (
		169	walk => MOVE_WALK,
		170	fly_low => MOVE_FLY_LOW,
		171	fly_high => MOVE_FLY_HIGH,
		172	flying => MOVE_FLYING,
		173	swim => MOVE_SWIM,
		174	boat => MOVE_BOAT,
		175	ship => MOVE_SHIP,
		176	all => MOVE_ALL,
		177	);
		178
		179	our @MOVE_TYPE = qw(all walk flying fly_low fly_high swim boat ship);
		180
		181	{
		182	package Deliantra::MoveType;
		183
		184	use overload
		185	'=' => sub { bless [@{$_[0]}], ref $_[0] },
		186	'""' => \&as_string,
		187	'>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef },
		188	'<=' => sub {
		189	($_[0][0] & $MOVE_TYPE{$_[1]}) == $MOVE_TYPE{$_[1]}
		190	? $_[0][1] & $MOVE_TYPE{$_[1]}
		191	: undef
		192	},
		193	'+=' => sub { $_[0][0] \|= $MOVE_TYPE{$_[1]}; $_[0][1] \|= $MOVE_TYPE{$_[1]}; &normalise },
		194	'-=' => sub { $_[0][0] \|= $MOVE_TYPE{$_[1]}; $_[0][1] &= ~$MOVE_TYPE{$_[1]}; &normalise },
		195	'/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise },
		196	'x=' => sub { # toggle between off, + and -
		197	my $cur = $_[0] >= $_[1];
		198	if (!defined $cur) {
		199	if ($_[0] >= "all") {
		200	$_[0] -= $_[1];
		201	} else {
		202	$_[0] += $_[1];
		203	}
		204	} elsif ($cur) {
		205	$_[0] -= $_[1];
		206	} else {
		207	$_[0] /= $_[1];
		208	}
		209
		210	$_[0]
		211	},
		212	'eq' => sub { "$_[0]" eq "$_[1]" },
		213	'ne' => sub { "$_[0]" ne "$_[1]" },
		214	;
		215
		216	sub TO_JSON {
		217	$_[0][0]
		218	}
		219	}
		220
		221	sub Deliantra::MoveType::new {
		222	my ($class, $string) = @_;
		223
		224	my $mask;
		225	my $value;
		226
		227	if ($string =~ /^\s\d+\s$/) {
		228	$mask = MOVE_ALL;
		229	$value = $string+0;
		230	} else {
		231	for (split /\s+/, lc $string) {
		232	if (s/^-//) {
		233	$mask \|= $MOVE_TYPE{$_};
		234	$value &= ~$MOVE_TYPE{$_};
		235	} else {
		236	$mask \|= $MOVE_TYPE{$_};
		237	$value \|= $MOVE_TYPE{$_};
		238	}
		239	}
		240	}
		241
		242	(bless [$mask, $value], $class)->normalise
		243	}
		244
		245	sub Deliantra::MoveType::normalise {
		246	my ($self) = @_;
		247
		248	if ($self->[0] & MOVE_ALL) {
		249	my $mask = ~(($self->[1] & MOVE_ALL ? $self->[1] : ~$self->[1]) & $self->[0] & ~MOVE_ALL);
		250	$self->[0] &= $mask;
		251	$self->[1] &= $mask;
		252	}
		253
		254	$self->[1] &= $self->[0];
		255
		256	$self
		257	}
		258
		259	sub Deliantra::MoveType::as_string {
		260	my ($self) = @_;
		261
		262	my @res;
		263
		264	my ($mask, $value) = @$self;
		265
		266	for (@Deliantra::MOVE_TYPE) {
		267	my $bit = $Deliantra::MOVE_TYPE{$_};
		268	if (($mask & $bit) == $bit && (($value & $bit) == $bit \|\| ($value & $bit) == 0)) {
		269	$mask &= ~$bit;
		270	push @res, $value & $bit ? $_ : "-$_";
		271	}
		272	}
		273
		274	join " ", @res
		275	}
145		276
146	sub load_ref($) {	277	sub load_ref($) {
147	my ($path) = @_;	278	my ($path) = @_;
148		279
149	open my $fh, "<:raw:perlio", $path	280	open my $fh, "<:raw:perlio", $path
…		…
213	adamant => 256,	344	adamant => 256,
214	liquid => 512,	345	liquid => 512,
215	tin => 1024,	346	tin => 1024,
216	bone => 2048,	347	bone => 2048,
217	ice => 4096,	348	ice => 4096,
		349
		350	# guesses
		351	runestone => 12,
		352	bronze => 18,
		353	"ancient wood" => 20,
		354	glass => 36,
		355	marble => 66,
		356	ice => 68,
		357	stone => 70,
		358	stone => 80,
		359	cloth => 136,
		360	ironwood => 144,
		361	adamantium => 258,
		362	glacium => 260,
		363	blood => 544,
218	;	364	;
219		365
220	# object as in "Object xxx", i.e. archetypes	366	# object as in "Object xxx", i.e. archetypes
221	sub normalize_object($) {	367	sub normalize_object($) {
222	my ($ob) = @_;	368	my ($ob) = @_;
		369
		370	delete $ob->{editable}; # deprecated
223		371
224	# convert material bitset to materialname, if possible	372	# convert material bitset to materialname, if possible
225	if (exists $ob->{material}) {	373	if (exists $ob->{material}) {
226	if (!$ob->{material}) {	374	if (!$ob->{material}) {
227	delete $ob->{material};	375	delete $ob->{material};
…		…
230	delete $ob->{material};	378	delete $ob->{material};
231	} else {	379	} else {
232	warn "object $ob->{_name} has both materialname ($ob->{materialname}) and material ($ob->{material}) set.\n";	380	warn "object $ob->{_name} has both materialname ($ob->{materialname}) and material ($ob->{material}) set.\n";
233	delete $ob->{material}; # assume materilname is more specific and nuke material	381	delete $ob->{material}; # assume materilname is more specific and nuke material
234	}	382	}
		383	} elsif (my $name = $MATERIAL{$ob->{material}}) {
		384	delete $ob->{material};
		385	$ob->{materialname} = $name;
235	} else {	386	} else {
236	if (my $name = $MATERIAL{$ob->{material}}) {	387	warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n";
237	delete $ob->{material};
238	$ob->{materialname} = $name;
239	}	388	}
240	}
241	}	389	}
		390
		391	# check whether attachment is the same as in the archetype
		392	if (exists $ob->{attach}) {
		393	my $arch = $ARCH{$ob->{_name}};
		394	my $js = JSON::XS->new->utf8->canonical (1);
		395
		396	if (defined $arch->{attach}
		397	&& $js->encode ($js->decode ($ob->{attach})) eq $js->encode ($arch->{attach})) {
		398	delete $ob->{attach}
		399	}
		400	}
		401
		402	# color_fg is used as default for magicmap if magicmap does not exist
		403	$ob->{magicmap} \|\|= delete $ob->{color_fg} if exists $ob->{color_fg};
242		404
243	# nuke outdated or never supported fields	405	# nuke outdated or never supported fields
244	delete @$ob{qw(	406	delete @$ob{qw(
245	can_knockback can_parry can_impale can_cut can_dam_armour	407	can_knockback can_parry can_impale can_cut can_dam_armour
246	can_apply pass_thru can_pass_thru	408	can_apply pass_thru can_pass_thru color_bg color_fg
247	)};	409	)};
248		410
249	if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; }	411	if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; }
250	if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; }	412	if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; }
251	if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; }	413	if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; }
252		414
253	# convert movement strings to bitsets	415	# convert movement strings to bitsets
254	for my $attr (keys %FIELD_MOVEMENT) {	416	for my $attr (keys %FIELD_MOVEMENT) {
255	next unless exists $ob->{$attr};	417	next unless exists $ob->{$attr};
256		418
257	$ob->{$attr} = MOVE_ALL if $ob->{$attr} == 255; #d# compatibility	419	$ob->{$attr} = new Deliantra::MoveType $ob->{$attr};
258
259	next if $ob->{$attr} =~ /^\d+$/;
260
261	my $flags = 0;
262
263	# assume list
264	for my $flag (map lc, split /\s+/, $ob->{$attr}) {
265	$flags \|= MOVE_WALK if $flag eq "walk";
266	$flags \|= MOVE_FLY_LOW if $flag eq "fly_low";
267	$flags \|= MOVE_FLY_HIGH if $flag eq "fly_high";
268	$flags \|= MOVE_FLYING if $flag eq "flying";
269	$flags \|= MOVE_SWIM if $flag eq "swim";
270	$flags \|= MOVE_BOAT if $flag eq "boat";
271	$flags \|= MOVE_ALL if $flag eq "all";
272
273	$flags &= ~MOVE_WALK if $flag eq "-walk";
274	$flags &= ~MOVE_FLY_LOW if $flag eq "-fly_low";
275	$flags &= ~MOVE_FLY_HIGH if $flag eq "-fly_high";
276	$flags &= ~MOVE_FLYING if $flag eq "-flying";
277	$flags &= ~MOVE_SWIM if $flag eq "-swim";
278	$flags &= ~MOVE_BOAT if $flag eq "-boat";
279	$flags &= ~MOVE_ALL if $flag eq "-all";
280	}
281
282	$ob->{$attr} = $flags;
283	}	420	}
284		421
285	# convert outdated movement flags to new movement sets	422	# convert outdated movement flags to new movement sets
286	if (defined (my $v = delete $ob->{no_pass})) {	423	if (defined (my $v = delete $ob->{no_pass})) {
287	$ob->{move_block} = $v ? MOVE_ALL : 0;	424	$ob->{move_block} = new Deliantra::MoveType $v ? "all" : "0";
288	}	425	}
289	if (defined (my $v = delete $ob->{slow_move})) {	426	if (defined (my $v = delete $ob->{slow_move})) {
290	$ob->{move_slow} \|= MOVE_WALK;	427	$ob->{move_slow} += "walk";
291	$ob->{move_slow_penalty} = $v;	428	$ob->{move_slow_penalty} = $v;
292	}	429	}
293	if (defined (my $v = delete $ob->{walk_on})) {	430	if (defined (my $v = delete $ob->{walk_on})) {
294	$ob->{move_on} = MOVE_ALL unless exists $ob->{move_on};	431	$ob->{move_on} \|\|= new Deliantra::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" }
295	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_WALK
296	: $ob->{move_on} & ~MOVE_WALK;
297	}	432	}
298	if (defined (my $v = delete $ob->{walk_off})) {	433	if (defined (my $v = delete $ob->{walk_off})) {
299	$ob->{move_off} = MOVE_ALL unless exists $ob->{move_off};	434	$ob->{move_off} \|\|= new Deliantra::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" }
300	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_WALK
301	: $ob->{move_off} & ~MOVE_WALK;
302	}	435	}
303	if (defined (my $v = delete $ob->{fly_on})) {	436	if (defined (my $v = delete $ob->{fly_on})) {
304	$ob->{move_on} = MOVE_ALL unless exists $ob->{move_on};	437	$ob->{move_on} \|\|= new Deliantra::MoveType; if ($v) { $ob->{move_on} += "fly_low" } else { $ob->{move_on} -= "fly_low" }
305	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_FLY_LOW
306	: $ob->{move_on} & ~MOVE_FLY_LOW;
307	}	438	}
308	if (defined (my $v = delete $ob->{fly_off})) {	439	if (defined (my $v = delete $ob->{fly_off})) {
309	$ob->{move_off} = MOVE_ALL unless exists $ob->{move_off};	440	$ob->{move_off} \|\|= new Deliantra::MoveType; if ($v) { $ob->{move_off} += "fly_low" } else { $ob->{move_off} -= "fly_low" }
310	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_FLY_LOW
311	: $ob->{move_off} & ~MOVE_FLY_LOW;
312	}	441	}
313	if (defined (my $v = delete $ob->{flying})) {	442	if (defined (my $v = delete $ob->{flying})) {
314	$ob->{move_type} = MOVE_ALL unless exists $ob->{move_type};	443	$ob->{move_type} \|\|= new Deliantra::MoveType; if ($v) { $ob->{move_type} += "fly_low" } else { $ob->{move_type} -= "fly_low" }
315	$ob->{move_type} = $v ? $ob->{move_type} \| MOVE_FLY_LOW
316	: $ob->{move_type} & ~MOVE_FLY_LOW;
317	}	444	}
318		445
319	# convert idiotic event_xxx things into objects	446	# convert idiotic event_xxx things into objects
320	while (my ($event, $subtype) = each %EVENT_TYPE) {	447	while (my ($event, $subtype) = each %EVENT_TYPE) {
321	if (exists $ob->{"event_${event}_plugin"}) {	448	if (exists $ob->{"event_${event}_plugin"}) {
…		…
337	# arch as in "arch xxx", ie.. objects	464	# arch as in "arch xxx", ie.. objects
338	sub normalize_arch($) {	465	sub normalize_arch($) {
339	my ($ob) = @_;	466	my ($ob) = @_;
340		467
341	normalize_object $ob;	468	normalize_object $ob;
		469
		470	return if $ob->{_atype} eq "object";
342		471
343	my $arch = $ARCH{$ob->{_name}}	472	my $arch = $ARCH{$ob->{_name}}
344	or (warn "$ob->{_name}: no such archetype", return $ob);	473	or (warn "$ob->{_name}: no such archetype", return $ob);
345		474
346	if ($arch->{type} == 22) { # map	475	if ($arch->{type} == 22) { # map
…		…
382	}	511	}
383		512
384	sub attr_thaw($) {	513	sub attr_thaw($) {
385	my ($ob) = @_;	514	my ($ob) = @_;
386		515
387	$ob->{attach} = from_json $ob->{attach}	516	$ob->{attach} = decode_json $ob->{attach}
388	if exists $ob->{attach};	517	if exists $ob->{attach};
389		518
390	$ob	519	$ob
391	}	520	}
392		521
393	sub attr_freeze($) {	522	sub attr_freeze($) {
394	my ($ob) = @_;	523	my ($ob) = @_;
395		524
396	$ob->{attach} = Crossfire::to_json $ob->{attach}	525	$ob->{attach} = JSON::XS->new->utf8->canonical->encode ($ob->{attach})
397	if exists $ob->{attach};	526	if exists $ob->{attach};
398		527
399	$ob	528	$ob
400	}	529	}
401		530
…		…
421		550
422	my %arc;	551	my %arc;
423	my ($more, $prev);	552	my ($more, $prev);
424	my $comment;	553	my $comment;
425		554
426	open my $fh, "<:raw:perlio:utf8", $path	555	open my $fh, "<:utf8", $path
427	or Carp::croak "$path: $!";	556	or Carp::croak "$path: $!";
428		557
429	# binmode $fh;	558	# binmode $fh;
430		559
431	my $parse_block; $parse_block = sub {	560	my $parse_block; $parse_block = sub {
…		…
531	my $str;	660	my $str;
532		661
533	my $append; $append = sub {	662	my $append; $append = sub {
534	my %a = %{$_[0]};	663	my %a = %{$_[0]};
535		664
536	Crossfire::attr_freeze \%a;	665	Deliantra::attr_freeze \%a;
537	Crossfire::normalize_arch \%a;	666	Deliantra::normalize_arch \%a;
538		667
539	# undo the bit-split we did before	668	# undo the bit-split we did before
540	if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) {	669	if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) {
541	$a{attack_movement} = (delete $a{attack_movement_bits_0_3})	670	$a{attack_movement} = (delete $a{attack_movement_bits_0_3})
542	\| (delete $a{attack_movement_bits_4_7});	671	\| (delete $a{attack_movement_bits_4_7});
…		…
552		681
553	my $inv = delete $a{inventory};	682	my $inv = delete $a{inventory};
554	my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some	683	my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some
555	my $anim = delete $a{anim};	684	my $anim = delete $a{anim};
556		685
		686	if ($a{_atype} eq 'object') {
		687	$str .= join "\n", "anim", @$anim, "mina\n"
		688	if $anim;
		689	}
		690
557	my @kv;	691	my @kv;
558		692
559	for ($a{_name} eq "map"	693	for ($a{_name} eq "map"
560	? @Crossfire::FIELD_ORDER_MAP	694	? @Deliantra::FIELD_ORDER_MAP
561	: @Crossfire::FIELD_ORDER) {	695	: @Deliantra::FIELD_ORDER) {
562	push @kv, [$_, delete $a{$_}]	696	push @kv, [$_, delete $a{$_}]
563	if exists $a{$_};	697	if exists $a{$_};
564	}	698	}
565		699
566	for (sort keys %a) {	700	for (sort keys %a) {
…		…
569	}	703	}
570		704
571	for (@kv) {	705	for (@kv) {
572	my ($k, $v) = @$_;	706	my ($k, $v) = @$_;
573		707
574	if (my $end = $Crossfire::FIELD_MULTILINE{$k}) {	708	if (my $end = $Deliantra::FIELD_MULTILINE{$k}) {
575	$v =~ s/\n$//;	709	$v =~ s/\n$//;
576	$str .= "$k\n$v\n$end\n";	710	$str .= "$k\n$v\n$end\n";
577	} elsif (exists $Crossfire::FIELD_MOVEMENT{$k}) {
578	if ($v & ~Crossfire::MOVE_ALL or !$v) {
579	$str .= "$k $v\n";
580
581	} elsif ($v & Crossfire::MOVE_ALLBIT) {
582	$str .= "$k all";
583
584	$str .= " -walk" unless $v & Crossfire::MOVE_WALK;
585	$str .= " -fly_low" unless $v & Crossfire::MOVE_FLY_LOW;
586	$str .= " -fly_high" unless $v & Crossfire::MOVE_FLY_HIGH;
587	$str .= " -swim" unless $v & Crossfire::MOVE_SWIM;
588	$str .= " -boat" unless $v & Crossfire::MOVE_BOAT;
589
590	$str .= "\n";
591
592	} else {
593	$str .= $k;
594
595	$str .= " walk" if $v & Crossfire::MOVE_WALK;
596	$str .= " fly_low" if $v & Crossfire::MOVE_FLY_LOW;
597	$str .= " fly_high" if $v & Crossfire::MOVE_FLY_HIGH;
598	$str .= " swim" if $v & Crossfire::MOVE_SWIM;
599	$str .= " boat" if $v & Crossfire::MOVE_BOAT;
600
601	$str .= "\n";
602	}
603	} else {	711	} else {
604	$str .= "$k $v\n";	712	$str .= "$k $v\n";
605	}	713	}
606	}	714	}
607		715
608	if ($inv) {	716	if ($inv) {
609	$append->($_) for @$inv;	717	$append->($_) for @$inv;
610	}
611
612	if ($a{_atype} eq 'object') {
613	$str .= join "\n", "anim", @$anim, "mina\n"
614	if $anim;
615	}	718	}
616		719
617	$str .= "end\n";	720	$str .= "end\n";
618		721
619	if ($a{_atype} eq 'object') {	722	if ($a{_atype} eq 'object') {
…		…
706	=cut	809	=cut
707		810
708	sub arch_attr($) {	811	sub arch_attr($) {
709	my ($obj) = @_;	812	my ($obj) = @_;
710		813
711	require Crossfire::Data;	814	require Deliantra::Data;
712		815
713	my $root;	816	my $root;
714	my $attr = { };	817	my $attr = { };
715		818
716	my $arch = $ARCH{ $obj->{_name} };	819	my $arch = $ARCH{ $obj->{_name} };
717	my $type = $obj->{type} \|\| $arch->{type};	820	my $type = $obj->{type} \|\| $arch->{type};
718		821
719	if ($type > 0) {	822	if ($type > 0) {
720	$root = $Crossfire::Data::ATTR{$type};	823	$root = $Deliantra::Data::ATTR{$type};
721	} else {	824	} else {
722	my %a = (%$arch, %$obj);	825	my %a = (%$arch, %$obj);
723		826
724	if ($a{is_floor} && !$a{alive}) {	827	if ($a{is_floor} && !$a{alive}) {
725	$root = $Crossfire::Data::TYPE{Floor};	828	$root = $Deliantra::Data::TYPE{Floor};
726	} elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) {	829	} elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) {
727	$root = $Crossfire::Data::TYPE{"Monster & NPC"};	830	$root = $Deliantra::Data::TYPE{"Monster & NPC"};
728	} elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) {	831	} elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) {
729	$root = $Crossfire::Data::TYPE{Wall};	832	$root = $Deliantra::Data::TYPE{Wall};
730	} elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) {	833	} elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) {
731	$root = $Crossfire::Data::TYPE{"Weak Wall"};	834	$root = $Deliantra::Data::TYPE{"Weak Wall"};
732	} else {	835	} else {
733	$root = $Crossfire::Data::TYPE{Misc};	836	$root = $Deliantra::Data::TYPE{Misc};
734	}	837	}
735	}	838	}
736		839
		840	my (%ignore);
737	my @import = ($root);	841	my @import = ($root);
		842
		843	my @new_import;
		844	while (my $type = shift @import) {
		845	# first import everything we will need:
		846	push @import,
		847	grep $_,
		848	map $Deliantra::Data::TYPE{$_},
		849	@{$type->{import} \|\| []};
		850
		851	# and compute the ignored attributes
		852	for (@{$type->{ignore} \|\| []}) {
		853	$ignore{$_}++ for ref $_ ? @$_ : $_;
		854	}
		855
		856	push @new_import, $type;
738		857	}
		858	(@import) = @new_import;
		859
		860	# then add defaults to the back of the list, so they are added
		861	# as last resort.
739	unshift @import, \%Crossfire::Data::DEFAULT_ATTR	862	push @import, \%Deliantra::Data::DEFAULT_ATTR
740	unless $type == 116;	863	unless $type == 116;
741		864
742	my (%ignore);
743	my (@section_order, %section, @attr_order);	865	my (@section_order, %section, @attr_order);
744		866
		867	# @import = root, imported, default
745	while (my $type = shift @import) {	868	while (my $type = pop @import) {
746	push @import, @{$type->{import} \|\| []};
747
748	$attr->{$_} \|\|= $type->{$_}	869	$attr->{$_} \|\|= $type->{$_}
749	for qw(name desc use);	870	for qw(name desc use);
750
751	for (@{$type->{ignore} \|\| []}) {
752	$ignore{$_}++ for ref $_ ? @$_ : $_;
753	}
754		871
755	for ([general => ($type->{attr} \|\| [])], @{$type->{section} \|\| []}) {	872	for ([general => ($type->{attr} \|\| [])], @{$type->{section} \|\| []}) {
756	my ($name, $attr) = @$_;	873	my ($name, $attr) = @$_;
757	push @section_order, $name;	874	push @section_order, $name;
758	for (@$attr) {	875	for (@$attr) {
759	my ($k, $v) = @$_;	876	my ($k, $v) = @$_;
760	push @attr_order, $k;	877	push @attr_order, $k;
761	$section{$name}{$k} \|\|= $v;	878	$section{$name}{$k} = $v; # overwrite, so that the root decides
762	}
763	}	879	}
		880	}
		881	}
		882
		883	# remove ignores for "root" type
		884	for (
		885	map @{$_->[1]}, # section attributes
		886	[general => ($root->{attr} \|\| [])],
		887	@{$root->{section} \|\| []}
		888	) {
		889	my ($k, $v) = @$_;
		890	# skip fixed attributes, if they are ignored thats fine
		891	next if $v->{type} eq 'fixed';
		892
		893	delete $ignore{$k}; # if the attributes are defined explicitly they
		894	# should NOT be ignored. ignore should mainly
		895	# hit imported/inherited attributes.
764	}	896	}
765		897
766	$attr->{section} = [	898	$attr->{section} = [
767	map !exists $section{$_} ? () : do {	899	map !exists $section{$_} ? () : do {
768	my $attr = delete $section{$_};	900	my $attr = delete $section{$_};
…		…
772	map exists $attr->{$_} && !$ignore{$_}	904	map exists $attr->{$_} && !$ignore{$_}
773	? [$_ => delete $attr->{$_}] : (),	905	? [$_ => delete $attr->{$_}] : (),
774	@attr_order	906	@attr_order
775	]	907	]
776	},	908	},
777
778	exists $section{$_} ? [$_ => delete $section{$_}] : (),	909	exists $section{$_} ? [$_ => delete $section{$_}] : (),
779	@section_order	910	@section_order
780	];	911	];
781		912
782	$attr	913	$attr
783	}
784
785	sub arch_edit_sections {
786	# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
787	# edit_type = 0;
788	# else if (edit_type != 0) {
789	# // all flags from 'check_type' must be unset in this arch because they get recalculated now
790	# edit_type &= ~check_type;
791	# }
792	#
793	# }
794	# if ((check_type & IGUIConstants.TILE_EDIT_MONSTER) != 0 &&
795	# getAttributeValue("alive", defarch) == 1 &&
796	# (getAttributeValue("monster", defarch) == 1 \|\|
797	# getAttributeValue("generator", defarch) == 1)) {
798	# // Monster: monsters/npcs/generators
799	# edit_type \|= IGUIConstants.TILE_EDIT_MONSTER;
800	# }
801	# if ((check_type & IGUIConstants.TILE_EDIT_WALL) != 0 &&
802	# arch_type == 0 && getAttributeValue("no_pass", defarch) == 1) {
803	# // Walls
804	# edit_type \|= IGUIConstants.TILE_EDIT_WALL;
805	# }
806	# if ((check_type & IGUIConstants.TILE_EDIT_CONNECTED) != 0 &&
807	# getAttributeValue("connected", defarch) != 0) {
808	# // Connected Objects
809	# edit_type \|= IGUIConstants.TILE_EDIT_CONNECTED;
810	# }
811	# if ((check_type & IGUIConstants.TILE_EDIT_EXIT) != 0 &&
812	# arch_type == 66 \|\| arch_type == 41 \|\| arch_type == 95) {
813	# // Exit: teleporter/exit/trapdoors
814	# edit_type \|= IGUIConstants.TILE_EDIT_EXIT;
815	# }
816	# if ((check_type & IGUIConstants.TILE_EDIT_TREASURE) != 0 &&
817	# getAttributeValue("no_pick", defarch) == 0 && (arch_type == 4 \|\|
818	# arch_type == 5 \|\| arch_type == 36 \|\| arch_type == 60 \|\|
819	# arch_type == 85 \|\| arch_type == 111 \|\| arch_type == 123 \|\|
820	# arch_type == 124 \|\| arch_type == 130)) {
821	# // Treasure: randomtreasure/money/gems/potions/spellbooks/scrolls
822	# edit_type \|= IGUIConstants.TILE_EDIT_TREASURE;
823	# }
824	# if ((check_type & IGUIConstants.TILE_EDIT_DOOR) != 0 &&
825	# arch_type == 20 \|\| arch_type == 23 \|\| arch_type == 26 \|\|
826	# arch_type == 91 \|\| arch_type == 21 \|\| arch_type == 24) {
827	# // Door: door/special door/gates + keys
828	# edit_type \|= IGUIConstants.TILE_EDIT_DOOR;
829	# }
830	# if ((check_type & IGUIConstants.TILE_EDIT_EQUIP) != 0 &&
831	# getAttributeValue("no_pick", defarch) == 0 && ((arch_type >= 13 &&
832	# arch_type <= 16) \|\| arch_type == 33 \|\| arch_type == 34 \|\|
833	# arch_type == 35 \|\| arch_type == 39 \|\| arch_type == 70 \|\|
834	# arch_type == 87 \|\| arch_type == 99 \|\| arch_type == 100 \|\|
835	# arch_type == 104 \|\| arch_type == 109 \|\| arch_type == 113 \|\|
836	# arch_type == 122 \|\| arch_type == 3)) {
837	# // Equipment: weapons/armour/wands/rods
838	# edit_type \|= IGUIConstants.TILE_EDIT_EQUIP;
839	# }
840	#
841	# return(edit_type);
842	#
843	#
844	}	914	}
845		915
846	sub cache_file($$&&) {	916	sub cache_file($$&&) {
847	my ($src, $cache, $load, $create) = @_;	917	my ($src, $cache, $load, $create) = @_;
848		918
…		…
898	}, sub {	968	}, sub {
899	read_arch "$LIB/archetypes"	969	read_arch "$LIB/archetypes"
900	};	970	};
901	}	971	}
902		972
		973	sub construct_tilecache_pb {
		974	my ($idx, $cache) = @_;
		975
		976	my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, CACHESTRIDE * TILESIZE, TILESIZE * int +($idx + CACHESTRIDE - 1) / CACHESTRIDE;
		977
		978	while (my ($name, $tile) = each %$cache) {
		979	my $tpb = delete $tile->{pb};
		980	my $ofs = $tile->{idx};
		981
		982	for my $x (0 .. $tile->{w} - 1) {
		983	for my $y (0 .. $tile->{h} - 1) {
		984	my $idx = $ofs + $x + $y * $tile->{w};
		985	$tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
		986	$pb, ($idx % CACHESTRIDE) * TILESIZE, TILESIZE * int $idx / CACHESTRIDE);
		987	}
		988	}
		989	}
		990
		991	$pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
		992
		993	$cache
		994	}
		995
		996	sub use_tilecache {
		997	my ($face) = @_;
		998	$TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
		999	or die "$VARDIR/tilecache.png: $!";
		1000	*FACE = $_[0];
		1001	}
		1002
903	=item load_tilecache	1003	=item load_tilecache
904		1004
905	(Re-)Load %TILE and %FACE.	1005	(Re-)Load %TILE and %FACE.
906		1006
907	=cut	1007	=cut
908		1008
909	sub load_tilecache() {	1009	sub load_tilecache() {
910	require Gtk2;	1010	require Gtk2;
911		1011
912	cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub {	1012	cache_file "$LIB/facedata", "$VARDIR/tilecache.pst", \&use_tilecache,
913	$TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
914	or die "$VARDIR/tilecache.png: $!";
915	*FACE = $_[0];
916	}, sub {	1013	sub {
917	my $tile = read_pak "$LIB/crossfire.0";
918
919	my %cache;	1014	my %cache;
		1015	my $facedata = Storable::retrieve "$LIB/faceinfo";
920		1016
		1017	open my $fh, "<", "$LIB/facedata"
		1018	or die "$LIB/facedata: $!";
		1019
		1020	$facedata->{version} == 2
		1021	or die "$LIB/facedata: version mismatch, cannot proceed.";
		1022
		1023	my $faces = $facedata->{faceinfo};
921	my $idx = 0;	1024	my $idx = 0;
922		1025
923	for my $name (sort keys %$tile) {	1026	for (sort keys %$faces) {
		1027	my ($face, $info) = ($_, $faces->{$_});
		1028
924	my $pb = new Gtk2::Gdk::PixbufLoader;	1029	my $pb = new Gtk2::Gdk::PixbufLoader;
925	$pb->write ($tile->{$name});
926	$pb->close;
927	my $pb = $pb->get_pixbuf;
928		1030
929	my $tile = $cache{$name} = {	1031	if (exists $info->{data32}) {
930	pb => $pb,	1032	$pb->write ($info->{data32});
931	idx => $idx,	1033	} else {
932	w => int $pb->get_width / TILESIZE,	1034	sysseek $fh, $info->{fofs32}, 0;
933	h => int $pb->get_height / TILESIZE,	1035	sysread $fh, my $buf, $info->{size32};
934	};	1036	$pb->write ($buf);
935
936
937	$idx += $tile->{w} * $tile->{h};
938	}
939
940	my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
941
942	while (my ($name, $tile) = each %cache) {
943	my $tpb = delete $tile->{pb};
944	my $ofs = $tile->{idx};
945
946	for my $x (0 .. $tile->{w} - 1) {
947	for my $y (0 .. $tile->{h} - 1) {
948	my $idx = $ofs + $x + $y * $tile->{w};
949	$tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
950	$pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
951	}	1037	}
		1038	$pb->close;
		1039	my $pb = $pb->get_pixbuf;
		1040
		1041	my $tile = $cache{$face} = {
		1042	pb => $pb,
		1043	idx => $idx,
		1044	w => int $pb->get_width / TILESIZE,
		1045	h => int $pb->get_height / TILESIZE,
952	}	1046	};
		1047
		1048	$idx += $tile->{w} * $tile->{h};
		1049	}
		1050
		1051	construct_tilecache_pb $idx, \%cache;
		1052
		1053	\%cache
953	}	1054	};
954
955	$pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
956
957	\%cache
958	};
959	}	1055	}
		1056
		1057	=back
960		1058
961	=head1 AUTHOR	1059	=head1 AUTHOR
962		1060
963	Marc Lehmann <schmorp@schmorp.de>	1061	Marc Lehmann <schmorp@schmorp.de>
964	http://home.schmorp.de/	1062	http://home.schmorp.de/
…		…
967	http://www.ta-sa.org/	1065	http://www.ta-sa.org/
968		1066
969	=cut	1067	=cut
970		1068
971	1	1069	1
		1070

Diff Legend

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

Comparing deliantra/Deliantra/Deliantra.pm (file contents): Revision 1.82 by root, Tue Feb 6 23:53:26 2007 UTC vs. Revision 1.147 by root, Wed Nov 7 12:04:36 2018 UTC

Diff Legend

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.82 by root, Tue Feb 6 23:53:26 2007 UTC vs.
Revision 1.147 by root, Wed Nov 7 12:04:36 2018 UTC