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

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.81 by root, Tue Feb 6 22:27:44 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
…		…
199	while (my ($k, $v) = each %attack_mask) {	330	while (my ($k, $v) = each %attack_mask) {
200	$ob->{"resist_$k"} = min 100, max -100, $ob->{"resist_$k"} + $value if $mask & $v;	331	$ob->{"resist_$k"} = min 100, max -100, $ob->{"resist_$k"} + $value if $mask & $v;
201	}	332	}
202	}	333	}
203		334
		335	my %MATERIAL = reverse
		336	paper => 1,
		337	iron => 2,
		338	glass => 4,
		339	leather => 8,
		340	wood => 16,
		341	organic => 32,
		342	stone => 64,
		343	cloth => 128,
		344	adamant => 256,
		345	liquid => 512,
		346	tin => 1024,
		347	bone => 2048,
		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,
		364	;
		365
204	# object as in "Object xxx", i.e. archetypes	366	# object as in "Object xxx", i.e. archetypes
205	sub normalize_object($) {	367	sub normalize_object($) {
206	my ($ob) = @_;	368	my ($ob) = @_;
207		369
		370	delete $ob->{editable}; # deprecated
		371
		372	# convert material bitset to materialname, if possible
		373	if (exists $ob->{material}) {
		374	if (!$ob->{material}) {
		375	delete $ob->{material};
		376	} elsif (exists $ob->{materialname}) {
		377	if ($MATERIAL{$ob->{material}} eq $ob->{materialname}) {
		378	delete $ob->{material};
		379	} else {
		380	warn "object $ob->{_name} has both materialname ($ob->{materialname}) and material ($ob->{material}) set.\n";
		381	delete $ob->{material}; # assume materilname is more specific and nuke material
		382	}
		383	} elsif (my $name = $MATERIAL{$ob->{material}}) {
		384	delete $ob->{material};
		385	$ob->{materialname} = $name;
		386	} else {
		387	warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n";
		388	}
		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};
		404
208	# nuke outdated or never supported fields	405	# nuke outdated or never supported fields
209	delete @$ob{qw(	406	delete @$ob{qw(
210	can_knockback can_parry can_impale can_cut can_dam_armour	407	can_knockback can_parry can_impale can_cut can_dam_armour
211	can_apply pass_thru can_pass_thru	408	can_apply pass_thru can_pass_thru color_bg color_fg
212	)};	409	)};
213		410
214	if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; }	411	if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; }
215	if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; }	412	if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; }
216	if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; }	413	if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; }
217		414
218	# convert movement strings to bitsets	415	# convert movement strings to bitsets
219	for my $attr (keys %FIELD_MOVEMENT) {	416	for my $attr (keys %FIELD_MOVEMENT) {
220	next unless exists $ob->{$attr};	417	next unless exists $ob->{$attr};
221		418
222	$ob->{$attr} = MOVE_ALL if $ob->{$attr} == 255; #d# compatibility	419	$ob->{$attr} = new Deliantra::MoveType $ob->{$attr};
223
224	next if $ob->{$attr} =~ /^\d+$/;
225
226	my $flags = 0;
227
228	# assume list
229	for my $flag (map lc, split /\s+/, $ob->{$attr}) {
230	$flags \|= MOVE_WALK if $flag eq "walk";
231	$flags \|= MOVE_FLY_LOW if $flag eq "fly_low";
232	$flags \|= MOVE_FLY_HIGH if $flag eq "fly_high";
233	$flags \|= MOVE_FLYING if $flag eq "flying";
234	$flags \|= MOVE_SWIM if $flag eq "swim";
235	$flags \|= MOVE_BOAT if $flag eq "boat";
236	$flags \|= MOVE_ALL if $flag eq "all";
237
238	$flags &= ~MOVE_WALK if $flag eq "-walk";
239	$flags &= ~MOVE_FLY_LOW if $flag eq "-fly_low";
240	$flags &= ~MOVE_FLY_HIGH if $flag eq "-fly_high";
241	$flags &= ~MOVE_FLYING if $flag eq "-flying";
242	$flags &= ~MOVE_SWIM if $flag eq "-swim";
243	$flags &= ~MOVE_BOAT if $flag eq "-boat";
244	$flags &= ~MOVE_ALL if $flag eq "-all";
245	}
246
247	$ob->{$attr} = $flags;
248	}	420	}
249		421
250	# convert outdated movement flags to new movement sets	422	# convert outdated movement flags to new movement sets
251	if (defined (my $v = delete $ob->{no_pass})) {	423	if (defined (my $v = delete $ob->{no_pass})) {
252	$ob->{move_block} = $v ? MOVE_ALL : 0;	424	$ob->{move_block} = new Deliantra::MoveType $v ? "all" : "0";
253	}	425	}
254	if (defined (my $v = delete $ob->{slow_move})) {	426	if (defined (my $v = delete $ob->{slow_move})) {
255	$ob->{move_slow} \|= MOVE_WALK;	427	$ob->{move_slow} += "walk";
256	$ob->{move_slow_penalty} = $v;	428	$ob->{move_slow_penalty} = $v;
257	}	429	}
258	if (defined (my $v = delete $ob->{walk_on})) {	430	if (defined (my $v = delete $ob->{walk_on})) {
259	$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" }
260	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_WALK
261	: $ob->{move_on} & ~MOVE_WALK;
262	}	432	}
263	if (defined (my $v = delete $ob->{walk_off})) {	433	if (defined (my $v = delete $ob->{walk_off})) {
264	$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" }
265	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_WALK
266	: $ob->{move_off} & ~MOVE_WALK;
267	}	435	}
268	if (defined (my $v = delete $ob->{fly_on})) {	436	if (defined (my $v = delete $ob->{fly_on})) {
269	$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" }
270	$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_FLY_LOW
271	: $ob->{move_on} & ~MOVE_FLY_LOW;
272	}	438	}
273	if (defined (my $v = delete $ob->{fly_off})) {	439	if (defined (my $v = delete $ob->{fly_off})) {
274	$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" }
275	$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_FLY_LOW
276	: $ob->{move_off} & ~MOVE_FLY_LOW;
277	}	441	}
278	if (defined (my $v = delete $ob->{flying})) {	442	if (defined (my $v = delete $ob->{flying})) {
279	$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" }
280	$ob->{move_type} = $v ? $ob->{move_type} \| MOVE_FLY_LOW
281	: $ob->{move_type} & ~MOVE_FLY_LOW;
282	}	444	}
283		445
284	# convert idiotic event_xxx things into objects	446	# convert idiotic event_xxx things into objects
285	while (my ($event, $subtype) = each %EVENT_TYPE) {	447	while (my ($event, $subtype) = each %EVENT_TYPE) {
286	if (exists $ob->{"event_${event}_plugin"}) {	448	if (exists $ob->{"event_${event}_plugin"}) {
…		…
302	# arch as in "arch xxx", ie.. objects	464	# arch as in "arch xxx", ie.. objects
303	sub normalize_arch($) {	465	sub normalize_arch($) {
304	my ($ob) = @_;	466	my ($ob) = @_;
305		467
306	normalize_object $ob;	468	normalize_object $ob;
		469
		470	return if $ob->{_atype} eq "object";
307		471
308	my $arch = $ARCH{$ob->{_name}}	472	my $arch = $ARCH{$ob->{_name}}
309	or (warn "$ob->{_name}: no such archetype", return $ob);	473	or (warn "$ob->{_name}: no such archetype", return $ob);
310		474
311	if ($arch->{type} == 22) { # map	475	if ($arch->{type} == 22) { # map
…		…
347	}	511	}
348		512
349	sub attr_thaw($) {	513	sub attr_thaw($) {
350	my ($ob) = @_;	514	my ($ob) = @_;
351		515
352	$ob->{attach} = from_json $ob->{attach}	516	$ob->{attach} = decode_json $ob->{attach}
353	if exists $ob->{attach};	517	if exists $ob->{attach};
354		518
355	$ob	519	$ob
356	}	520	}
357		521
358	sub attr_freeze($) {	522	sub attr_freeze($) {
359	my ($ob) = @_;	523	my ($ob) = @_;
360		524
361	$ob->{attach} = Crossfire::to_json $ob->{attach}	525	$ob->{attach} = JSON::XS->new->utf8->canonical->encode ($ob->{attach})
362	if exists $ob->{attach};	526	if exists $ob->{attach};
363		527
364	$ob	528	$ob
365	}	529	}
366		530
…		…
386		550
387	my %arc;	551	my %arc;
388	my ($more, $prev);	552	my ($more, $prev);
389	my $comment;	553	my $comment;
390		554
391	open my $fh, "<:raw:perlio:utf8", $path	555	open my $fh, "<:utf8", $path
392	or Carp::croak "$path: $!";	556	or Carp::croak "$path: $!";
393		557
394	# binmode $fh;	558	# binmode $fh;
395		559
396	my $parse_block; $parse_block = sub {	560	my $parse_block; $parse_block = sub {
…		…
496	my $str;	660	my $str;
497		661
498	my $append; $append = sub {	662	my $append; $append = sub {
499	my %a = %{$_[0]};	663	my %a = %{$_[0]};
500		664
501	Crossfire::attr_freeze \%a;	665	Deliantra::attr_freeze \%a;
502	Crossfire::normalize_arch \%a;	666	Deliantra::normalize_arch \%a;
503		667
504	# undo the bit-split we did before	668	# undo the bit-split we did before
505	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}) {
506	$a{attack_movement} = (delete $a{attack_movement_bits_0_3})	670	$a{attack_movement} = (delete $a{attack_movement_bits_0_3})
507	\| (delete $a{attack_movement_bits_4_7});	671	\| (delete $a{attack_movement_bits_4_7});
…		…
517		681
518	my $inv = delete $a{inventory};	682	my $inv = delete $a{inventory};
519	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
520	my $anim = delete $a{anim};	684	my $anim = delete $a{anim};
521		685
		686	if ($a{_atype} eq 'object') {
		687	$str .= join "\n", "anim", @$anim, "mina\n"
		688	if $anim;
		689	}
		690
522	my @kv;	691	my @kv;
523		692
524	for ($a{_name} eq "map"	693	for ($a{_name} eq "map"
525	? @Crossfire::FIELD_ORDER_MAP	694	? @Deliantra::FIELD_ORDER_MAP
526	: @Crossfire::FIELD_ORDER) {	695	: @Deliantra::FIELD_ORDER) {
527	push @kv, [$_, delete $a{$_}]	696	push @kv, [$_, delete $a{$_}]
528	if exists $a{$_};	697	if exists $a{$_};
529	}	698	}
530		699
531	for (sort keys %a) {	700	for (sort keys %a) {
…		…
534	}	703	}
535		704
536	for (@kv) {	705	for (@kv) {
537	my ($k, $v) = @$_;	706	my ($k, $v) = @$_;
538		707
539	if (my $end = $Crossfire::FIELD_MULTILINE{$k}) {	708	if (my $end = $Deliantra::FIELD_MULTILINE{$k}) {
540	$v =~ s/\n$//;	709	$v =~ s/\n$//;
541	$str .= "$k\n$v\n$end\n";	710	$str .= "$k\n$v\n$end\n";
542	} elsif (exists $Crossfire::FIELD_MOVEMENT{$k}) {
543	if ($v & ~Crossfire::MOVE_ALL or !$v) {
544	$str .= "$k $v\n";
545
546	} elsif ($v & Crossfire::MOVE_ALLBIT) {
547	$str .= "$k all";
548
549	$str .= " -walk" unless $v & Crossfire::MOVE_WALK;
550	$str .= " -fly_low" unless $v & Crossfire::MOVE_FLY_LOW;
551	$str .= " -fly_high" unless $v & Crossfire::MOVE_FLY_HIGH;
552	$str .= " -swim" unless $v & Crossfire::MOVE_SWIM;
553	$str .= " -boat" unless $v & Crossfire::MOVE_BOAT;
554
555	$str .= "\n";
556
557	} else {
558	$str .= $k;
559
560	$str .= " walk" if $v & Crossfire::MOVE_WALK;
561	$str .= " fly_low" if $v & Crossfire::MOVE_FLY_LOW;
562	$str .= " fly_high" if $v & Crossfire::MOVE_FLY_HIGH;
563	$str .= " swim" if $v & Crossfire::MOVE_SWIM;
564	$str .= " boat" if $v & Crossfire::MOVE_BOAT;
565
566	$str .= "\n";
567	}
568	} else {	711	} else {
569	$str .= "$k $v\n";	712	$str .= "$k $v\n";
570	}	713	}
571	}	714	}
572		715
573	if ($inv) {	716	if ($inv) {
574	$append->($_) for @$inv;	717	$append->($_) for @$inv;
575	}
576
577	if ($a{_atype} eq 'object') {
578	$str .= join "\n", "anim", @$anim, "mina\n"
579	if $anim;
580	}	718	}
581		719
582	$str .= "end\n";	720	$str .= "end\n";
583		721
584	if ($a{_atype} eq 'object') {	722	if ($a{_atype} eq 'object') {
…		…
671	=cut	809	=cut
672		810
673	sub arch_attr($) {	811	sub arch_attr($) {
674	my ($obj) = @_;	812	my ($obj) = @_;
675		813
676	require Crossfire::Data;	814	require Deliantra::Data;
677		815
678	my $root;	816	my $root;
679	my $attr = { };	817	my $attr = { };
680		818
681	my $arch = $ARCH{ $obj->{_name} };	819	my $arch = $ARCH{ $obj->{_name} };
682	my $type = $obj->{type} \|\| $arch->{type};	820	my $type = $obj->{type} \|\| $arch->{type};
683		821
684	if ($type > 0) {	822	if ($type > 0) {
685	$root = $Crossfire::Data::ATTR{$type};	823	$root = $Deliantra::Data::ATTR{$type};
686	} else {	824	} else {
687	my %a = (%$arch, %$obj);	825	my %a = (%$arch, %$obj);
688		826
689	if ($a{is_floor} && !$a{alive}) {	827	if ($a{is_floor} && !$a{alive}) {
690	$root = $Crossfire::Data::TYPE{Floor};	828	$root = $Deliantra::Data::TYPE{Floor};
691	} elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) {	829	} elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) {
692	$root = $Crossfire::Data::TYPE{"Monster & NPC"};	830	$root = $Deliantra::Data::TYPE{"Monster & NPC"};
693	} elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) {	831	} elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) {
694	$root = $Crossfire::Data::TYPE{Wall};	832	$root = $Deliantra::Data::TYPE{Wall};
695	} elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) {	833	} elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) {
696	$root = $Crossfire::Data::TYPE{"Weak Wall"};	834	$root = $Deliantra::Data::TYPE{"Weak Wall"};
697	} else {	835	} else {
698	$root = $Crossfire::Data::TYPE{Misc};	836	$root = $Deliantra::Data::TYPE{Misc};
699	}	837	}
700	}	838	}
701		839
		840	my (%ignore);
702	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;
703		857	}
		858	(@import) = @new_import;
		859
		860	# then add defaults to the back of the list, so they are added
		861	# as last resort.
704	unshift @import, \%Crossfire::Data::DEFAULT_ATTR	862	push @import, \%Deliantra::Data::DEFAULT_ATTR
705	unless $type == 116;	863	unless $type == 116;
706		864
707	my (%ignore);
708	my (@section_order, %section, @attr_order);	865	my (@section_order, %section, @attr_order);
709		866
		867	# @import = root, imported, default
710	while (my $type = shift @import) {	868	while (my $type = pop @import) {
711	push @import, @{$type->{import} \|\| []};
712
713	$attr->{$_} \|\|= $type->{$_}	869	$attr->{$_} \|\|= $type->{$_}
714	for qw(name desc use);	870	for qw(name desc use);
715
716	for (@{$type->{ignore} \|\| []}) {
717	$ignore{$_}++ for ref $_ ? @$_ : $_;
718	}
719		871
720	for ([general => ($type->{attr} \|\| [])], @{$type->{section} \|\| []}) {	872	for ([general => ($type->{attr} \|\| [])], @{$type->{section} \|\| []}) {
721	my ($name, $attr) = @$_;	873	my ($name, $attr) = @$_;
722	push @section_order, $name;	874	push @section_order, $name;
723	for (@$attr) {	875	for (@$attr) {
724	my ($k, $v) = @$_;	876	my ($k, $v) = @$_;
725	push @attr_order, $k;	877	push @attr_order, $k;
726	$section{$name}{$k} \|\|= $v;	878	$section{$name}{$k} = $v; # overwrite, so that the root decides
727	}
728	}	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.
729	}	896	}
730		897
731	$attr->{section} = [	898	$attr->{section} = [
732	map !exists $section{$_} ? () : do {	899	map !exists $section{$_} ? () : do {
733	my $attr = delete $section{$_};	900	my $attr = delete $section{$_};
…		…
737	map exists $attr->{$_} && !$ignore{$_}	904	map exists $attr->{$_} && !$ignore{$_}
738	? [$_ => delete $attr->{$_}] : (),	905	? [$_ => delete $attr->{$_}] : (),
739	@attr_order	906	@attr_order
740	]	907	]
741	},	908	},
742
743	exists $section{$_} ? [$_ => delete $section{$_}] : (),	909	exists $section{$_} ? [$_ => delete $section{$_}] : (),
744	@section_order	910	@section_order
745	];	911	];
746		912
747	$attr	913	$attr
748	}
749
750	sub arch_edit_sections {
751	# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
752	# edit_type = 0;
753	# else if (edit_type != 0) {
754	# // all flags from 'check_type' must be unset in this arch because they get recalculated now
755	# edit_type &= ~check_type;
756	# }
757	#
758	# }
759	# if ((check_type & IGUIConstants.TILE_EDIT_MONSTER) != 0 &&
760	# getAttributeValue("alive", defarch) == 1 &&
761	# (getAttributeValue("monster", defarch) == 1 \|\|
762	# getAttributeValue("generator", defarch) == 1)) {
763	# // Monster: monsters/npcs/generators
764	# edit_type \|= IGUIConstants.TILE_EDIT_MONSTER;
765	# }
766	# if ((check_type & IGUIConstants.TILE_EDIT_WALL) != 0 &&
767	# arch_type == 0 && getAttributeValue("no_pass", defarch) == 1) {
768	# // Walls
769	# edit_type \|= IGUIConstants.TILE_EDIT_WALL;
770	# }
771	# if ((check_type & IGUIConstants.TILE_EDIT_CONNECTED) != 0 &&
772	# getAttributeValue("connected", defarch) != 0) {
773	# // Connected Objects
774	# edit_type \|= IGUIConstants.TILE_EDIT_CONNECTED;
775	# }
776	# if ((check_type & IGUIConstants.TILE_EDIT_EXIT) != 0 &&
777	# arch_type == 66 \|\| arch_type == 41 \|\| arch_type == 95) {
778	# // Exit: teleporter/exit/trapdoors
779	# edit_type \|= IGUIConstants.TILE_EDIT_EXIT;
780	# }
781	# if ((check_type & IGUIConstants.TILE_EDIT_TREASURE) != 0 &&
782	# getAttributeValue("no_pick", defarch) == 0 && (arch_type == 4 \|\|
783	# arch_type == 5 \|\| arch_type == 36 \|\| arch_type == 60 \|\|
784	# arch_type == 85 \|\| arch_type == 111 \|\| arch_type == 123 \|\|
785	# arch_type == 124 \|\| arch_type == 130)) {
786	# // Treasure: randomtreasure/money/gems/potions/spellbooks/scrolls
787	# edit_type \|= IGUIConstants.TILE_EDIT_TREASURE;
788	# }
789	# if ((check_type & IGUIConstants.TILE_EDIT_DOOR) != 0 &&
790	# arch_type == 20 \|\| arch_type == 23 \|\| arch_type == 26 \|\|
791	# arch_type == 91 \|\| arch_type == 21 \|\| arch_type == 24) {
792	# // Door: door/special door/gates + keys
793	# edit_type \|= IGUIConstants.TILE_EDIT_DOOR;
794	# }
795	# if ((check_type & IGUIConstants.TILE_EDIT_EQUIP) != 0 &&
796	# getAttributeValue("no_pick", defarch) == 0 && ((arch_type >= 13 &&
797	# arch_type <= 16) \|\| arch_type == 33 \|\| arch_type == 34 \|\|
798	# arch_type == 35 \|\| arch_type == 39 \|\| arch_type == 70 \|\|
799	# arch_type == 87 \|\| arch_type == 99 \|\| arch_type == 100 \|\|
800	# arch_type == 104 \|\| arch_type == 109 \|\| arch_type == 113 \|\|
801	# arch_type == 122 \|\| arch_type == 3)) {
802	# // Equipment: weapons/armour/wands/rods
803	# edit_type \|= IGUIConstants.TILE_EDIT_EQUIP;
804	# }
805	#
806	# return(edit_type);
807	#
808	#
809	}	914	}
810		915
811	sub cache_file($$&&) {	916	sub cache_file($$&&) {
812	my ($src, $cache, $load, $create) = @_;	917	my ($src, $cache, $load, $create) = @_;
813		918
…		…
863	}, sub {	968	}, sub {
864	read_arch "$LIB/archetypes"	969	read_arch "$LIB/archetypes"
865	};	970	};
866	}	971	}
867		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
868	=item load_tilecache	1003	=item load_tilecache
869		1004
870	(Re-)Load %TILE and %FACE.	1005	(Re-)Load %TILE and %FACE.
871		1006
872	=cut	1007	=cut
873		1008
874	sub load_tilecache() {	1009	sub load_tilecache() {
875	require Gtk2;	1010	require Gtk2;
876		1011
877	cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub {	1012	cache_file "$LIB/facedata", "$VARDIR/tilecache.pst", \&use_tilecache,
878	$TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
879	or die "$VARDIR/tilecache.png: $!";
880	*FACE = $_[0];
881	}, sub {	1013	sub {
882	my $tile = read_pak "$LIB/crossfire.0";
883
884	my %cache;	1014	my %cache;
		1015	my $facedata = Storable::retrieve "$LIB/faceinfo";
885		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};
886	my $idx = 0;	1024	my $idx = 0;
887		1025
888	for my $name (sort keys %$tile) {	1026	for (sort keys %$faces) {
		1027	my ($face, $info) = ($_, $faces->{$_});
		1028
889	my $pb = new Gtk2::Gdk::PixbufLoader;	1029	my $pb = new Gtk2::Gdk::PixbufLoader;
890	$pb->write ($tile->{$name});
891	$pb->close;
892	my $pb = $pb->get_pixbuf;
893		1030
894	my $tile = $cache{$name} = {	1031	if (exists $info->{data32}) {
895	pb => $pb,	1032	$pb->write ($info->{data32});
896	idx => $idx,	1033	} else {
897	w => int $pb->get_width / TILESIZE,	1034	sysseek $fh, $info->{fofs32}, 0;
898	h => int $pb->get_height / TILESIZE,	1035	sysread $fh, my $buf, $info->{size32};
899	};	1036	$pb->write ($buf);
900
901
902	$idx += $tile->{w} * $tile->{h};
903	}
904
905	my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
906
907	while (my ($name, $tile) = each %cache) {
908	my $tpb = delete $tile->{pb};
909	my $ofs = $tile->{idx};
910
911	for my $x (0 .. $tile->{w} - 1) {
912	for my $y (0 .. $tile->{h} - 1) {
913	my $idx = $ofs + $x + $y * $tile->{w};
914	$tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
915	$pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
916	}	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,
917	}	1046	};
		1047
		1048	$idx += $tile->{w} * $tile->{h};
		1049	}
		1050
		1051	construct_tilecache_pb $idx, \%cache;
		1052
		1053	\%cache
918	}	1054	};
919
920	$pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
921
922	\%cache
923	};
924	}	1055	}
		1056
		1057	=back
925		1058
926	=head1 AUTHOR	1059	=head1 AUTHOR
927		1060
928	Marc Lehmann <schmorp@schmorp.de>	1061	Marc Lehmann <schmorp@schmorp.de>
929	http://home.schmorp.de/	1062	http://home.schmorp.de/
…		…
932	http://www.ta-sa.org/	1065	http://www.ta-sa.org/
933		1066
934	=cut	1067	=cut
935		1068
936	1	1069	1
		1070

Diff Legend

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

Comparing deliantra/Deliantra/Deliantra.pm (file contents): Revision 1.81 by root, Tue Feb 6 22:27:44 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.81 by root, Tue Feb 6 22:27:44 2007 UTC vs.
Revision 1.147 by root, Wed Nov 7 12:04:36 2018 UTC