* This TCL routine generates a TK photo Zone Plate test image.
#/*******************************************************************************
# * create a ZonePlate test pattern Image
# *
# * This a TK port of Ken Turkowski's ZonePlate.c
# *
# * The orginal 1995 vintage C code can be found at:
# * http://www.worldserver.com/turk/opensource/ZonePlate.c
# *
# * TK port by Greg Blair, Toronto, Ontario, Canada.
# *
# * The dependency on TK can be removed if one only wanted
# * to write out a .pgm file for example.
# *
# *******************************************************************************/
#
# Copyright legislation requires code derived from Ken Turkowski's
# code to include Ken's copyright notice:
#
#/* Copyright (C) 1978-1995 Ken Turkowski. <turk_at_computer.org>
# *
# *
# * All rights reserved.
# *
# * Warranty Information
# * Even though I have reviewed this software, I make no warranty
# * or representation, either express or implied, with respect to this
# * software, its quality, accuracy, merchantability, or fitness for a
# * particular purpose. As a result, this software is provided "as is,"
# * and you, its user, are assuming the entire risk as to its quality
# * and accuracy.
# *
# * This code may be used and freely distributed as long as it includes
# * this copyright notice and the above warranty information.
# */
proc ZonePlate {width height scale} {
# Richard Suchenwirth's tkPhotolab.tcl (https://wiki.tcl-lang.org/9521)
# shows us:
# o - method for building up an image row
# o - method for inserting row into a photo object
# o - proc alias
# o - rgb (which uses alias)
proc alias {name args} {eval [linsert $args 0 interp alias {} $name {}]} ;# local subroutine
alias rgb format #%02x%02x%02x ;# 8 bit color depth
set M_PI 3.14159265358979323846 ;# pi from gcc math.h
set maxValue 255 ;# 8 bit color depth
set midValue [expr {$maxValue / 2.0}]
for {set i 0} {$i <= $maxValue} {incr i} {
set sineTab($i) [expr {$midValue*sin($M_PI*($i-$midValue)/$midValue)+$midValue}]
}
set zpImage [image create photo -width $width -height $height]
set cX [expr { $width / 2} ]
set cY [expr { $height / 2} ]
set u 0 ; set row {}
set v 0
for {set i $height; set y [expr {-$cY}]} {$i} {incr i -1; incr y} {
for {set j $width ; set x [expr {-$cX}]} {$j} {incr j -1; incr x} {
set d [expr {(int(($x*$x+$y*$y) * $scale)>>8)&0xFF}] ;# 8 bit color depth
set d [expr {int($sineTab($d))}]
lappend row [rgb $d $d $d]
incr u
if {$u == $width} {
$zpImage put [list $row] -to 0 $v
set u 0 ; set row {}
incr v
}
}}
return $zpImage
} ;# end proc ZonePlate
########
# TEST #
########
set haveImg [expr {! [catch {package require Img}] } ]
set width 512
set height 512
for {set scale 10} {$scale <= 50} {incr scale 10} \
{
set details [format %04d $width]x[format %04d $height]-[format %02d $scale]
set zpImage [ZonePlate $width $height $scale]
$zpImage write zp-$details.ppm -format PPM ;# PPM image support included with TK
if {$haveImg} {
$zpImage write zp-$details.gif -format GIF ;# requires Img extension
$zpImage write zp-$details.bmp -format BMP ;# requires Img extension
$zpImage write zp-$details.tif -format TIFF ;# requires Img extension
$zpImage write zp-$details.sgi -format SGI ;# requires Img extension
$zpImage write zp-$details.jpg -format JPEG ;# requires Img extension
}
destroy $zpImage ;# all done with image
}
exit