Re: Processus simple et rapide.

Ce script sert juste à lancer les différents outils. Rien d'extraordinaire. Il est un peu inutilement compliqué dans le but de me faire réapprendre Perl, plus pratiqué depuis 5 ans. Les commentaires mélangent anglais et français.

#!/usr/bin/perl
use strict; 
use warnings; 
# Le script prend les scans, les repagine (le livre 
# est reliés en cahiers, décousus pour les scans), 
# et met les pages dans un dossier temporaires. 
# Les fichiers y sont retravaillés puis copiés dans 
# un dossier pour l'OCR.
#
# Les paramètres fins sont à adapter au type de scan.
#
# reliure de latin religare
# cahier de reliure = Section (bookbinding)
# In bookbinding, a section, gathering, or signature is a group of sheets folded in half. 
# In medieval manuscripts, a gathering, or quire, was most often formed of 4 folded sheets
# La technique du cahier est née avec le développement de la forme codex. 
use File::Basename; 
use Image::Magick;
# à utiliser pour gérer les chemins Win, Mac, Linux...
# require File::Spec; 
# TODO
# Page dewarping if needed
# from https://mzucker.github.io/2016/08/15/page-dewarping.html
# B&W binarisation or TEXTCLEANER ?
# http://www.fmwconcepts.com/imagemagick/textcleaner/index.php
#
# front and back cover are named couv
# unnecessary scanned files are named 
# other scanned files are named with the page odd number
#
# taille des cahiers (feuilles x 2)
my $sheetNumber = 8 ; # quire size x2
# pourcentage pour redimensionner (maj ~= 33px)
my $percent = 92;
# scans directory (base directory)
my $baseDir = '/home/toto/Projets/Livre'; # FIXME le choper avec 'pwd'
# working dir
my $tmpDir = '_tmp';
# final dir (OCR ready)
my $ocrDir = 'ocr';
# FIXME access rights
# $dirMode = 644;
# se placer dans le bon répertoire
# créer les répertoires temporaires et finaux
chdir $baseDir || die "Could not go in dir $baseDir\n";
mkdir ( $tmpDir ) unless -e $tmpDir; # $dirMode ?
mkdir ( $ocrDir ) unless -e $ocrDir; # $dirMode ?
# get the file list, all names are odd numbers
# put it in a hash with key = page number, value = file name
my @tmpList = listFiles( $baseDir,'jpg' );
my %files = hashList( @tmpList );
# create individual pages
# Unfold();
# improve quality with noteshrink, unpaper and further enhancement
chdir $tmpDir;
callUnpaper('ppm');
# callNoteshrink('-U');
# callSmallOperations('-N');
# callNoteshrink('ppm'); # creates -N files
# callSmallOperations('-N'); # creates -SO files
# callUnpaper('-SO'); # creates -U files
Ready('-SO');
#
# functions
#
# Noise Removal with noteshrink
# https://github.com/mzucker/noteshrink
# -p % of pixels to sample for background( default 5)
# -v background value threshold % (default 25)
# -s background saturation threshold % (default 20)
# -S do not saturate colors
# -w make background white
# -n number of output colors (default 8)
# -b output PNG filename base
sub callNoteshrink {
 my ( $match ) = @_;
 @tmpList = listFiles( "$baseDir/$tmpDir",$match );
 print scalar @tmpList . " files to optimize with noteshrink : \n\n";
 foreach my $file( @tmpList ) {
 # empty pages makes it crash, stupid hack
 next if $file eq '1.ppm';
 next if $file eq '2.ppm';
 next if $file eq '4.ppm';
 next if $file eq '176.ppm';
 # remove extension
 my $fileName = fileName($file);
 # '-v10', '-n12', '-S', 
 my @args = ( "$baseDir/noteshrink-master/noteshrink.py", '-w', "-b$fileName", $file );
 system(@args) == 0 or die "system @args failed (file is $file): $?";
 }
 print scalar @tmpList . " png files created by noteshrink.\n";
 @tmpList = listFiles( "$baseDir/$tmpDir",'png' );
 print scalar @tmpList . " png files to convert in ppm \n";
 # convert files to ppm
 foreach my $file( @tmpList ) {
 my( $image, $x, $filename );
 $image = Image::Magick->new;
 $image->Read( $file );
 $filename = fileName($file);
 # remove 0000 from noteshrink
 $filename =~ s/0000$//;
 $x = $image->Write( "$filename-N.ppm" );
 }
 unlink @tmpList;
 print scalar @tmpList . " png files converted to ppm. All png deleted. \n\n";
}
# small operations
sub callSmallOperations {
 my ( $match ) = @_;
 @tmpList = listFiles( "$baseDir/$tmpDir",$match );
 print "Around " . scalar @tmpList . " files to rework : \n\n";
 foreach my $file( @tmpList ) { 
 my( $image, $w, $h, $x, $filename );
 $image = Image::Magick->new;
 print "Opened $file \n";
 $image->Read( $file );
 ( $w,$h ) = $image->Get( 'width','height' );
 print " size is $w x $h pixels, ";
 # rescale to get optimal capital letter size > 33 pixels
 # not automaticaly detected, gives manual percentage
 $w = $w * $percent/100;
 $h = $h * $percent/100;
 print "optimize capital letter size ... \n";
 $x = $image->Resize( width=>$w, height=>$h );
 # remove Scanning border if any
 # FIXME -trim avec +repage à cause des traitements suivants
# print "remove scanning border ... ";
# $image->Set( fuzz=>'5%' );
# $x = $image->Trim();
 # add small white borde to help OCR 
 print " add a 20 pixels white border ... \n";
 $x = $image->Shave( geometry=>'20x20' );
 $x = $image->Border( geometry=>'20x20+20+20', bordercolor=>'white', compose=>'Over' );
 # write image
 $filename = fileName($file);
 $x = $image->Write( "$filename-SO.ppm" );
 print " $filename.ppm saved. \n";
 undef $image;
 }
 print "\n" . scalar @tmpList . " ppm files reworked.\n\n";
}
# unpaper 
# -ni intensity, -noisefilter-intensity intensity 
# Intensity with which to delete individual pixels or tiny clusters of pixels. 
# Any cluster which only contains intensity dark pixels together will be deleted. (default: 4)
# -li ratio, --blurfilter-intensity ratio
# Relative intensity with which to delete tiny clusters of pixels. 
# Any blurred area which contains at most the ratio of dark pixels 
# will be cleared. (default: 0.01)
# -gt ratio, --grayfilter-threshold ratio
# Relative intensity of grayness which is accepted 
# before clearing the grayfilter mask in cases where 
# no black pixel is found in the mask. (default: 0.5)
# w threshold, --white-threshold threshold 
# Brightness ratio above which a pixel is considered white. (default: 0.9)
sub callUnpaper {
 my ( $match ) = @_;
 @tmpList = listFiles( "$baseDir/$tmpDir",$match );
 print "Around " . scalar @tmpList . " files to optimize with unpaper : \n\n";
 foreach my $file( @tmpList ) {
 my $filename = fileName( $file );
 # unpaper can't overwrite, remove existing files
 $filename = "$filename-U.ppm";
 unlink $filename if -e $filename ;
 # TODO enlever plus
# '--blurfilter-intensity','1', 
# '--grayfilter-threshold','1',
# '--noisefilter-intensity','1',
# '--white-threshold','0.9',
 my @args = ( "unpaper", 
 $file, $filename );
 system(@args) == 0 or die "system @args failed: $?";
 }
 print scalar @tmpList . " new ppm files created.\n\n";
}
# files ready to move in OCR
sub Ready {
 my ( $match ) = @_;
 @tmpList = listFiles( "$baseDir/$tmpDir",$match );
 print "Around " . scalar @tmpList . " files to move to $ocrDir : \n";
 foreach my $file( @tmpList ) { 
 my( $image, $x );
 $image = Image::Magick->new;
 $image->Read( $file );
 # name update
 my $key = fileName($file);
 my $name = $files{$key};
 $x = $image->Write( "$baseDir/$ocrDir/$name" );
 print " $name saved in $ocrDir folder. \n";
 }
 print "Finished. \n\n"
}
# Create temporary individual page's files. 
# Don't forget all file's name are odd
sub Unfold {
 print "\n\n" . scalar @tmpList . " files to unfold ... ";
 # without cover files, loop is ((scalar @tmpList) / $sheetNumber) times 
 # remove unnecessary files from the loop first
 my $zeroFiles = ( scalar @tmpList ) % $sheetNumber;
 my $goodFiles = ( scalar @tmpList ) - $zeroFiles;
 print "$zeroFiles files not kept, $goodFiles files to paginate ... \n";
 #
 # 13ème apôtre = in-4° de 11 cahiers
 # 11 cahiers -> 44 feuilles -> 88 fichiers + couverture + un scan à remonter = 90 fichiers
 # boucler 11 fois
 # sur un cahier de 8 fichiers, 1er: $first impair, 8ème: $last pair
 # boucler 8 fois :
 # couper fichier en 2 : pair / impair
 # écrire pair, impair
 # pair = pair- 2 impair = impair + 2
 #
 # first page number from quire is odd
 my $first = 1;
 # start key in %files, all keys are odd numbers
 my $key = $first;
 # every $sheetNumber files (11 times)
 for ( my $i=0;$i<$goodFiles/$sheetNumber;$i++ ) {
 # last page number from quire, even
 my $last = $first + (2 * $sheetNumber) - 1;
 for ( my $i=0;$i<$sheetNumber;$i++ ) {
 my $file = $files{$key};
 print "Will paginate $file ... ";
 ( $last, $first ) = paginate( $file, $last, $first );
 print "\n";
 $key = $key + 2;
 }
 }
 print "done, $goodFiles pages processed, " . $goodFiles*2 . " files created in $tmpDir. \n\n";
}
#
# utilities
#
# remove extension and space
sub fileName {
 my ( $f ) = @_;
 $f =~ s/\.[a-z]+$//g;
 $f =~ s/\-[A-Z]+$//g;
 $f =~ s/\s+//;
 return $f;
}
# coupe, nomme, écrit
# read all file formats supported by IM, but write in ppm format
sub paginate {
 my ( $file, $even, $odd ) = @_;
 my( $image, $image1, $w, $h, $x );
 $image = Image::Magick->new;
 $image->Read( $file );
 $image1 = $image->Clone();
 ( $w,$h ) = $image->Get( 'width','height' );
 $w = $w / 2;
 # first half is even
 $x = $image->Crop ( geometry=>"$w x $h + 0 + 0" );
 $x = $image->Write( "$tmpDir/$even.ppm" );
 print "created $tmpDir/$even.ppm ";
 # second half is odd
 $x = $image1->Crop ( geometry=>"$w x $h + $w + 0" );
 $x = $image1->Write( "$tmpDir/$odd.ppm" );
 print "and $tmpDir/$odd.ppm";
 # empty memory
 undef $image; 
 undef $image1;
 $even = $even - 2;
 $odd = $odd + 2;
 return $even, $odd;
}
# extract page number, hash with number => name of file
sub hashList {
 my ( @list ) = @_;
 my %hash;
 foreach my $l ( @list ) {
 my $v = $l;
 $l =~ s/[^0-9]+//g;
 $hash{$l} = $v;
 }
 return %hash;
}
# extraire les nombres, créer un hash nombre => fichier,
# sortir une liste triée par la clé du hash
sub orderedList {
 my ( @list ) = @_;
 my %hash;
 foreach my $l ( @list ) {
 my $v = $l;
 $l =~ s/[^0-9]+//g;
 $hash{$l} = $v;
 }
 my @keys = sort { $a <=> $b } keys %hash;
 my @olist;
 foreach my $key ( @keys ) {
 next if $hash{$key} =~ m/\s0/; # fichiers 00
 push (@olist, $hash{$key});
 }
 return @olist;
}
# directory content (not recursive)
# FIXME should use file type instead of extension
sub listFiles {
 my ( $dir, $ext ) = @_;
 opendir( D,$dir ) || die "Could not open dir $dir\n";
 # files and dir but (. and ..) 
 my @content = grep { !/^\.\.?$/ } readdir D;
 closedir D;
 # remove dir
 my @files; 
 foreach my $name (@content) {
 next if -d $name ;
 push @files, $name if $name =~ m/$ext/;
 }
 return @files;
}