# Games::Construder - A 3D Game written in Perl with an infinite and modifiable world.
# Copyright (C) 2011  Robin Redeker
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU Affero General Public License as
# published by the Free Software Foundation, either version 3 of the
# License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU Affero General Public License for more details.
#
# You should have received a copy of the GNU Affero General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
#
package Games::Construder;
use JSON;
use common::sense;
use Time::HiRes qw/time/;
use Games::Construder::Logging;

require Exporter;
our @ISA = qw/Exporter/;
our @EXPORT = qw/
   ctr_prof
/;

our $VERSION = '0.95';

use XSLoader;
XSLoader::load "Games::Construder", $Games::Construder::VERSION;

=head1 NAME

Games::Construder - A 3D game written in Perl, which is actually playable!

=head1 SYNOPSIS

   Starting the server:

   user@host ~# construder_server

   Starting the client:

   user@host ~# construder_client

=head1 DESCRIPTION

This is the source code documentation for the game called "Construder".

If you search for information on how to actually play it please look at
the official website for introduction videos:

L<http://ue.o---o.eu/>

You can also find other interesting information there, such as screenshots,
the motivation of writing this game or B<where to go with questions and/or bug
reports.>

=head1 PACKAGES

This specific module file provides the XS bindings and also some utility
functions that are used in many places in the game.

=over 4

=cut

sub ctr_prof {
   my ($name, $sub) = @_;

   ctr_cond_log (profile => sub {
      my $t1 = time;
      $sub->();
      ctr_log (profile => "ctr_prof[%-20s] %0.4f\n", $name, time - $t1);
   }, sub { $sub->() });
}

package Games::Construder::Util;

sub visible_chunks_at {
   my ($pos, $rad) = @_;

   my $chnks =
      Games::Construder::Math::calc_visible_chunks_at (@$pos, $rad);
   my @o;
   for (my $i = 0; $i < @$chnks; $i += 3) {
      push @o, [$chnks->[$i], $chnks->[$i + 1], $chnks->[$i + 2]];
   }
   #d#warn "visible chunks: " . scalar (@o) . "\n";
   return @o
}

package Games::Construder::VolDraw;
use Games::Construder::Logging;

sub _get_file {
   my ($file) = @_;
   open my $f, "<", $file
      or die "Couldn't open '$file': $!\n";
   binmode $f, ":raw";
   do { local $/; <$f> }
}

my %OPS = (
   add  => 1,
   sub  => 2,
   mul  => 3,
   set  => 4,
   set_if_0 => 5,
   set_if_1 => 6,
);

sub lerp {
   my ($a, $b, $x) = @_;
   $a * (1 - $x) + $b * $x
}

sub show_map_range {
   my ($a, $b) = @_;
   map_range (0, $a - 0.000001, 0, 0);
   map_range ($b + 0.000001, 2, 0, 0);
   map_range ($a, $b, 0, 0.6); # enhance contrast a bit maybe
}

sub draw_commands {
   my ($str, $env) = @_;

   $env->{seed}++; # offset by 1, so we get no 0 should be unsigned anyways

   my (@lines) = map { $_ =~ s/#.*$//; $_ } split /\r?\n/, $str;
   my (@stmts) = map { split /\s*;\s*/, $_ } @lines;

   for (@stmts) {
      s/^\s+(.*?)\s*$/$1/;
      next if $_ eq '';

      my ($cmd, @arg) = split /\s+/, $_;

      (@arg) = map {
            $_ =~ /P([+-]?\d+(?:\.\d+)?)\s*,\s*([+-]?\d+(?:\.\d+)?)/
               ? lerp ($1, $2, $env->{param})
               : ($_ eq 'P' ?  $env->{param} : $_)
      } @arg;

      if ($cmd eq 'mode') {
         set_op ($OPS{$arg[0]});

      } elsif ($cmd eq 'end') {
         last;

      } elsif ($cmd eq 'src_dst') { # set source and destination buffer (0..3)
         set_src ($arg[0]);
         set_dst ($arg[1]);

      } elsif ($cmd eq 'dst_range') {
         # set modifiable range of destination buffer
         $arg[0] = 0 unless $arg[0] ne '';
         $arg[1] = 0 unless $arg[1] ne '';
         set_dst_range ($arg[0], $arg[1]);

      } elsif ($cmd eq 'src_range') {
         # set range of source color to draw with
         $arg[0] = 0 unless $arg[0] ne '';
         $arg[1] = 0 unless $arg[1] ne '';
         set_src_range ($arg[0], $arg[1]);

      } elsif ($cmd eq 'src_blend') {
         # amount with which source will be blended,
         # negative amount will invert the drawn colors
         $arg[0] = 1 unless $arg[0] ne '';
         set_src_blend ($arg[0]);

      } elsif ($cmd eq 'fill') {
         # fill with either color or
         # draw destination buffer over itself (allows blending with src_blend)
         if ($arg[0] ne '') {
            val ($arg[0]);
         } else {
            dst_self ();
         }

      } elsif ($cmd eq 'fill_noise') {
         # fill destination with noise
         # fill_noise <octaves> <scale factor> <persistence> <seed offset>
         fill_simple_noise_octaves ($env->{seed} + $arg[3], $arg[0], $arg[1], $arg[2]);

      } elsif ($cmd eq 'spheres') {
         # draw spheres
         # spheres <recursion-cnt> <shrink factor (default 0)>
         subdiv (1, 0, 0, 0, $env->{size}, defined $arg[1] ? $arg[1] : 0, $arg[0]);

      } elsif ($cmd eq 'cubes') {
         # draw spheres
         # cubes <recursion-cnt> <shrink factor (default 0)>
         subdiv (0, 0, 0, 0, $env->{size}, defined $arg[1] ? $arg[1] : 0, $arg[0]);

      } elsif ($cmd eq 'triangles') {
         # draw spheres
         # triangles <recursion-cnt> <shrink factor (default 0)>
         subdiv (2, 0, 0, 0, $env->{size}, defined $arg[1] ? $arg[1] : 0, $arg[0]);

      } elsif ($cmd eq 'self_cubes') {
         # draw spheres
         # spheres <missing corners> <recursion-cnt> <seed offset>
         self_sim_cubes_hash_seed (0, 0, 0, $env->{size}, $arg[0], $env->{seed} + $arg[2], $arg[1]);

      } elsif ($cmd eq 'menger_sponge') {
         # draw menger sponge <level>
         menger_sponge_box (0, 0, 0, $env->{size}, $arg[0]);

      } elsif ($cmd eq 'cantor_dust') {
         # draw cantor dust <level>
         cantor_dust_box (0, 0, 0, $env->{size}, $arg[0]);

      } elsif ($cmd eq 'sierpinski_pyramid') {
         # sierpinski_pyramid <level>
         sierpinski_pyramid (0, 0, 0, $env->{size}, $arg[0]);

      } elsif ($cmd eq 'map_range') {
         # map range of destionation buffer
         map_range ($arg[0], $arg[1], $arg[2], $arg[3]);

      } elsif ($cmd eq 'hist_equalize') {
         # hist_equalize <number of buckets> <range from> <range to>
         histogram_equalize ($arg[0] || 1, $arg[1], $arg[2]);

      } elsif ($cmd eq 'coords') {
         ($env->{coords_x}, $env->{coords_y}, $env->{coords_z},
          $env->{coords_sx}, $env->{coords_sy}, $env->{coords_sz}) = (@arg);

      } elsif ($cmd eq 'mandelbox') {
         # mandelbox <s> <r> <f> <it> <coordscale>
         mandel_box ($env->{coords_x}, $env->{coords_y}, $env->{coords_z}, $env->{coords_sx}, $env->{coords_sy}, $env->{coords_sz}, $arg[0], $arg[1], $arg[2], $arg[3], $arg[4]);

      } elsif ($cmd eq 'show_region_sectors') {
         # show_region_sectors
         my %sectors;

         my $wg = JSON->new->relaxed->decode (_get_file ("res/world_gen.json"));
         for my $type (keys %{$wg->{sector_types}}) {
            my $s = $wg->{sector_types}->{$type};
            my $r = $s->{region_range};
            $sectors{$type} = [count_in_range (@$r), $r];
         }

         my $acc = 0;
         for (sort { $sectors{$b}->[0] <=> $sectors{$a}->[0] } keys %sectors) {
            my $p = $sectors{$_}->[0] / (100 ** 2);
            $acc += $p;
            printf "%2s: %7d (%5.2f%% acc %5.2f%%) [%5.4f,%5.4f)\n",
                   $_, $sectors{$_}->[0], $p, $acc, @{$sectors{$_}->[1]};
         }

      } elsif ($cmd eq 'show_range_region_sector') {
         # show_range_region_sector <sector type>
         my ($type) = @arg;
         my $wg = JSON->new->relaxed->decode (_get_file ("res/world_gen.json"));
         my $s = $wg->{sector_types}->{$type};
         my $r = $s->{region_range};
         unless ($r) {
            ctr_log (warn => "No region range for sector type '$type' found!\n");
         }
         show_map_range (@$r);

      } elsif ($cmd eq 'show_range_sector_type') {
         # show_range_region_sector <sector type> <idx in range array>
         my ($type, $range_idx) = @arg;
         my $wg = JSON->new->relaxed->decode (_get_file ("res/world_gen.json"));
         my $s = $wg->{sector_types}->{$type};
         my $r = $s->{ranges};
         unless ($r) {
            ctr_log (warn => "No ranges for sector type '$type' found!\n");
         }
         show_map_range ($r->[$range_idx * 3], $r->[($range_idx * 3) + 1]);

      } else {
         warn "unknown draw command: $_\n";
      }
   }
}

package Games::Construder::Debug;
use Games::Construder::Logging;
use AnyEvent;
use AnyEvent::Debug;

our $SHELL;

our $PROF_TMR;

our @CCNT_NAMES = qw/
   chunk_changes
   active_cell_changes
   allocated_axises
   allocated_axises_size
   noise_cnt
   noise_size
   dyn_buf_cnt
   dyn_buf_size
   geom_cnt
   allocated_chunks
/;

sub init {
   my ($name) = @_;

   $PROF_TMR = AE::timer 60, 60, sub {
      my $c_cntrs = Games::Construder::World::get_prof_counters ();
      ctr_log (memory_prof => "C Counters:");
      my @names = @CCNT_NAMES;
      for (@$c_cntrs) {
         my $name = shift @names;
         ctr_log (memory_prof => "   %20s: %d", $name, $_);
      }
   };

   return unless $ENV{PERL_GAMES_CONSTRUDER_DEBUG};

   eval <<'ADDFUNCS';
require Data::Dumper;

sub ::AnyEvent::Debug::shell::d {
   my ($d) = @_;
   Data::Dumper::Dumper ($d)
}

sub ::AnyEvent::Debug::shell::wf {
   my ($name, $data) = @_;
   open my $fh, ">", "/tmp/$name.construder_debug"
      or die "Couldn't open /tmp/$name.debug: $!\n";
   binmode $fh;
   print $fh $data;
   close $fh;
   print "wrote /tmp/$name.construder_debug";
}
ADDFUNCS

   $Data::Dumper::Indent = 2;

   my $sock = "/tmp/construder_shell_$name";

   $SHELL = AnyEvent::Debug::shell "unix/", $sock;
   if ($SHELL) {
      ctr_log (info => "started shell at $sock, use with: 'socat readline $sock'\n");
   }
}

=back

=head1 AUTHOR

Robin Redeker, C<< <elmex@ta-sa.org> >>

=head1 SEE ALSO

L<http://www.deliantra.net/> - Another game written with a lot of Perl, facilitating C<Coro>, C<IO::AIO>, C<AnyEvent>, C<JSON> and many other Perl modules.

=head1 COPYRIGHT & LICENSE

Copyright 2011 Robin Redeker, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the terms of the GNU Affero General Public License.

=cut

1;