server/ext/cfplus_build.ext

#!perl

our %materials;

our @CONNECTABLE = (
   cf::DOOR,
   cf::GATE,
   cf::BUTTON,
   cf::DETECTOR,
   cf::TIMED_GATE,
   cf::PEDESTAL,
   cf::CF_HANDLE,
   cf::MAGIC_EAR
);
our @READABLE = (cf::SIGN, cf::MAGIC_EAR);

$cf::CFG{"editor_builder_ui"}
   or return;

cf::register_extcmd builder_player_items => sub {
   my ($pl, $msg) = @_;

   (items => {
      map {
         my $arch = $_;
         my $buildarch = cf::arch::find ($arch->clone->slaying);
         my $h = { value => $arch->clone->value, build_arch_name => $buildarch->name };

         if (((grep { $buildarch->clone->type == $_ } @CONNECTABLE) > 0)
             || ($buildarch->name eq 'magic_mouth' && $buildarch->clone->type == cf::SIGN)) {
            $h->{has_connection} = 1;
         }

         if (grep { $buildarch->clone->type == $_ } @READABLE) {
            $h->{has_name} = 1;
            $h->{has_text} = 1;
         }

         $arch->name => $h
      } values %materials
   })
};

cf::register_extcmd builder_build => sub {
   my ($pl, $msg) = @_;
   my ($dx, $dy) = @$msg{qw(dx dy)};
   my ($x, $y) = ($pl->ob->x + $dx, $pl->ob->y + $dy);

   my $buildable = 0;

   unless ($pl->ob->flag (cf::FLAG_WIZ)) {
      for ($pl->ob->map->at ($x, $y)) {
         unless ($_->flag (cf::FLAG_IS_BUILDABLE)) {
            return;
         }
      }
   }

   if ($msg->{do_erase}) {
      if ($pl->ob->flag (cf::FLAG_WIZ)) {
         my ($top) = reverse $pl->ob->map->at ($x, $y);
         $top->destroy if ($top and $top->flag (cf::FLAG_IS_BUILDABLE));
      } else {
         for my $ob ($pl->ob->map->at ($x, $y)) {
            unless ($ob->type == cf::BUILDABLE_WALL || $ob->type == cf::FLOOR || $ob->flag (cf::FLAG_IS_FLOOR)) {
               $ob->destroy if $ob->flag (cf::FLAG_IS_BUILDABLE);
            }
         }
      }
   }

   return unless $msg->{item};

   return unless $pl->cell_visible ($dx, $dy);
   my $arch = cf::arch::find $msg->{item};

   if ($arch->clone->subtype == cf::ST_MAT_FLOOR) {
      my $above_floor;
      for my $ob ($pl->ob->map->at ($x, $y)) {
         if ($ob->type == cf::BUILDABLE_WALL) {
            undef $above_floor if $above_floor == $ob;
            $ob->destroy;
         } elsif ($ob->type == cf::FLOOR || $ob->flag (cf::FLAG_IS_FLOOR)) {
            undef $above_floor if $above_floor == $ob;
            $above_floor = $ob->above;
            $ob->destroy;
         }
      }

      my $floor = cf::object::new $arch->clone->slaying;
      $floor->flag (cf::FLAG_IS_BUILDABLE, 1);
      $floor->flag (cf::FLAG_UNIQUE, 1);
      $floor->flag (cf::FLAG_IS_FLOOR, 1);
      $floor->type (cf::FLOOR);
      $floor->insert_ob_in_map_at ($pl->ob->map, $above_floor, ($above_floor ? cf::INS_BELOW_ORIGINATOR : cf::INS_ON_TOP), $x, $y);

      $pl->ob->map->fix_walls_around ($x, $y);

   } elsif ($arch->clone->subtype == cf::ST_MAT_WALL) {
      my @obs = $pl->ob->map->at ($x, $y);
      my $prev_wall;
      for (@obs) {
         if ($_->type == cf::BUILDABLE_WALL) {
            $prev_wall = $_;
            last;
         }
      }

      my ($floor) =
         grep { $_->type == cf::FLOOR || $_->flag (cf::FLAG_IS_FLOOR) }
            $pl->ob->map->at ($x, $y);

      my $above_floor = $floor->above;
      if ($above_floor) {
         return;
      }

      my $wall = cf::object::new $arch->clone->slaying;
      $wall->type (cf::BUILDABLE_WALL);
      $wall->flag (cf::FLAG_IS_BUILDABLE, 1);
      $wall->insert_ob_in_map_at ($pl->ob->map, undef, cf::INS_ABOVE_FLOOR_ONLY, $x, $y);
      if ($prev_wall) {
         $prev_wall->destroy;
         $pl->ob->map->fix_walls ($pl->ob->x + $dx, $pl->ob->y + $dy);
      } else {
         $pl->ob->map->fix_walls_around ($pl->ob->x + $dx, $pl->ob->y + $dy);
      }

   } elsif ($arch->clone->subtype == cf::ST_MAT_ITEM) {
      my ($floor) =
         grep { $_->type == cf::FLOOR || $_->flag (cf::FLAG_IS_FLOOR) }
            $pl->ob->map->at ($x, $y);

      unless ($floor) {
         return;
      }

      if ($floor->above) {
         return;
      }

      my $ob = cf::object::new $arch->clone->slaying;
      $ob->flag (cf::FLAG_IS_BUILDABLE, 1);
      $ob->flag (cf::FLAG_NO_PICK, 1);
      $ob->insert_ob_in_map_at ($pl->ob->map, undef, cf::INS_ABOVE_FLOOR_ONLY, $x, $y);

      if (defined $msg->{connection}) {
         $ob->add_button_link ($pl->ob->map, $msg->{connection});
      }
      if (defined $msg->{text}) {
         $ob->msg ($msg->{text});
      }
      if (defined $msg->{name}) {
         my $name = $msg->{name};
         $ob->name ($msg->{name});
      }
      if ((grep { $ob->type == $_ } @READABLE) && $ob->invisible) {
         $ob->name ("talking " . $ob->name);
         $ob->invisible (0);
      }
   }
};

my $farch = cf::arch::first;
while ($farch) {
   if ($farch->clone->type == cf::MATERIAL) {
      if (cf::arch::find $farch->clone->slaying) {
         $materials{$farch->name} = $farch;
      } else {
         warn "Undefined build archetype '".($farch->clone->slaying)."' for build material '".($farch->name)."'\n";
      }
   }
   $farch = $farch->next;
}
Revision:	1.2
Committed:	Wed Dec 20 12:09:35 2006 UTC (17 years, 5 months ago) by elmex
Branch:	MAIN
CVS Tags:	STABLE, rel-2_0, rel-2_1
Changes since 1.1:	+6 -6 lines
Log Message:	fixed some checking about what to erase :-)
#	User	Rev	Content
1	root	1.1	#!perl
2
3			our %materials;
4
5			our @CONNECTABLE = (
6			cf::DOOR,
7			cf::GATE,
8			cf::BUTTON,
9			cf::DETECTOR,
10			cf::TIMED_GATE,
11			cf::PEDESTAL,
12			cf::CF_HANDLE,
13			cf::MAGIC_EAR
14			);
15			our @READABLE = (cf::SIGN, cf::MAGIC_EAR);
16
17			$cf::CFG{"editor_builder_ui"}
18			or return;
19
20			cf::register_extcmd builder_player_items => sub {
21			my ($pl, $msg) = @_;
22
23			(items => {
24			map {
25			my $arch = $_;
26			my $buildarch = cf::arch::find ($arch->clone->slaying);
27			my $h = { value => $arch->clone->value, build_arch_name => $buildarch->name };
28
29			if (((grep { $buildarch->clone->type == $_ } @CONNECTABLE) > 0)
30			\|\| ($buildarch->name eq 'magic_mouth' && $buildarch->clone->type == cf::SIGN)) {
31			$h->{has_connection} = 1;
32			}
33
34			if (grep { $buildarch->clone->type == $_ } @READABLE) {
35			$h->{has_name} = 1;
36			$h->{has_text} = 1;
37			}
38
39			$arch->name => $h
40			} values %materials
41			})
42			};
43
44			cf::register_extcmd builder_build => sub {
45			my ($pl, $msg) = @_;
46			my ($dx, $dy) = @$msg{qw(dx dy)};
47			my ($x, $y) = ($pl->ob->x + $dx, $pl->ob->y + $dy);
48
49			my $buildable = 0;
50
51			unless ($pl->ob->flag (cf::FLAG_WIZ)) {
52			for ($pl->ob->map->at ($x, $y)) {
53			unless ($_->flag (cf::FLAG_IS_BUILDABLE)) {
54			return;
55			}
56			}
57			}
58
59			if ($msg->{do_erase}) {
60			if ($pl->ob->flag (cf::FLAG_WIZ)) {
61			my ($top) = reverse $pl->ob->map->at ($x, $y);
62	elmex	1.2	$top->destroy if ($top and $top->flag (cf::FLAG_IS_BUILDABLE));
63	root	1.1	} else {
64			for my $ob ($pl->ob->map->at ($x, $y)) {
65	elmex	1.2	unless ($ob->type == cf::BUILDABLE_WALL \|\| $ob->type == cf::FLOOR \|\| $ob->flag (cf::FLAG_IS_FLOOR)) {
66			$ob->destroy if $ob->flag (cf::FLAG_IS_BUILDABLE);
67	root	1.1	}
68			}
69			}
70			}
71
72			return unless $msg->{item};
73
74			return unless $pl->cell_visible ($dx, $dy);
75			my $arch = cf::arch::find $msg->{item};
76
77			if ($arch->clone->subtype == cf::ST_MAT_FLOOR) {
78			my $above_floor;
79			for my $ob ($pl->ob->map->at ($x, $y)) {
80	elmex	1.2	if ($ob->type == cf::BUILDABLE_WALL) {
81	root	1.1	undef $above_floor if $above_floor == $ob;
82			$ob->destroy;
83			} elsif ($ob->type == cf::FLOOR \|\| $ob->flag (cf::FLAG_IS_FLOOR)) {
84			undef $above_floor if $above_floor == $ob;
85			$above_floor = $ob->above;
86			$ob->destroy;
87			}
88			}
89
90			my $floor = cf::object::new $arch->clone->slaying;
91			$floor->flag (cf::FLAG_IS_BUILDABLE, 1);
92			$floor->flag (cf::FLAG_UNIQUE, 1);
93			$floor->flag (cf::FLAG_IS_FLOOR, 1);
94			$floor->type (cf::FLOOR);
95			$floor->insert_ob_in_map_at ($pl->ob->map, $above_floor, ($above_floor ? cf::INS_BELOW_ORIGINATOR : cf::INS_ON_TOP), $x, $y);
96
97			$pl->ob->map->fix_walls_around ($x, $y);
98
99			} elsif ($arch->clone->subtype == cf::ST_MAT_WALL) {
100			my @obs = $pl->ob->map->at ($x, $y);
101			my $prev_wall;
102			for (@obs) {
103	elmex	1.2	if ($_->type == cf::BUILDABLE_WALL) {
104	root	1.1	$prev_wall = $_;
105			last;
106			}
107			}
108
109			my ($floor) =
110			grep { $_->type == cf::FLOOR \|\| $_->flag (cf::FLAG_IS_FLOOR) }
111			$pl->ob->map->at ($x, $y);
112
113			my $above_floor = $floor->above;
114			if ($above_floor) {
115			return;
116			}
117
118			my $wall = cf::object::new $arch->clone->slaying;
119	elmex	1.2	$wall->type (cf::BUILDABLE_WALL);
120	root	1.1	$wall->flag (cf::FLAG_IS_BUILDABLE, 1);
121			$wall->insert_ob_in_map_at ($pl->ob->map, undef, cf::INS_ABOVE_FLOOR_ONLY, $x, $y);
122			if ($prev_wall) {
123			$prev_wall->destroy;
124			$pl->ob->map->fix_walls ($pl->ob->x + $dx, $pl->ob->y + $dy);
125			} else {
126			$pl->ob->map->fix_walls_around ($pl->ob->x + $dx, $pl->ob->y + $dy);
127			}
128
129			} elsif ($arch->clone->subtype == cf::ST_MAT_ITEM) {
130			my ($floor) =
131			grep { $_->type == cf::FLOOR \|\| $_->flag (cf::FLAG_IS_FLOOR) }
132			$pl->ob->map->at ($x, $y);
133
134			unless ($floor) {
135			return;
136			}
137
138			if ($floor->above) {
139			return;
140			}
141
142			my $ob = cf::object::new $arch->clone->slaying;
143			$ob->flag (cf::FLAG_IS_BUILDABLE, 1);
144			$ob->flag (cf::FLAG_NO_PICK, 1);
145			$ob->insert_ob_in_map_at ($pl->ob->map, undef, cf::INS_ABOVE_FLOOR_ONLY, $x, $y);
146
147			if (defined $msg->{connection}) {
148			$ob->add_button_link ($pl->ob->map, $msg->{connection});
149			}
150			if (defined $msg->{text}) {
151			$ob->msg ($msg->{text});
152			}
153			if (defined $msg->{name}) {
154			my $name = $msg->{name};
155			$ob->name ($msg->{name});
156			}
157			if ((grep { $ob->type == $_ } @READABLE) && $ob->invisible) {
158			$ob->name ("talking " . $ob->name);
159			$ob->invisible (0);
160			}
161			}
162			};
163
164			my $farch = cf::arch::first;
165			while ($farch) {
166			if ($farch->clone->type == cf::MATERIAL) {
167			if (cf::arch::find $farch->clone->slaying) {
168			$materials{$farch->name} = $farch;
169			} else {
170			warn "Undefined build archetype '".($farch->clone->slaying)."' for build material '".($farch->name)."'\n";
171			}
172			}
173			$farch = $farch->next;
174			}