utils/harness

use strict; use warnings;
use PDL;
use PDL::IO::GD; # for write_gif_anim, bigger file but nicer looking
use PDL::Demos;
use File::Path qw(mkpath);
use File::Spec::Functions qw(catdir catfile splitpath updir);

my $html_header = <<'EOF';
<!DOCTYPE html>
<html lang="en">
<head>
<meta charset="UTF-8">
<meta name="viewport" content="width=device-width, initial-scale=1.0">
<title>%s</title>
</head>
<body>
EOF
my $html_footer = <<'EOF';
</body>
</html>
EOF
my $index_header = <<'EOF';
<!-- Generated with pdl/Demos/harness -->
<h1 class='title'>Demos and Examples</h1>
<p>On the following pages you'll find some examples of how to use PDL
for basic computations and plotting purposes. Several of the examples
are available as demos within <tt>perldl</tt>. For more details try:</p>
<pre>
 <b>perldl></b> demo
</pre>
<ul>
EOF
my $index_footer = <<'EOF';
<li><a href="?page=demos/plot2D">2D plotting with PGPLOT</a></li>
<li><a href="?page=screenshots/index">3D plots</a></li>
</ul>
EOF
my ($name_pat, $name_glob) = qw(output-%d.png output-*.png);

my $destroot = shift;
die "Usage: $0 destroot [singledemo]" unless defined $destroot && -d $destroot;

my $single_demo = shift;
my @infos = map [PDL::Demos->info($_)],
  'pdl', sort grep $_ ne 'pdl', $single_demo || PDL::Demos->keywords;
@infos = grep $_->[0] eq 'pdl' || $_->[1] =~ /Simple|GSL/, @infos;

my @this_output;
sub do_output { push @this_output, map "$_", @_; }
my @titles;
for (@infos) {
  my ($kw, $blurb, $mod) = @$_;
  my $outdir = catdir($destroot, updir, updir, qw(images demos), $kw);
  print " $kw -> $outdir\n";
  $ENV{PDL_SIMPLE_ENGINE} = 'gnuplot';
  $ENV{PDL_SIMPLE_OUTPUT} = catfile($outdir, $name_pat);
  mkpath($outdir) or die "$outdir: $!" if !-d $outdir;
  unlink($_) or die "unlink $_: $!"
    for grep -f, glob catfile($outdir, $name_glob);
  PDL::Demos->init($kw);
  my ($vidcounter, @outframes, %seen_img) = 0;
  for my $frame (PDL::Demos->demo($kw)) {
    my ($cmd, $txt) = @$frame;
    my @lines = split /\n/, $txt;
    shift @lines until $lines[0] =~ /\S/;
    pop @lines until $lines[-1] =~ /\S/;
    die "No non-blank lines found in a frame of $kw, text '$txt'" if !@lines;
    if ($cmd eq 'comment') {
      my $final = join "\n", @lines;
      $final =~ s#\n\n+#\n<p/>\n#g;
      push @outframes, [hyperlink($final)];
      next;
    }
    my ($state, $chunk, @to_execute, @thisframe) = ($lines[0] =~ /^\s*#/ ? 'c' : 'w', '');
    for (@lines) {
      if (/^\s*#+\s*(.*?)\s*#*\s*$/) { # words
        if ($state eq 'c') {
          chomp $chunk;
          push @thisframe, "<pre>\n$chunk\n</pre>" if $chunk;
          $chunk = '';
        }
        $state = 'w';
        $chunk .= $1 ? "$1\n" : "<p/>\n";
      } else {
        if ($state eq 'w') {
          chomp $chunk;
          push @thisframe, $chunk if $chunk;
          $chunk = '';
        }
        $state = 'c';
        $chunk .= "$_\n" if /\S/;
        push @to_execute, $_;
      }
    }
    chomp($chunk), push @thisframe, $state eq 'c' ? "<pre>\n$chunk\n</pre>" : $chunk
      if $chunk;
    if (@to_execute) {
      @this_output = ();
      s#^(\s*)print\b#do_output +#g for @to_execute;
      s#^(\s*)printf\b#do_output sprintf#g for @to_execute;
      my $exec_text = join "\n", "package $mod; *do_output=\\&main::do_output; sub do_output; no strict; use PDL;", @to_execute;
      eval $exec_text;
      die if $@;
      my $o = join('', @this_output)."\n";
      $o =~ s/\A\n+|\n+\z//g;
      $o = "<pre>\n$o\n</pre>" if $o;
      my @this_imgs = map $_->[1], sort {$a->[0]<=>$b->[0]} map [/(\d+)/, $_],
        grep !$seen_img{$_}++, glob catfile($outdir, $name_glob);
      if (@this_imgs) {
        if (@this_imgs > 1) {
          my $multiframe = cat(map rpic($_), @this_imgs);
          my $vidfile = catfile($outdir, "vid-".++$vidcounter.".gif");
          $multiframe->write_gif_anim($vidfile, 0, 10);
          unlink @this_imgs;
          delete @seen_img{@this_imgs}; # may reappear with new content
          @this_imgs = $vidfile;
        }
        $o .= sprintf qq{\n<img src="images/demos/%s/%s"/>}, $kw, (splitpath $this_imgs[0])[2];
      }
      push @thisframe, "<h4>Output</h4>\n$o" if $o;
    }
    $_ = hyperlink($_) for @thisframe;
    push @outframes, \@thisframe;
  }
  PDL::Demos->done($kw);
  rmdir $outdir if !glob catfile($outdir, $name_glob);
  open my $fh, ">", catfile($destroot, "$kw.html");
  $blurb =~ s#\s*\(.*##;
  push @titles, [$kw, my $title = "$kw - $blurb"];
  print $fh sprintf($html_header, $title),
    "<h1>$title</h1>\n\n",
    join("\n\n<hr/>\n", map join("\n", @$_), @outframes), "\n",
    $html_footer;
}
if (!$single_demo) {
  open my $fh, ">", catfile($destroot, "index.html");
  print $fh
    $index_header,
    (map qq{<li><a href="?page=demos/$_->[0]">$_->[1]</a></li>\n}, @titles),
    $index_footer;
}

sub hyperlink {
  my ($text) = @_;
  $text =~ s#PDL::[a-zA-Z0-9_:]+#<a href="https://metacpan.org/pod/$&">$&</a>#g;
  $text =~ s#([^"])(https?:\S+)#$1<a href="$2">$2</a>#g;
  $text;
}