#! /bin/env tclsh
package require critcl
package require ego
package require {ycl chan diagnostic}
alias [yclprefix]::chan::diagnostic
package require {ycl list}
namespace import [yclprefix]::list::pop
namespace import [yclprefix]::list::split
namespace import [yclprefix]::list::take
package require {ycl proc}
namespace import [yclprefix]::proc::checkargs
namespace import [yclprefix]::proc::dproc
package require {ycl string}
namespace import [yclprefix]::string::isdecimal
namespace import [yclprefix]::string::tolower
package require {ycl struct tree}
namespace import [yclprefix]::struct::tree
package require {ycl tmpfile}
namespace import [yclprefix]::tmpfile::mktemp
namespace eval arg {}
namespace eval doc {}
namespace eval pattern {}
::apply [list {} {
set incdirs {/usr/include}
foreach dir $incdirs {
set magickdir /usr/include/ImageMagick-7
if {[file exists $magickdir/MagickCore/MagickCore.h]} {
::critcl::cheaders -I$magickdir
}
}
set libdirs {/usr/lib}
foreach dir $libdirs {
foreach file [glob -nocomplain -directory $dir *MagickCore-7*] {
set tail [file tail $file]
regexp -nocase {^(?:lib)?(magickcore.*?)\.so} $tail -> tail
::critcl::ldflags -L $dir -l$tail
}
}
} [namespace current]]
critcl ccode {
#include "MagickCore/MagickCore.h"
Tcl_Obj * tclnumber (long long number) {
Tcl_Obj *res;
int intnum;
int longnum;
res = Tcl_NewIntObj(number);
if (intnum == number) {
return res;
}
Tcl_DecrRefCount(res);
res = Tcl_NewLongObj(number);
if (longnum == number) {
return res;
}
Tcl_DecrRefCount(res);
Tcl_NewWideIntObj(number);
}
}
variable arg::cmdargs {
description {
list of arguments to pass to the convert command
}
}
variable arg::inname {
description {
name of input file to process
}
}
variable arg::overwrite {
description {
specifies that the it's OK to overwrite the output file if it
already exits
}
default {
set overwrite no
}
}
variable arg::outname {
description {
name of output file
}
constrain {
$overwrite || ![file exists $outname]
}
}
variable arg::stdout {
description {
a valid stdout spec
}
default {}
}
variable arg::stderr {
description {
a valid stderr spec
}
default {}
}
#keys like exif:contrast: contain two colons, so this didn't work
#regexp -- {([^:]*):[[:space:]]*(.*)} $line unused key val
variable pattern::info_key {^([[:space:]]*)((?:.(?!:(?:[[:space:]]|$)))+[^:]):[[:space:]]*(.*)[[:space:]]*$}
proc args_out {outname errname} {
upvar $outname up_outname
upvar $errname up_errname
set res [list]
if {[info exists up_outname]} {
lappend res >@$up_outname
}
if {[info exists up_errname]} {
lappend res 2>@$up_errname
}
return $res
}
proc dashsplit name {
upvar $name val
split val -
set val [lindex $val 0]
}
proc uncommented {list} {
set newlist [list]
foreach item $list {
if {[string index $item 0] ne "#"} {
lappend newlist $item
}
}
return $newlist
}
proc errexit {args} {
cleanup
exit $status
}
variable doc::outname {
description {
generate an output filename from an input filename
}
args {
incrdelim {
description {
specifies a character to delimit the root filename and the
incrementor
}
default {
set incrdelim _
}
}
}
}
dict set doc::outname args inname $arg::inname
dproc outname args {
checkargs $doc::outname {*}$args
set tail [file tail $inname]
set dirname [file dirname $inname]
set root [file rootname $inname]
set extension [file extension $tail]
if {[file exists [set res [file join $dirname $root]]]} {
}
while [file exists [set res [file join \
$dirname $root$incrdelim[incr i]$extension]]] {}
return $res
}
variable doc::execim {
description {
execute an image magic command
}
args {
cmdargs {
description {
arguments to be passed to the command
}
}
}
}
dproc execim args {
checkargs $doc::execim {*}$args
return [exec {*}$cmdargs]
}
set doc::convert {
description {
execute ImageMagick "convert" command
}
}
variable convert_args [dict create]
dict set convert_args cmdargs $arg::cmdargs
dict set convert_args stdout $arg::stdout
dict set convert_args stderr $arg::stderr
dict set doc::convert args $convert_args
dproc convert args {
checkargs $doc::convert {*}$args
set args_out [args_out stdout stderr]
return [execim cmdargs [list convert {*}$cmdargs {*}$args_out]]
}
variable doc::identify_full {
description {
get full metadata for an image
}
value {
a dictionary representing the parsed image info
}
}
dict set doc::identify_full args inname $arg::inname
dproc identify_full args {
checkargs $doc::identify_full {*}$args
set cmd [list identify -verbose $inname 2>@stderr]
set imageinfo [execim cmdargs $cmd]
set imageinfo [parse_verboseinfo data $imageinfo]
return $imageinfo
}
proc number_percent val {
if {![
regexp {([^[:space:]])[[:space:]]*\(([^(]*)\)} $val -> number percent]
} {
error [list {could not extract number and percent} $val]
}
return [list $number $percent]
}
proc paren_comma_list name {
upvar $name val
regsub {^\s*\((.*)\)\s*$} $val {\1} val
split val ,
return $val
}
proc parse_artifacts {tree node key val} {
{*}$tree node new $node $val
return
}
proc parse_channeldepth {tree node key val} {
{*}$tree node new $node $val
return
}
proc parse_channelstatistics {tree node key val} {
set res {}
switch $key {
red - green - blue - gray {
lappend res parse_channelstatistics_color
}
pixels {
{*}$tree node new $node $val
}
default {
error [list {unknown key} key $key path [{*}$tree node path $node]]
}
}
return $res
}
proc parse_channelstatistics_color {tree node key val} {
switch $key {
min - max - mean - {standard deviation} {
{*}$tree node new $node [number_percent $val]
}
kurtosis - skewness - entropy {
{*}$tree node new $node $val
}
default {
error [list {unknown key} key $key path [{*}$tree node path $node]]
}
}
return
}
proc parse_chromaticity {tree node key val} {
switch $key {
{red primary} - {green primary} - {blue primary} - {white point} {
paren_comma_list val
{*}$tree node new $node $val
}
default {
error [list {unknown key} key $key path [{*}$tree node path $node]]
}
}
return
}
proc parse_color {tree node val} {
set scanned [scan $val { srgba ( %d , %d , %d , %d ) } r g b a]
if {$scanned == 4} {
{*}$tree node tree $node [list r $r g $g b $b a $a]
} else {
set scanned [scan $val { srgb ( %d , %d , %d) } r g b]
if {$scanned == 3} {
{*}$tree node tree $node [list r $r g $g b $b]
} else {
if {[regexp {^[[:space:]]*([^[:space:]])+[[:space:]]*$} $val val]} {
{*}$tree node new $node $val
} else {
error [list {can not parse color} $val]
}
}
}
return
}
proc parse_colormap {tree node key val} {
set scanned [scan $val { ( %d , %d , %d ,%d ) #%x srgba( %d , %d , %d ,%d} \
r g b a v sr sg sb sa]
if {$scanned == 9} {
{*}$tree node tree $node [list r $r g $g b $b v $v sr $sr sg $sg sb $sb sa $sa]
} else {
set scanned [scan $val { ( %d , %d , %d ) #%x srgb( %d , %d , %d } \
r g b v sr sg sb]
if {$scanned == 7} {
{*}$tree node tree $node [list r $r g $g b $b v $v sr $sr sg $sg sb $sb]
} else {
set scanned [scan $val { ( %d , %d , %d , %d ) #%x %s } r g b a v color]
if {$scanned == 6} {
{*}$tree node tree $node [list r $r g $g b $b a $a v $v color $color]
} else {
set scanned [scan $val { ( %d , %d , %d ) #%x %s } r g b v color]
if {$scanned == 5} {
{*}$tree node tree $node [list r $r g $g b $b v $v color $color]
} else {
error [list {unknown histogram record} $val]
}
}
}
}
return
}
proc parse_geometry {tree node key val} {
set res [parse_geometry_helper $val]
lassign $res width height x y
foreach {key val} $res {
{*}$tree node set $node $key $val
}
return
}
proc parse_imagestatistics {tree node key val} {
set res {}
switch $key {
overall {
lappend res parse_imagestatistics_overall
}
default {
error [list {unknown key} key $key path [{*}$tree node path $node]]
}
}
return $res
}
proc parse_imagestatistics_overall {tree node key val} {
set res {}
switch $key {
min - max - mean - {standard deviation} {
{*}$tree node new $node [number_percent $val]
}
kurtosis - skewness - entropy {
{*}$tree node new $node $val
}
default {
error [list {unknown key} key $key path [{*}$tree node path $node]]
}
}
return $res
}
proc parse_profiles {tree node key val} {
switch $key {
{profile-icc} {
{*}$tree node new $node $val
} default {
error [list {unknown key} key $key path [{*}$tree node path $node]]
}
}
return
}
proc parse_properties {tree node key val} {
{*}$tree node new $node $val
return
}
proc parse_top {tree node key val} {
set res {}
switch $key {
artifacts {
lappend res parse_artifacts
}
{background color} {
parse_color $tree $node $val
}
{border color} {
parse_color $tree $node $val
}
chromaticity {
lappend res parse_chromaticity
}
colormap {
lappend res parse_colormap
}
depth {
{*}$tree node new $node [regexp -inline {} $val]
}
geometry - {page geometry} {
parse_geometry $tree $node $key $val
}
histogram {
lappend res parse_colormap
}
{mime type} {
parse_mimetype $tree $node $key $val
}
{channel depth} {
lappend res parse_channeldepth
}
{channel statistics} {
lappend res parse_channelstatistics
}
{image statistics} {
lappend res parse_imagestatistics
}
profiles {
lappend res parse_profiles
}
properties {
lappend res parse_properties
}
resolution {
parse_geometry $tree $node $key $val
}
default {
{*}$tree node new $node $val
}
}
return $res
}
critcl cproc parse_geometry_helper {Tcl_Interp* interp pstring data} object0 {
Tcl_Obj *res;
MagickStatusType flags;
size_t w ,h;
ssize_t x ,y ;
int intnum;
long zlong;
flags = GetGeometry(data.s ,&x ,&y ,&w ,&h);
if (flags = 0) {
return NULL;
}
res = Tcl_NewDictObj();
Tcl_DictObjPut(interp ,res ,Tcl_NewStringObj("width" ,-1), tclnumber(w));
Tcl_DictObjPut(interp ,res ,Tcl_NewStringObj("height" ,-1), tclnumber(h));
Tcl_DictObjPut(interp ,res ,Tcl_NewStringObj("x" ,-1), tclnumber(x));
Tcl_DictObjPut(interp ,res ,Tcl_NewStringObj("y" ,-1), tclnumber(y));
if (flags & MinimumValue) {
Tcl_DictObjPut(interp ,res ,Tcl_NewStringObj("minimum" ,-1), tclnumber(1));
}
if (flags & PercentValue) {
Tcl_DictObjPut(interp ,res ,Tcl_NewStringObj("percent" ,-1), tclnumber(1));
}
if (flags & AspectValue) {
Tcl_DictObjPut(interp ,res ,Tcl_NewStringObj("aspect" ,-1), tclnumber(1));
}
if (flags & GreaterValue) {
Tcl_DictObjPut(interp ,res ,Tcl_NewStringObj("greater" ,-1), tclnumber(1));
}
if (flags & LessValue) {
Tcl_DictObjPut(interp ,res ,Tcl_NewStringObj("less" ,-1), tclnumber(1));
}
if (flags & AreaValue) {
Tcl_DictObjPut(interp ,res ,Tcl_NewStringObj("area" ,-1), tclnumber(1));
}
if (flags & DecimalValue) {
Tcl_DictObjPut(interp ,res ,Tcl_NewStringObj("decimal" ,-1), tclnumber(1));
}
if (flags & AspectRatioValue) {
Tcl_DictObjPut(interp ,res ,Tcl_NewStringObj("ratio" ,-1), tclnumber(1));
}
return res;
}
variable doc::parse_imconfigure {
description {
parse ImageMagick configuration information
}
args {
data {
description {
the output of [convert -list configure]
}
}
}
value {
type dictionary
}
}
dproc parse_imconfigure args {
checkargs $doc::parse_imconfigure {*}$args
set res [dict create]
split data \n
foreach line $data {
if {![regexp {[^[:space:]]} $line]} {
#empty line
continue
}
if {[string match *- $line]} {
continue
}
set key [lindex $line 0]
set val [lrange $line 1 end]
if {$key eq "Name"} {
continue
}
dict set res $key $val
}
return $res
}
proc parse_mimetype {tree node key val} {
split val /
take val major minor
{*}$tree node set $node major $major
{*}$tree node set $node minor $minor
return
}
variable doc::parse_verboseinfo {
description {
returns the name of {struct tree} containing parsed verbose info
}
args {
chan {
description {
the channel from which to read the text to parse
}
}
}
value {
desc
}
}
dproc parse_verboseinfo {tree node chan} {
set data [read $chan]
split data \n
lappend current $node
set innum 0
set indents {}
set parents {}
set parsers [list parse_top]
while {[llength $data]} {
take data line
if {[string is space $line]} {
continue
}
if {[regexp {^[[:space:]]*Image:[[:space:]]} $line]} break
error [list {"Image: " line not found}]
}
while {[llength $data]} {
{*}$tree db transaction {
while {[llength $data]} {
set data [lassign $data[set data {}] line]
if {![regexp {[^[:space:]]} $line]} {
continue ;#empty line
}
if {![regexp -- $pattern::info_key $line unused newindent key val]} {
error [list {unknown data formatting} $line]
}
tolower key
split key :
if {[llength $key] > 1} {
set keys [lrange $key 0 end-1]
} else {
set keys {}
}
set key [lindex $key end]
set num $key
isdecimal num
if {$newindent > [lindex $indents end]} {
if {!$innum} {
lappend parents $node
set node $current
lappend indents $newindent
}
} elseif {[llength $indents]} {
if {$num eq {}} {
if {$newindent < [lindex $indents end]} {
#newindent is a dedent
while {[lindex $indents end] > $newindent} {
pop indents
pop parents node
pop parsers
}
pop indents
lappend indents $newindent
}
}
}
set innum [expr {$num ne {}}]
lassign [{*}$tree node forge {*}$node {*}$keys $key] current existed
set newparsers {}
foreach parser [lindex $parsers end] {
lappend newparsers {*}[{*}$parser $tree $current $key $val]
}
lappend parsers {*}$newparsers
set indent $newindent
}
if {[incr dbi] % 100 == 0} {
break
}
}
}
return $tree
}
variable doc::mean {
description {
compute the mean of $inname
}
}
dict set doc::mean args inname $arg::inname
dproc mean args {
$checkargs doc::mean {*}$args
if {[package vcompare [imversion] 6.4.0.11 ] > 0} {
set mean [convert cmdargs [list $inname -format {%[fx:mean]} info: ]]
} else {
set info [identify_full inname $inname]
set mean [dict get $info image t mean t percent v]
}
return $mean
}
if 0 {
# to do
# complete this command
variable doc::threshold {
description {
get the theshold of an image
}
args {
fname {
description {
the image file name, including, if necessary the path
}
}
mean {
description {
}
}
bias {
description {
}
}
}
}
dproc threshold args {
checkargs $doc::threshold {*}$args
set mean [mean inname $fname]
set thresh [convert cmdargs [list $fname -format {%[f:100*($mean+$bias/100)]} info:]]
}
}
variable doc::check_image {
description {
convert an image doing nothing but regarding warnings and repaging
}
args {
fname {
description {
name of input file
}
}
outname {
description {
name of output file
}
}
}
}
dproc check_image args {
checkargs $doc::check_image {*}$args
#should throw an error if there's a problem reading the image
convert cmdargs [list -quiet -regard-warnings $fname +repage $outname ]
}
variable doc::imversion {
description {
determine the version of ImageMagick
}
args {
}
}
dproc imversion args {
set raw [convert cmdargs [list -list configure]]
set config [parse_imconfigure data $raw]
set version [dict get $config LIB_VERSION_NUMBER]
regsub -all {\,} $version {.} version
return $version
}
proc imageinfo {filename} {
set percentproperties {
base
channels
colorspace
copyright
depth
directory
extension
group
height
magick
max
mean
min
name
opaque
page
scene
scenes
size
standard-deviation
unique
version
width
xresolution
yresolution
}
set format {
filesize {%b}
comment {%c}
directory {%d}
fileextension {%e}
filename {%f}
layergeo {%g}
height {%h}
imagefilename {%i}
unique_colors {%k}
label {%l}
image_file_format {%m}
number_of_images {%n}
output_filename {%o}
current_image_index {%p}
quantum_depth {%q}
class_and_colorspace {%r}
scene_number {%s}
filename_root {%t}
unique_temporary_filename {%u}
current_width {%w}
x_res {%x}
y_res {%y}
image_depth {%z}
transparency {%A}
compression_type {%C}
dispose_method {%D}
size {%G}
page_height {%H}
magick_filename {%M}
page_offset {%O}
page_size {%P}
compression_quality {%Q}
scenes {%S}
time_delay {%T}
page_width {%W}
page_x_offset {%X}
page_y_offset {%Y}
unique_filename {%z}
bounding_box {%@}
signature {%#}
}
set format [regsub -line -all {^[[:space:]]+} $format {}]
foreach property $percentproperties {
set format [concat $format $property "{%\[$property]}"]
}
set format [concat $format image_properties "{%\[*]}"]
set args [list $::inname]
lappend args ( +clone -colorspace RGB )
lappend args -delete 0
lappend args ( +clone -colorspace Rec709Luma )
lappend args -delete 0
lappend args -format $format
set res [exec convert {*}$args info: 2>@stderr]
return $res
}
proc iter {iterations args} {
set res [list]
while {$iterations > 0} {
lappend res {*}[{*}$args]
incr iterations -1
}
return $res
}
proc add_alpha {} {
lappend args +matte -compose copy_opacity
return $args
}
variable doc::posterscan {
description {
clean up and posterize a scanned document
}
args {
outname {
description {
name of output file
}
}
colors {
description {
number of colors in output image
}
default {
set colors 2
}
}
}
}
dict set doc::posterscan args inname $arg::inname
dproc posterscan args {
checkargs $doc::posterscan {*}$args
convert cmdargs [list $inname {*}[posterscan_args {*}$args] $outname]
}
proc posterscan_args args {
checkargs $doc::posterscan {*}$args
set median_count 20
set median_area 3x3
set outsuffix _out.tif
set medians [list]
for {set i 0} {$i<$median_count} {incr i} {
lappend medians -statistic Median $median_area
}
#note:
# +matte -contrast-stretch 0 -deskew 40% -level 89%,90% +dither -colors 8 -compress Group4
# -alpha off -set option:deskew:auto-crop 10 -deskew 10% -contrast-stretch 0 -level 50%,94%
set args [list]
#for some reason, results are different if -contrast-stretch 0 comes after -deskew
#maybe because -deskew does some blurring/smoothing
lappend args -contrast-stretch 0
#lappend args -sharpen 0x3
lappend args -deskew 40%
#lappend args ( -clone 0 -colorspace gray -morphology smooth:5 disk -threshold 77% )
lappend args ( -clone 0 -colorspace gray -fuzz 20% -threshold 200 )
lappend args +swap
#lappend args -modulate 100,50
#auto-level was not good
#lappend args -auto-level
#not good here
#lappend args -enhance
#lappend args -fuzz 20%
#lappend args -fill white
#lappend args -opaque white
#lappend args -fuzz 73%
#lappend args -fill black
#lappend args -opaque black
#needed prior to segmentint
#lappend args {*}$medians
lappend args +dither
#always remove transparency
lappend args +matte
#lappend args {*}$medians
#-morphology Open not good
#lappend args -morphology Open Disk
#lappend args -morphology close square:1
#lappend args -segment 8
#lappend args -colors $colors
#lappend args -posterize 3
lappend args -type bilevel
#lappend args -fuzz 20%
#lappend args -fill white
#lappend args -opaque white
#lappend args -fuzz 30%
#lappend args -fill black
#lappend args -opaque black
lappend args -modulate 100,800
#lappend args +append
lappend args -compose src-over
#lappend args -compose blend
#lappend args -define compose:args=50,50
lappend args -composite
lappend args -fuzz 20%
lappend args -trim
return $args
}
variable doc::posterscan2 {
description {
clean up and posterize a scanned document
}
}
dict set doc::posterscan2 args inname $arg::inname
dict set doc::posterscan2 args outname $arg::outname
dict set doc::posterscan2 args overwrite $arg::overwrite
dproc posterscan2 args {
checkargs $doc::posterscan2 {*}$args
#lappend args -fuzz 20%
#lappend args -fill white
#lappend args -opaque white
#lappend args -fuzz 30%
#lappend args -fill black
#lappend args -opaque black
#lappend args -modulate 100,200
set hres [duotonemap inname $inname outname $outname \
bias 3 mode highlights threshold 59]
}
variable doc::scandoc {
description {
clean up a scanned document
}
}
dict set doc::scandoc args inname $arg::inname
dict set doc::scandoc args outname $arg::outname
dict set doc::scandoc args overwrite $arg::overwrite
dproc scandoc args {
checkargs $doc::scandoc {*}$args
lappend opts -type TrueColor
lappend opts -fuzz 20% -opaque black -fill black
convert cmdargs [list $inname {*}$opts $outname]
}
variable doc::duotonemap {
description {
DESCRIPTION: DUOTONEMAP enhances the shadows and/or highlight regions
in an image. This is done by adjusting the gamma in each region as
defined by a threshold of the image used as a mask. Processing is
nominally automatic, but can be overridden with manual settings. This
is similar to Photoshop's Shadows/Highlights function.
}
}
dict set duotonemap_args inname $arg::inname
dict set duotonemap_args inname validate {[
#input image is readable
set ext [file extension $inname]
set froot [file rootname $inname]
set tmpdir [mktemp d y template $froot.duotonemap.@tmpid@]
dict incr tmpfiles $tmpdir
set tmpA1 [file join $tmpdir 1.mpc]
check_image fname $inname outname $tmpA1
dict incr tmpfiles $tmpA1
set mean [mean inname $inname]
set meanpct [expr {$mean * 100}]
expr yes
]}
variable duotonemap_args [dict merge $duotonemap_args {
bias {
description {
percent shift of the mean value of the input that is is
used as the nominal threshold value between shadows and highlights.
Values are positive or negative floats. The default=0 indicates no
change from the global mean value of all channels of the input
image.
}
validate {
[string is double $bias]
}
default {
set bias 0
}
}
colorspace {
description {
Set colorspace of input image to sRGB before processing. This
provides an initial non-linear processing. Options are: yes or no.
}
constrain {
$colorspace in [list yes no]
}
default {
set colorspace no
}
}
sgamma {
description {
gamma value to use in shadows; float>0; sgamma=1 is no change;
values larger/smaller than 1 produce brighter/darker results;
default is computed automatically from shadow area mean and "lower"
graylevel parameter.
Overrides the automatic value determined from the mean value in the
shadows and the "lower" graylevel parameter. Values are floats>0.
A value of sgamma=1 produces no change. Smaller/larger values
produce darker or brighter results in the shadows. The default is
to use the automatically computed value.
}
validate {
[string is double $sgamma] && $sgamma > 0
}
default {
set sgamma {}
}
}
hgamma {
description {
gamma value to use in highlights; float>0; sgamma=1 is no change;
values larger/smaller than 1 produce brighter/darker results;
default is computed automatically from shadow area mean and "upper"
graylevel parameter.
Overrides the automatic value determined from the mean value in the
highlights and the "upper" graylevel parameter. Values are
floats>0. A value of hgamma=1 produces no change. Smaller/larger
values produce darker or brighter results in the highlights. The
default is to use the automatically
}
validate {
[string is double $hgamma] && $hgamma > 0
}
default {
set hgamma {}
}
}
mode {
description {
Specifies shadows or highlights or both. Choices are shadows (or
s), highlights (or h) or both (or b). The default=both
}
validate {[
set mode [lindex [lsearch -inline $modes $mode*] 0]
expr true
] &&
$mode in $modes
}
default {
set mode $both
}
}
threshold {
description {
Overrides the automatic value from the (mean + bias) value. Values
are floats between 0 and 100. The default is to use automatic value
from the (mean + bias). is the user specified threshold value. When
used, it overrides the automatic value from the (mean + bias)
value. Values are floats between 0 and 100. The default is to use
automatic value from the (mean + bias).
}
validate {
$threshold >= 0 && $threshold <= 100
}
default {
set threshold [expr {100*($mean+$bias/100)}]
}
}
lower {
description {
lower graylevel value used in automatic sgamma computation;
smaller/larger values produce darker/larger results
}
validate {
[string is double $lower] && $lower >= 0 && $lower <= 1
}
default {
set lower 0.5
}
}
upper {
description {
upper graylevel value used in automatic hgamma
computation; smaller/larger values produce
darker/larger results; 0<=float<=1; default=0.7
}
validate {
[string is double $upper] && $upper >= 0 && $upper <= 1
}
default {
set upper 0.7
}
}
ramp {
description {
The transition distance in pixels between the shadows and
highlights. Values are integers>=0.
}
validate {
[string is entier $ramp] && $ramp > 0
}
default {
set ramp 20
}
}
}]
dict set duotonemap_args overwrite $arg::overwrite
dict set duotonemap_args outname $arg::outname
dict set doc::duotonemap args $duotonemap_args
dproc duotonemap args {
variable tmpfiles
variable outsuffix
set res [list]
#log factor to use in secondary auto gamma adjustment
set fact 255
set shadows shadows
set highlights highlights
set both both
set modes [list $shadows $highlights $both]
checkargs $doc::duotonemap {*}$args
diagnostic msg info mean $mean
diagnostic msg info {mean percent} $meanpct
diagnostic msg info threshold $threshold
#set up for blurring transition
set blurring {}
if {$ramp != 0} {
set blurring [list -blur ${ramp}x65000]
}
#create mask to separate image at midpoint
dict incr tmpfiles [set tmpB1 [file join $tmpdir 1.cache]]
dict incr tmpfiles [set tmpA2 [file join $tmpdir 2.mpc]]
dict incr tmpfiles [set tmpB2 [file join $tmpdir 2.cache]]
dict incr tmpfiles [set tmpA3 [file join $tmpdir 3.mpc]]
dict incr tmpfiles [set tmpB3 [file join $tmpdir 3.cache]]
dict incr tmpfiles [set tmpA4 [file join $tmpdir 4.mpc]]
dict incr tmpfiles [set tmpB4 [file join $tmpdir 4.cache]]
dict incr tmpfiles tmpA2
#create mask to separate image at midpoint
convert cmdargs [list $tmpA1 -threshold $threshold% {*}$blurring $tmpA2]
#get gamma values
if {$sgamma eq {} || $hgamma eq {}} {
#get mean of mask
set meanm [mean inname $tmpA2]
diagnostic msg info {mask mean} $meanm
#get mean of shadows
if {$sgamma eq {} && $mode ne $highlights} {
convert cmdargs [list $tmpA1 ( $tmpA2 -negate ) -compose multiply -composite $tmpA3]
set mean [mean inname $tmpA3]
set means [convert cmdargs [list xc: -format %\[fx:$mean/(1-$meanm)\] info:]]
diagnostic msg info {shadow mean} $means
#get gamma of shadows and highlights
set sgamma [convert cmdargs [list xc: -format %\[fx:log($means)/log($lower)\] info:]]
set tests [convert cmdargs [list xc: -format %\[fx:$sgamma<=0?1:0\] info:]]
if {$tests == 1} {
set sgamma [convert cmdargs [list \
xc: -format %\[fx:log($fact*$meanh)/log($fact*$upper)\] info:]]
}
}
#get mean of highlights
if {$hgamma eq {} && $mode ne $shadows} {
convert cmdargs [list $tmpA1 $tmpA2 -compose multiply -composite $tmpA4]
set mean [mean inname $tmpA4]
set meanh [convert cmdargs [list xc: -format %\[fx:$mean/(1-$meanm)\] info:]]
diagnostic msg info {highlight mean} $meanh
set hgamma [convert cmdargs [list xc: -format %\[fx:log($meanh)/log($upper)\] info:]]
set testh [convert cmdargs [list xc: -format %\[fx:$hgamma<=0?1:0\] info:]]
if {$testh == 1} {
set hgamma [convert cmdargs [list \
xc: -format %\[fx:log($fact*$meanh)/log($fact*$upper)\] info:]]
}
}
}
if {$mode eq $both} {
diagnostic msg info sgamma $sgamma
diagnostic msg info hgamma $hgamma
convert cmdargs [list $tmpA1 -auto-level -gamma $sgamma $tmpA3]
convert cmdargs [list $tmpA1 -auto-level -gamma $hgamma $tmpA4]
set images [list $tmpA3 $tmpA4 $tmpA2]
} elseif {$mode eq $shadows} {
diagnostic msg info sgamma $sgamma
convert cmdargs [list $tmpA1 -auto-level -gamma $sgamma $tmpA3]
set images [list $tmpA3 $tmpA1 $tmpA2]
} elseif {$mode eq $highlights} {
diagnostic msg info hgamma $hgamma
convert cmdargs [list $tmpA1 -auto-level -gamma $hgamma $tmpA4]
set images [list $tmpA1 $tmpA4 $tmpA2]
}
convert cmdargs [list {*}$images -compose over -composite $outname] stdout stdout \
stderr stderr
return [dict create tmpfiles $tmpdir]
}
proc blur {} {
set args [list]
lappend args -blur 0x2
return $args
}
proc test_cleanlines {} {
set args [list]
lappend args ( +clone -colorspace gray -blur 0x8
lappend args {*}[add_alpha] )
lappend args -compose subtract
lappend args -composite
return $args
}
variable compose_methods {
#clear
#src
#dst
#src-over
#dst-over
#src-in
#dst-in
#src-out
#dst-out
#src-atop
#dst-atop
#xor
#multiply
#screen
#plus
add
#minus
#subtract
#difference
#exclusion
#darken
#lighten
}
set compose_methods [uncommented $compose_methods]
#namespace ensemble configure [namespace current] -subcommands [list duotonemap]
::critcl::tcl 8.6
::critcl::debug symbols
::critcl::load