pd.if.org Git - afpopgen/blob - sim/mkimage

   1 #!/usr/bin/env perl
   2
   3 # This program connects to the database and creates one image at a time in a loop
   4 # It can thus be run in parallel
   5
   6 use strict;
   7 use warnings;
   8
   9 use JSON;
  10 use Image::Magick;
  11
  12 my $data = '';
  13
  14 my $forks = 0;
  15
  16 if ($ARGV[0] eq '-f' ) {
  17         shift;
  18         $forks = shift;
  19 }
  20
  21 while (<>) {
  22         $data .= $_;
  23 }
  24 warn "read data\n";
  25
  26 my $json = JSON->new;
  27 my $run = $json->decode($data);
  28
  29 warn "parsed json\n";
  30 my %coords;
  31
  32 my (@min, @max); # bounding box so we can know how big to make the image
  33
  34 my $scale = 5;
  35
  36 # get the vertex coordinates for each hex
  37 if (0) {
  38 my $i=0;
  39 foreach my $hex (@{$run->{hexlist}}) {
  40         my $c = `./hexverts $scale $hex`;
  41         chomp $c;
  42         $coords{$hex} = $c;
  43         $i++;
  44         warn "$i $hex = $c\n";
  45 }
  46 } else {
  47         %coords = do 'verts.pl';
  48 }
  49 #warn keys %coords, "\n";
  50
  51 warn "got coords\n";
  52
  53 my @forks = ();
  54 if ($forks > 0) {
  55         my $elems = @{$run->{gendata}};
  56         my $perfork = int($elems / $forks);
  57         my $leftover = $elems - $perfork * $forks;
  58
  59         my $start = 0;
  60         for my $fork (0..$forks-1) {
  61                 $forks[$fork] = { start => $start, end => $start + $perfork-1 };
  62                 $forks[$fork]{end}++ if $fork < $leftover;
  63                 $start = $forks[$fork]{end}+1;
  64         }
  65 }
  66
  67 my $forkinfo = join(' ', map { sprintf('[%s %s]', $_->{start}, $_->{end}) } @forks);
  68 warn "forks = $forkinfo\n";
  69
  70 while (my $f = shift @forks) {
  71         my $pid = fork;
  72         next if $pid;
  73 foreach my $gen (@{$run->{gendata}}[$f->{start}..$f->{end}]) {
  74         my $image = Image::Magick->new(size => '364x404');
  75         $image->ReadImage('canvas:white');
  76 #       foreach (qw(background fill size colorspace)) {
  77 #               warn "$_ ", $image->Get($_), "\n";
  78 #       }
  79
  80         my %drawn = ();
  81         foreach my $hex (@{$gen->{hexes}}) {
  82                 my $frac = $hex->{freq}[0]/$hex->{pop}/2.0;
  83                 my $maxgenfrac = $hex->{pop} / $gen->{maxpop};
  84                 my @hsv = (
  85                         (4.0 / (1.0 + exp(-($frac - 0.5 ))) - 1.5) / 2.0 + 0.075, # hue
  86                         1.0, # saturation
  87                         0.15+0.85*sqrt($maxgenfrac) # value
  88                 );
  89                 for (@hsv) {
  90                         $_ = 1.0 if $_ > 1.0;
  91                         $_ = 0.0 if $_ < 0.0;
  92                 }
  93
  94                 my $color = sprintf('hsb(%f%%, %f%%, %f%%)', 100 * $hsv[0], 100 * $hsv[1], 100 * $hsv[2]);
  95                 #warn "drawing $color\n";
  96                 die "missing coords for hex ", $hex->{hex}, "\n" unless exists $coords{$hex->{hex}};
  97                 $image->Draw(fill => $color, primitive=>'polygon', antialias => 1, points => $coords{$hex->{hex}});
  98                 $drawn{$hex->{hex}} = 1;
  99         }
 100
 101         foreach my $hex (keys %coords) {
 102                 next if $drawn{$hex};
 103                 $image->Draw(fill => 'black', primitive=>'polygon', points => $coords{$hex});
 104         }
 105
 106         # make a band on the top for a label
 107         # make sure this is a multiple of four, some
 108         # of the movie formats require it
 109         $image->Splice(geometry => '0x20', background => 'white', gravity => 'North');
 110
 111         # now annotate the image
 112         my $x = 5;   # where to put the annotation
 113         my $y = 220;
 114         my $font = 'SourceCodePro-Light.ttf';
 115         my %params = (
 116                 font => $font, fill => 'black', stroke => 'black',
 117                 pointsize => 15, antialias => 1,
 118         );
 119
 120         # set up a title caption
 121         #
 122         my @lines = (
 123                 sprintf('gen: %8d', $gen->{gen}),
 124                 sprintf(q{pop: %8d}, $gen->{pop}),
 125                 sprintf(q{ybp: %8d}, $gen->{year}),
 126         );
 127
 128         for (@lines) {
 129                 $image->Annotate(%params, x => $x, y => $y, text => $_);
 130                 $y += 15;
 131         }
 132 #       $text = sprintf(q{ams: %8d}, $genlen*$gen);
 133 #       $image->Annotate(x => $x, y => $y, -text => $text); $y += 15;
 134
 135         my $prefix = $ENV{IMGPREFIX};
 136         $prefix ||= '';
 137
 138         my $name = $prefix . sprintf('%04d.png', $gen->{gen});
 139         $image->Write($name);
 140         warn sprintf("%s gen %d pop %d\n", $name, $gen->{gen}, $gen->{pop});
 141 }
 142 exit 0;
 143 }
 144
 145 while (wait != -1) {};
 146
 147 sub mkdirp {
 148         my $path = '.';
 149         foreach my $comp (@_) {
 150                 $path .= "/$comp";
 151                 mkdir $path unless -d $path;
 152                 die "can't make director $path: $!" unless -d $path;
 153         }
 154 }
 155 __END__