source: trunk/npemap.org.uk/scripts/tile-processing/makeSmaller.pl @ 712

Last change on this file since 712 was 712, checked in by Nick Burch, 10 years ago

Per-decade support in tile scripts

  • Property svn:executable set to *
File size: 7.1 KB
Line 
1#!/usr/bin/perl
2#
3# Copyright (c) 2006-2007 David Sheldon and Nick Burch
4# Permission is hereby granted, free of charge, to any person obtaining a
5# copy of this software and associated documentation files (the "Software"),
6# to deal in the Software without restriction, including without limitation
7# the rights to use, copy, modify, merge, publish, distribute, sublicense,
8# and/or sell copies of the Software, and to permit persons to whom the
9# Software is furnished to do so, subject to the following conditions:
10#
11# The above copyright notice and this permission notice shall be included in
12# all copies or substantial portions of the Software.
13#
14# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
15# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
16# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
17# THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
18# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
19# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
20# IN THE SOFTWARE.
21#
22#
23# This script reads in 1km grid square images from <map>-tiles-<year>
24#  directories, and outputs (scaled) images as scaled#/<eee>/<nnn>.jpg
25# By default it will go for the newest files it can, but if run from a
26#  decade based directory, will be constrained to the newest tiles
27#  of that decade.
28#
29use List::Util qw[min max];
30use Image::Magick;
31
32my $tilesize = 125;
33
34my $scale = shift;
35unless($scale) { $scale = 6; }
36
37# Should we rescale as we go?
38my $rescale_by = 1;
39if($scale > 20) {
40        $rescale_by = 4;
41}
42my $out_tile_size = int($tilesize / $rescale_by);
43
44my $outdir = "scaled$scale";
45
46if (! -d $outdir) {
47    mkdir $outdir or die "Unable to create dir '$outdir'"
48}
49
50# Are we running across all tiles in search of the most recent, or
51#  are we constrained by a given decade?
52my $dir_glob = "*";
53
54my $current_dir = `pwd`;
55chomp $current_dir;
56if($current_dir =~ /\/(19[0-6]0)s$/) {
57    my $decade = $1;
58    my $decade_match = substr($decade,0,3)."?";
59    $dir_glob = "../*-$decade_match";
60
61    print "Restricting to just tiles from the decade '$decade'\n";
62} else {
63    print "Using the most recent tiles available\n";
64}
65print "\n";
66sleep 2;
67
68# Find out files
69my @files = glob("$dir_glob/tile-*.jpg");
70my %tiles ;
71
72my $minx, $miny, $maxx, $maxy;
73
74# Sort the tiles by directory name
75# (If we have two copies of the same tile, we want the newest one)
76@files = sort {
77        my ($adate) = ($a =~ /^.*?\-(\d\d\d\d)\//);
78        my ($bdate) = ($b =~ /^.*?\-(\d\d\d\d)\//);
79        if(!$adate && !$bdate) { return $a cmp $b; }
80        if($adate && !$bdate) { return 1; }
81        if($bdate && !$adate) { return -1; }
82        return $adate <=> $bdate;
83} @files;
84
85# Process the files into a hash, based on easting and northing
86foreach my $f (@files) {
87  $f =~ m/-(\d+)-(\-?\d+)\./;
88  my ($x, $y) = ($1 +0, $2 +0);
89  $tiles{$x} ||= {};
90  $tiles{$x}{$y} = $f;
91}
92
93# Figure out our largest easting and northing values
94$maxx = max(keys %tiles);
95$maxy = max(map { max(keys %{$tiles{$_}})} keys %tiles);
96$miny = min(map { min(keys %{$tiles{$_}})} keys %tiles);
97
98# The meta info's to re-create
99# (Only done for scale 1, and only record the eastings to update)
100my %update_meta;
101
102# start at 0, if there are any tiles in a WxW square, render a scale model
103# of it
104
105foreach my $x (0..($maxx/$scale)) {
106    foreach my $y (($miny/$scale)..($maxy/$scale)) {
107        # Note - channel island maps with negative y values will end up
108        #   as scaledX/ddd/-dd.jpg, as the - counts as a digit
109        my $filename = sprintf("%s/%03d/%03d.jpg", $outdir, $x, $y);
110
111                my $meta_filename = sprintf("meta1/%03d.txt", $x);
112        my $outdir = sprintf("%s/%03d/", $outdir, $x);
113               
114                # Do we need to create the meta info?
115                if( ($scale == 1) && (! -f $meta_filename) ) {
116                        $update_meta{$x}++;
117                }
118
119                # Do we need to create / re-create the tile?
120                # (Check if tile exists, then if any of the parent tiles are newer)
121                my $create_tile = 0;
122        if( (! -f $filename) && any_tiles($x, $y, \%tiles) ) {
123                        $create_tile = 1;
124                }
125                foreach my $i (0..($scale -1)) {
126                        foreach my $j (0..($scale -1)) {
127                                if (defined $tiles{($x*$scale)+$i}{($y*$scale)+$j}) {
128                                        my $input = $tiles{($x*$scale)+$i}{($y*$scale)+$j};
129                                        # Is this newer than the tile?
130                                        if(-M $input < -M $filename) {
131                                                $create_tile = 1;
132                                        }
133                                }
134                        }
135                }
136
137                if($create_tile) {
138            print "Making $filename\n";
139            my $out = Image::Magick->new( size => "".($out_tile_size*$scale)."x".($out_tile_size*$scale) );
140            $out ->ReadImage('xc:white');
141
142            unless(-d $outdir) {
143                mkdir($outdir);
144            }
145
146 foreach my $i (0..($scale -1)) {
147     foreach my $j (0..($scale -1)) {
148         if (defined $tiles{($x*$scale)+$i}{($y*$scale)+$j}) {
149            my $input = $tiles{($x*$scale)+$i}{($y*$scale)+$j};
150            my $image = Image::Magick->new;
151            print $image->Read($input);
152            if($scale == 1) {
153                            print "\tIncluding $input\n";
154            }
155
156                        if($rescale_by > 1) {
157                                $image->Resize("${out_tile_size}x${out_tile_size}");
158                                #print "Resized $input to ${out_tile_size}x${out_tile_size}\n";
159                        }
160
161            print $out->Composite(image=>$image, x=> ($i*$out_tile_size), y=> ((($scale -1)-$j)*$out_tile_size) );
162            undef $image;
163        }
164     }
165 }
166
167                        # Do we need to update the meta info?
168                        if($scale == 1) {
169                                $update_meta{$x}++;
170                        }
171                       
172                        # Resize the image to 125x125, and write it out
173            $out->Resize("${tilesize}x$tilesize");
174            $out->Set(quality=>85);
175            $out->Write("jpg:$filename");
176            undef $out;
177            print "\t($x,$y)\n";
178        }
179   }
180}
181
182# Load in our list of what legends apply
183my %legends;
184open(LEGENDS, "<../legends/which.txt");
185while(my $line = <LEGENDS>) {
186    chomp $line;
187    unless($line) { next; }
188    if($line =~ /^(\d+.*?-19\d\d)\s+([\w\d\-\_]+)\s*$/) {
189        my ($dir,$legend) = ($1,$2);
190        $legends{$dir} = $legend;
191    } elsif($line =~ /^(\d+.*?-tiles-WO)\s+([\w\d\-\_]+)\s*$/) {
192        my ($dir,$legend) = ($1,$2);
193        $legends{$dir} = $legend;
194    } else {
195        warn("Invalid legends line: '$line'\n");
196    }
197}
198
199# Re-create the meta files
200foreach my $easting (sort keys %update_meta) {
201        my $meta_filename = sprintf("meta1/%03d.txt", $easting);
202        open(META, ">$meta_filename");
203        print META "# easting,northing,sheet,year,legend\n";
204       
205        foreach my $northing (sort keys %{$tiles{$easting}}) {
206                my $file = $tiles{$easting}{$northing};
207                my ($sheet) = ($file =~ /^(\d+\w?)\-/);
208                my ($year) = ($file =~ /^\d+\w?\-tiles\-(\d+)/);
209                my ($dir) = ($file =~ /^(\d+.*?)\//);
210
211        my $legend = $legends{$dir} or "";
212
213        # Handle Channel Island maps
214        if(!$sheet && $file =~ /^([GJ]\w+)\-tiles\-(\d+)/) {
215            $sheet = $1;
216            $year = $2;
217        }
218
219                print META "${easting},${northing},$sheet,$year,$legend\n";
220        }
221
222        print "Recreated $meta_filename\n";
223        close META;
224}
225
226
227use Data::Dumper;
228
229print "($maxx, $maxy)\n";
230
231sub any_tiles {
232 my ($x, $y, $tiles) = (shift, shift, shift);
233 foreach my $i (0..($scale -1)) {
234     foreach my $j (0..($scale -1)) {
235         if (defined $$tiles{($x*$scale)+$i}{($y*$scale)+$j}) {
236             return 1;
237         }
238     }
239 }
240 return 0;
241}
Note: See TracBrowser for help on using the repository browser.