(pentcl.tcl + example.tcl)
# pentcl.tcl (0.07b2)
# pentcl is a PostScript generator by Ben Collver
# based on Perl PostScript-Simple v0.07 by Matthew C. Newton
if {[catch {package present TclOO}] != 0} {
error "TclOO missing. Try using Tcl 8.6 or greater"
}
package require TclOO
namespace path oo
namespace eval ::pentcl:: {}
set ::pentcl::pscolours [dict create \
black [list 0 0 0 ] \
brightred [list 1 0 0 ] \
brightgreen [list 0 1 0 ] \
brightblue [list 0 0 1 ] \
red [list 0.8 0 0 ] \
green [list 0 0.8 0 ] \
blue [list 0 0 0.8] \
darkred [list 0.5 0 0 ] \
darkgreen [list 0 0.5 0 ] \
darkblue [list 0 0 0.5] \
grey10 [list 0.1 0.1 0.1] \
grey20 [list 0.2 0.2 0.2] \
grey30 [list 0.3 0.3 0.3] \
grey40 [list 0.4 0.4 0.4] \
grey50 [list 0.5 0.5 0.5] \
grey60 [list 0.6 0.6 0.6] \
grey70 [list 0.7 0.7 0.7] \
grey80 [list 0.8 0.8 0.8] \
grey90 [list 0.9 0.9 0.9] \
white [list 1 1 1 ] \
]
set ::pentcl::fonts [list \
Courier \
Courier-Bold \
Courier-BoldOblique \
Courier-Oblique \
Helvetica \
Helvetica-Bold \
Helvetica-BoldOblique \
Helvetica-Oblique \
Times-Roman \
Times-Bold \
Times-BoldItalic \
Times-Italic \
Symbol \
]
set ::pentcl::psdirs [dict create \
RightUp [list 1 1] \
RightDown [list 1 -1] \
LeftUp [list -1 1] \
LeftDown [list -1 -1] \
]
set ::pentcl::psorigin [dict create \
LeftBottom [list 0 0] \
LeftTop [list 0 -1] \
RightBottom [list -1 0] \
RightTop [list -1 -1] \
]
set ::pentcl::pspaper [dict create \
A0 [list 2384 3370 ] \
A1 [list 1684 2384 ] \
A2 [list 1191 1684 ] \
A3 [list 841.88976 1190.5512 ] \
A4 [list 595.27559 841.88976] \
A5 [list 420.94488 595.27559] \
A6 [list 297 420 ] \
A7 [list 210 297 ] \
A8 [list 148 210 ] \
A9 [list 105 148 ] \
B0 [list 2920 4127 ] \
B1 [list 2064 2920 ] \
B2 [list 1460 2064 ] \
B3 [list 1032 1460 ] \
B4 [list 729 1032 ] \
B5 [list 516 729 ] \
B6 [list 363 516 ] \
B7 [list 258 363 ] \
B8 [list 181 258 ] \
B9 [list 127 181 ] \
B10 [list 91 127 ] \
Executive [list 522 756 ] \
Folio [list 595 935 ] \
Half-Letter [list 612 397 ] \
Letter [list 612 792 ] \
US-Letter [list 612 792 ] \
Legal [list 612 1008 ] \
US-Legal [list 612 1008 ] \
Tabloid [list 792 1224 ] \
SuperB [list 843 1227 ] \
Ledger [list 1224 792 ] \
"Comm #10 Envelope" [list 297 684 ] \
Envelope-Monarch [list 280 542 ] \
Envelope-DL [list 312 624 ] \
Envelope-C5 [list 461 648 ] \
EuroPostcard [list 298 420 ] \
]
set ::pentcl::psunits [dict create \
pt [list 72 72.27 ] \
pc [list 72 6.0225] \
in [list 72 1 ] \
bp [list 1 1 ] \
cm [list 72 2.54 ] \
mm [list 72 25.4 ] \
dd [list 72 67.567 ] \
cc [list 72 810.804 ] \
]
set ::pentcl::version 0.07b2
class create ::pentcl::EpsSimpleClass {
constructor {data} {
variable key undefined
variable val undefined
variable opt_eps [dict create \
file undefined \
xsize undefined \
ysize undefined \
units bp \
clip true \
bbx1 0 \
bby1 0 \
bbx2 0 \
bby2 0 \
epsprefix [list] \
epsfile undefined \
epspostfix [list] \
source undefined \
]
dict for {key val} $data {
dict set opt_eps $key $val
}
if {[dict get $opt_eps file] eq "undefined"} {
if {[dict get $opt_eps source] eq "undefined"} {
error "Must provide source."
}
} else {
error "Must not provide file as it is unimplemented."
}
my init
}
method getfilebbox {} {
error "getfilebbox method not implemented"
}
method getsourcebbx {} {
variable opt_eps
variable result
if {[dict get $opt_eps epsfile] eq "undefined"} {
return false
}
set result [regexp -inline -line \
{^%%BoundingBox:\s+(-?\d+)\s+(-?\d+)\s+(-?\d+)\s+(-?\d+)$} \
[dict get $opt_eps epsfile] \
]
if {[llength $result] == 5} {
dict set opt_eps bbx1 [lindex $result 1]
dict set opt_eps bby1 [lindex $result 2]
dict set opt_eps bbx2 [lindex $result 3]
dict set opt_eps bby2 [lindex $result 4]
return true
}
return false
}
method init {} {
variable foundbbx
variable opt_eps
dict set opt_eps epsfile [dict get $opt_eps source]
dict unset opt_eps source
if {![my getsourcebbx]} {
error "EPS file must contain a BoundingBox"
}
if {([dict get $opt_eps bbx2] - [dict get $opt_eps bbx1] == 0) || \
([dict get $opt_eps bby2] - [dict get $opt_eps bby1] == 0)} \
{
error "Pentcl Eps Bounding Box has zero dimension"
return false
}
return true
}
method get_bbox {} {
variable opt_eps
return [list \
[dict get $opt_eps bbx1] [dict get $opt_eps bby1] \
[dict get $opt_eps bbx2] [dict get $opt_eps bby2] \
]
}
method width {} {
variable opt_eps
return [expr {[dict get $opt_eps bbx2] - [dict get $opt_eps bbx1]}]
}
method height {} {
variable opt_eps
return [expr {[dict get $opt_eps bby2] - [dict get $opt_eps bby1]}]
}
method scale {x {y undefined}} {
variable opt_eps
if {$y eq "undefined"} {
set y $x
}
dict lappend opt_eps epsprefix "$x $y scale"
return true
}
method rotate {d} {
variable opt_eps
dict lappend opt_eps epsprefix "$d rotate"
return true
}
method translate {x y} {
variable opt_eps
dict lappend opt_eps epsprefix "$x $y translate"
return true
}
method reset {} {
variable opt_eps
dict set opt_eps epsprefix [list]
return true
}
method load {} {
error "load method not implemented"
}
method preload {} {
error "preload method not implemented"
}
method get_include_data {x y} {
variable data ""
variable opt_eps
set data [join [dict get $opt_eps epsprefix] "\n"]
append data "\n"
if {[dict get $opt_eps clip]} {
append data "newpath " \
[dict get $opt_eps bbx1] " " [dict get $opt_eps bby1] " moveto\n" \
[dict get $opt_eps bbx2] " " [dict get $opt_eps bby1] " lineto " \
[dict get $opt_eps bbx2] " " [dict get $opt_eps bby2] " lineto\n" \
[dict get $opt_eps bbx1] " " [dict get $opt_eps bby2] \
" lineto closepath clip newpath\n"
}
append data [dict get $opt_eps epsfile] \
[join [dict get $opt_eps epspostfix] "\n"] "\n"
return $data
}
}
class create ::pentcl::PsSimpleClass {
constructor {data} {
variable key undefined
variable opt undefined
set opt [dict create \
xsize undefined \
ysize undefined \
papersize undefined \
units bp \
landscape 0 \
copies 1 \
colour false \
clip false \
eps true \
page 1 \
reencode ISOLatin1Encoding \
bbx1 0 \
bby1 0 \
bbx2 0 \
bby2 0 \
pscomments "" \
psprolog "" \
psfunctions "" \
pssetup "" \
pspages "" \
pstrailer "" \
lastfontsize undefined \
pspagecount 0 \
usedcircle false \
usedcircletext false \
usedbox false \
usedrotabout false \
usedimporteps false \
coordorigin LeftBottom \
direction RightUp \
fonts [list] \
]
dict for {key val} $data {
dict set opt $key $val
}
my init
}
method init {} {
variable d 1
variable dx
variable dy
variable font
variable i
variable m 1
variable mm
variable opt
variable u
# Units
if {[dict exists $::pentcl::psunits [dict get $opt units]]} {
lassign [dict get $::pentcl::psunits [dict get $opt units]] m d
} else {
error "unit [dict get $opt units] undefined"
}
lassign [dict get $::pentcl::psdirs [dict get $opt direction]] dx dy
# x direction
set mm [expr {$m * $dx}]
set u "{"
if {$mm != 1} {
append u "$mm mul "
}
if {$d != 1} {
append u "$d div "
}
set u [string trim $u]
append u "}"
dict append opt psfunctions "/ux $u def\n"
# y direction
set mm [expr {$m * $dy}]
set u "{"
if {$mm != 1} {
append u "$mm mul "
}
if {$d != 1} {
append u "$d div "
}
set u [string trim $u]
append u "}"
dict append opt psfunctions "/uy $u def\n"
# general unit scale
set u "{"
if {$m != 1} {
append u "$m mul "
}
if {$d != 1} {
append u "$d div "
}
set u [string trim $u]
append u "}"
dict append opt psfunctions "/u $u def\n"
if {[dict get $opt xsize] eq "undefined" || \
[dict get $opt ysize] eq "undefined"} \
{
if {[dict get $opt papersize] ne "undefined" && \
[dict exists $::pentcl::pspaper [dict get $opt papersize]]} \
{
dict set opt xsize [lindex \
[dict get $::pentcl::pspaper [dict get $opt papersize]] 0]
dict set opt ysize [lindex \
[dict get $::pentcl::pspaper [dict get $opt papersize]] 1]
dict set opt bbx2 [dict get $opt xsize]
dict set opt bby2 [dict get $opt ysize]
dict append opt pscomments "%%DocumentMedia: " \
[dict get $opt papersize] " " [dict get $opt xsize] " " \
[dict get $opt ysize] " 0 ( ) ( )\n"
} else {
error "page size undefined"
}
} else {
dict set opt bbx2 [expr {int([dict get $opt xsize] * double($m) / $d)}]
dict set opt bby2 [expr {int([dict get $opt ysize] * double($m) / $d)}]
}
if {![dict get $opt eps]} {
dict append opt pssetup "ll 2 ge \{ << /PageSize \[ " \
[dict get $opt xsize] " " [dict get $opt ysize] \
" \] /ImagingBBox null >> setpagedevice \} if\n"
}
if {[dict get $opt landscape]} {
variable swap
dict append opt psfunctions "/landscape { " [dict get $opt bbx2] \
" 0 translate 90 rotate } bind def\n"
# Portrait probably correct as page is rotated
dict append opt pscomments "%%Orientation: Portrait\n"
swap = [dict get $opt bbx2]
dict set opt bbx2 [dict get $opt bby2]
dict set opt bby2 $swap
# for EPS files, change to landscape here, as there are no pages
if {[dict get $opt eps]} {
dict append opt pssetup "landscape\n"
}
} else {
dict append opt pscomments "%%Orientation: Portrait\n"
}
# Clipping
if {[dict get $opt clip]} {
dict append opt psfunctions "/pageclip {newpath " \
[dict get $opt bbx1] " " [dict get $opt bby1] " moveto " \
[dict get $opt bbx1] " " [dict get $opt bby2] " lineto " \
[dict get $opt bbx2] " " [dict get $opt bby2] " lineto " \
[dict get $opt bbx2] " " [dict get $opt bby1] " lineto " \
[dict get $opt bbx1] " " [dict get $opt bby1] " lineto " \
"closepath clip} bind def\n"
if {[dict get $opt eps]} {
dict append opt pssetup "pageclip\n"
}
}
# Font reencoding
variable encoding ""
variable ext "-iso"
if {[dict get $opt reencode] ne "undefined"} {
set encoding [dict get $opt reencode]
dict append opt psfunctions {/STARTDIFFENC { mark } bind def
/ENDDIFFENC {
% /NewEnc BaseEnc STARTDIFFENC number or glyphname ... ENDDIFFENC -
counttomark 2 add -1 roll 256 array copy
/TempEncode exch def
% pointer for sequential encodings
/EncodePointer 0 def
{
% Get the bottom object
counttomark -1 roll
% Is it a mark?
dup type dup /marktype eq {
% End of encoding
pop pop exit
} {
/nametype eq {
% Insert the name at EncodePointer
% and increment the pointer.
TempEncode EncodePointer 3 -1 roll put
/EncodePointer EncodePointer 1 add def
} {
% Set the EncodePointer to the number
/EncodePointer exch def
} ifelse
} ifelse
} loop
TempEncode def
} bind def
% Define ISO Latin1 encoding if it doesnt exist
/ISOLatin1Encoding where {
% (ISOLatin1 exists!) =
pop
} {
(ISOLatin1 does not exist, creating...) =
/ISOLatin1Encoding StandardEncoding STARTDIFFENC
144 /dotlessi /grave /acute /circumflex /tilde
/macron /breve /dotaccent /dieresis /.notdef /ring
/cedilla /.notdef /hungarumlaut /ogonek /caron /space
/exclamdown /cent /sterling /currency /yen /brokenbar
/section /dieresis /copyright /ordfeminine
/guillemotleft /logicalnot /hyphen /registered
/macron /degree /plusminus /twosuperior
/threesuperior /acute /mu /paragraph /periodcentered
/cedilla /onesuperior /ordmasculine /guillemotright
/onequarter /onehalf /threequarters /questiondown
/Agrave /Aacute /Acircumflex /Atilde /Adieresis
/Aring /AE /Ccedilla /Egrave /Eacute /Ecircumflex
/Edieresis /Igrave /Iacute /Icircumflex /Idieresis
/Eth /Ntilde /Ograve /Oacute /Ocircumflex /Otilde
/Odieresis /multiply /Oslash /Ugrave /Uacute
/Ucircumflex /Udieresis /Yacute /Thorn /germandbls
/agrave /aacute /acircumflex /atilde /adieresis
/aring /ae /ccedilla /egrave /eacute /ecircumflex
/edieresis /igrave /iacute /icircumflex /idieresis
/eth /ntilde /ograve /oacute /ocircumflex /otilde
/odieresis /divide /oslash /ugrave /uacute
/ucircumflex /udieresis /yacute /thorn /ydieresis
ENDDIFFENC
} ifelse
% Name: Re-encode Font
% Description: Creates a new font using the named encoding.
/REENCODEFONT { % /Newfont NewEncoding /Oldfont
findfont dup length 4 add dict
begin
{ % forall
1 index /FID ne
2 index /UniqueID ne and
2 index /XUID ne and
{ def } { pop pop } ifelse
} forall
/Encoding exch def
% defs for DPS
/BitmapWidths false def
/ExactSize 0 def
/InBetweenSize 0 def
/TransformedChar 0 def
currentdict
end
definefont pop
} bind def
% Reencode the std fonts:
}
# end of psfunctions PostScript code block
foreach font [dict get $opt fonts] {
dict append opt psfunctions "/$font$ext $encoding /$font REENCODEFONT\n"
}
}
}
# end of init proc
method newpage {{nextpage undefined}} {
variable opt
variable x undefined
variable y undefined
if {$nextpage ne "undefined"} {
dict set opt page $nextpage
}
if {[dict get $opt eps]} {
# Cannot have multiple pages in an EPS file XXXXX
error "Do not use newpage for eps files!"
}
if {[dict get $opt pspagecount] != 0} {
dict append opt pspages "%%PageTrailer\n" \
"pagelevel restore\n" \
"showpage\n"
}
dict incr opt pspagecount
dict append opt pspages "%%Page: " [dict get $opt page] " " \
[dict get $opt pspagecount] "\n"
if {[dict get $opt page] >= 0} {
dict incr opt page
} else {
dict incr opt page -1
}
dict append opt pspages "%%BeginPageSetup\n" \
"/pagelevel save def\n"
if {[dict get $opt landscape]} {
dict append opt pspages "landscape\n"
}
if {[dict get $opt clip]} {
dict append opt pspages "pageclip\n"
}
lassign [dict get $::pentcl::psorigin [dict get $opt coordorigin]] x y
if {$x < 0} {
set x [dict get $opt xsize]
}
if {$y < 0} {
set y [dict get $opt ysize]
}
if {$x != 0 || $y != 0} {
dict append opt pspages "$x $y translate\n"
}
dict append opt pspages "%%EndPageSetup\n"
return true
}
method _builddocument {title} {
variable date [clock format [clock seconds] -format "%+"]
variable opt
variable page [list]
variable user "Console"
# Comments Section
if {[dict get $opt eps]} {
lappend page "%!PS-Adobe-3.0 EPSF-1.2"
} else {
lappend page "%!PS-Adobe-3.0"
}
lappend page "%%Title: ($title)"
lappend page "%%LanguageLevel: 1"
lappend page "%%Creator: Pentcl version $::pentcl::version"
lappend page "%%CreationDate: $date"
lappend page "%%For: $user"
lappend page [string trim [dict get $opt pscomments]]
if {[dict get $opt eps]} {
lappend page [join [list "%%BoundingBox:" \
[dict get $opt bbx1] [dict get $opt bby1] \
[dict get $opt bbx2] [dict get $opt bby2]] \
]
} else {
lappend page "%%Pages: [dict get $opt pspagecount]"
}
lappend page "%%EndComments"
# Prolog Section
lappend page "%%BeginProlog"
lappend page "/ll 1 def systemdict /languagelevel known {"
lappend page "/ll languagelevel def } if"
lappend page [dict get $opt psprolog]
lappend page "%%BeginResource: Pentcl"
lappend page [dict get $opt psfunctions]
lappend page "%%EndResource"
lappend page "%%EndProlog"
# Setup Section
if {[string length [dict get $opt pssetup]] > 0 || \
[dict get $opt copies] > 1} \
{
lappend page "%%BeginSetup"
if {[dict get $opt copies] > 1} {
lappend page "/#copies [dict get $opt copies] def"
}
lappend page [dict get $opt pssetup]
lappend page "%%EndSetup"
}
# Pages
lappend page [dict get $opt pspages]
if {(![dict get $opt eps]) && ([dict get $opt pspagecount] > 0)} {
lappend page "%%PageTrailer"
lappend page "pagelevel restore"
lappend page "showpage"
}
# Trailer Section
if {[string length [dict get $opt pstrailer]] > 0} {
lappend page "%%Trailer"
lappend page [dict get $opt pstrailer]
}
lappend page "%%EOF"
return $page
}
method output {} {
error "output method not implemented"
}
method get {} {
variable i undefined
variable opt
variable page [my _builddocument "Pentcl generated page"]
variable retval [join $page "\n"]
append retval "\n"
return $retval
}
method geteps {} {
variable opt
if {![dict get $opt eps]} {
error "document is not EPS"
}
return [::pentcl::EpsSimpleClass new [dict create source [my get]]]
}
method setcolour args {
variable b undefined
variable g undefined
variable opt
variable r undefined
if {[llength $args] == 1} {
set args [lassign $args r]
if {[dict exists $::pentcl::pscolours $r]} {
lassign [dict get $::pentcl::pscolours $r] r g b
} else {
error "bad colour name '$r'"
return false
}
} elseif {[llength $args] == 3} {
lassign $args r g b
set r [expr {double($r) / 255}]
set g [expr {double($g) / 255}]
set b [expr {double($b) / 255}]
} else {
error "setcolour given invalid arguments: $args"
return false
}
if {[dict get $opt colour]} {
dict append opt pspages "$r $g $b setrgbcolor\n"
} else {
# PKENT - colour->grey conversion
set r [expr {0.3 * $r + 0.59 * $g + 0.11 * $b}]
dict append opt pspages "$r setgray\n"
}
return true
}
method setlinewidth {width} {
variable opt
# MCN should allow for option units=>"cm" on each
# setlinewidth / line / polygon etc
# PKENT - good idea, should we have names for line weights, like we
# do for colours?
if {$width eq "thin"} {
set width "0.4"
} else {
append width " u"
}
dict append opt pspages "$width setlinewidth\n"
return true
}
method line {x1 y1 x2 y2 args} {
variable opt
# dashed lines? XXXXX
# MCN should allow for option units=>"cm" on each
# setlinewidth / line / polygon etc
if {[dict get $opt pspagecount] == 0 && ![dict get $opt eps]} {
# Cannot draw on to non-page when not an eps file XXXXX
return false
}
if {[llength $args] == 3} {
lassign $args r g b
my setcolour $r $g $b
} elseif {[llength $args] != 0} {
error "wrong number of args for line"
return false
}
my newpath
my moveto $x1 $y1
dict append opt pspages "$x2 ux $y2 uy lineto stroke\n"
return true
}
method linextend {x y} {
variable opt
dict set opt pspages [regsub {eto stroke\n$} \
[dict get $opt pspages] "eto\n$x ux $y uy lineto stroke\n"]
# PKENT comments: lineto can follow a curveto or a lineto,
# hence the change in regexp
# also I thought that it'd be better to change the '.*$' in the
# regsub with '\n$' - perhaps
# we need something like _lastcommand to know if operations are valid?
# dict append opt pspages "$x ux $y uy lineto stroke\n"
# XXXXX fixme
return true
}
method arc args {
variable ea undefined
variable opt
variable opt_arc [dict create]
variable opt_discard undefined
variable r undefined
variable sa undefined
variable x undefined
variable y undefined
if {[dict get $opt pspagecount] == 0 && ![dict get $opt eps]} {
# Cannot draw on to non-page when not an eps file XXXXX
return false
}
if {[lindex $args 0] eq "-opt"} {
set args [lassign $args opt_discard opt_arc]
}
if {[llength $args] == 5} {
lassign $args x y r sa ea
} else {
error "arc: wrong number of arguments"
return false
}
my newpath
dict append opt pspages "$x ux $y uy $r u $sa $ea arc "
if {[dict get $opt_arc filled]} {
dict append opt pspages "fill\n"
} else {
dict append opt pspages "stroke\n"
}
return true
}
method polygon args {
variable opt
variable opt_discard undefined
variable opt_polygon [dict create]
variable rotate 0
variable rotatex 0
variable rotatey 0
variable savestate undefined
variable x undefined
variable y undefined
variable xoffset 0
variable yoffset 0
# PKENT comments - the first arg could be an optional hashref of
# options. See if it's there with ref($_[0]) If it is, then shift
# it off and use those options. Could take the form:
# polygon( { offset => [ 10, 10 ], filled => 0, rotate => 45,
# rotate => [45, 10, 10] }, $x1, ... it seems neater to use native
# structures instead of manipulating strings
# ... done MCN 2002-10-22
if {[lindex $args 0] == "-opt"} {
set args [lassign $args opt_discard opt_polygon]
}
if {[llength $args] < 6} {
error "bad polygon - not enough points"
return false
}
set args [lassign $args x y]
if {[dict exists $opt_polygon rotate]} {
if {[llength [dict get $opt_polygon rotate]] > 1} {
lassign [dict get $opt_polygon rotate] rotate rotatex rotatey
} else {
set rotate [dict get $opt_polygon rotate]
set rotatex x
set rotatey y
}
}
if {[dict exists $opt_polygon offset]} {
if {[llength [dict get $opt_polygon offset]] > 0} {
lassign [dict get $opt_polygon offset] xoffset yoffset
} else {
error "polygon: bad offset option"
return false
}
}
if {![dict exists $opt_polygon filled]} {
dict set opt_polygon filled false
}
if {$x eq "undefined" || $y eq "undefined"} {
error "polygon: no start point"
return false
}
if {$xoffset || $yoffset || $rotate} {
set savestate true
dict append opt pspages "gsave "
} else {
set savestate false
}
if {$xoffset || $yoffset} {
dict append opt pspages "$xoffset ux $yoffset uy translate\n"
#dict append opt pspages "$xoffset u $yoffset u translate\n"
}
if {rotate} {
if {![dict get $opt usedrotabout]} {
dict append opt psfunctions "/rotabout {" \
"3 copy pop translate rotate exch 0 exch " \
"sub exch 0 exch sub translate" \
"} def\n"
dict set opt usedrotabout true
}
dict append opt pspages "$rotatex ux $rotatey uy rotate rotabout\n"
# dict append opt pspages "gsave $rotatex ux $rotatey uy translate "
# dict append opt pspages \
# "$rotate rotate -$rotatex ux -$rotatey uy translate\n"
}
my newpath
my moveto $x $y
while {[llength $args] > 0} {
set args [lassign $args x y]
dict append opt pspages "$x ux $y uy lineto "
}
if {[dict get $opt_polygon filled]} {
dict append opt pspages "fill\n"
} else {
dict append opt pspages "stroke\n"
}
if {savestate} {
dict append opt pspages "grestore\n"
}
return true
}
method circle args {
variable opt
variable opt_circle [dict create]
variable opt_discard undefined
variable x
variable y
variable r
if {[lindex $args 0] == "-opt"} {
set args [lassign $args opt_discard opt_circle]
}
if {[llength $args] != 3} {
error "circle: wrong number of arguments"
return false
}
lassign $args x y r
if {![dict get $opt usedcircle]} {
dict append opt psfunctions "/circle {" \
"newpath 0 360 arc closepath" \
"} bind def\n"
dict set opt usedcircle true
}
dict append opt pspages "$x ux $y uy $r u circle "
if {[dict get $opt filled]} {
dict append opt pspages "fill\n"
} else {
dict append opt pspages "stroke\n"
}
return true
}
method circletext args {
variable a undefined
variable opt
variable opt_circletext [dict create]
variable opt_discard undefined
variable r undefined
variable text undefined
variable x undefined
variable y undefined
if {[lindex $args 0] == "-opt"} {
set args [lassign $args opt_discard opt_circletext]
}
if {[llength $args] != 5} {
error "circletext: wrong number of arguments"
return false
}
lassign $args x y r a text
if {[dict get $opt lastfontsize] eq "undefined"} {
error "circletext: must set font first"
return false
}
if {![dict get $opt usedcircletext]} {
dict append opt psfunctions {/outsidecircletext {
$circtextdict begin
/radius exch def
/centerangle exch def
/ptsize exch def
/str exch def
/xradius radius ptsize 4 div add def
gsave
centerangle str findhalfangle add rotate
str {
/charcode exch def ( ) dup 0 charcode put outsideshowcharandrotate
} forall
grestore
end
} def
/insidecircletext {
$circtextdict begin
/radius exch def
/centerangle exch def
/ptsize exch def
/str exch def
/xradius radius ptsize 3 div sub def
gsave
centerangle str findhalfangle sub rotate
str {
/charcode exch def ( ) dup 0 charcode put insideshowcharandrotate
} forall
grestore
end
} def
/$circtextdict 16 dict def
$circtextdict begin
/findhalfangle {
stringwidth pop 2 div 2 xradius mul pi mul div 360 mul
} def
/outsideshowcharandrotate {
/char exch def
/halfangle char findhalfangle def
gsave
halfangle neg rotate radius 0 translate -90 rotate
char stringwidth pop 2 div neg 0 moveto char show
grestore
halfangle 2 mul neg rotate
} def
/insideshowcharandrotate {
/char exch def
/halfangle char findhalfangle def
gsave
halfangle rotate radius 0 translate 90 rotate
char stringwidth pop 2 div neg 0 moveto char show
grestore
halfangle 2 mul rotate
} def
/pi 3.1415926 def
end
}
# end of psfunctions PostScript code block
dict set opt usedcircletext true
}
dict append opt pspages "gsave" \
" $x ux $y uy translate" \
" ($text) [dict get $opt lastfontsize] $a $r $u "
if {[dict exists $opt_circletext align] && \
[dict get $opt_circletext align] eq "outside"} \
{
dict append opt pspages "outsidecircletext\n"
} else {
dict append opt pspages "insidecircletext\n"
}
dict append opt pspages "grestore\n"
return true
}
method box args {
variable opt
variable opt_box [dict create]
variable opt_discard undefined
variable x1 undefined
variable x2 undefined
variable y1 undefined
variable y2 undefined
if {[lindex $args 0] == "-opt"} {
set args [lassign $args opt_discard opt_box]
}
if {[llength $args] != 4} {
error "box: wrong number of arguments"
return false
}
lassign $args x1 y1 x2 y2
if {![dict exists $opt_box filled]} {
dict set opt_box filled false
}
if {![dict get $opt usedbox]} {
dict append opt psfunctions {/box {
newpath 3 copy pop exch 4 copy pop pop
8 copy pop pop pop pop exch pop exch
3 copy pop pop exch moveto lineto
lineto lineto pop pop pop pop closepath
} bind def
}
# end of psfunctions PostScript code block
dict set opt usedbox true
}
dict append opt pspages "$x1 ux $y1 uy $x2 ux $y2 uy box "
if {[dict get $opt_box filled]} {
dict append opt pspages "fill\n"
} else {
dict append opt pspages "stroke\n"
}
return true
}
method setfont {name size} {
variable opt
dict append opt pspages "/$name findfont $size scalefont setfont\n"
dict set opt lastfontsize size
return true
}
method text args {
variable align undefined
variable match_whole undefined
variable match_sub undefined
variable opt
variable opt_discard undefined
variable opt_text [dict create]
variable rot ""
variable rot_m ""
variable text undefined
if {[lindex $args 0] == "-opt"} {
set args [lassign $args opt_discard opt_text]
}
if {[llength $args] != 3} {
error "text: wrong number of arguments"
return false
}
lassign $args x y text
# Escape text to allow parentheses
set text [regsub -all {([\\\(\)])} $text {\\\1}]
while {[regexp {([\x00-\x1f\x7f-\xff])} $text match_whole match_sub]} {
variable oct [format "\\%03o" [scan %c $match_sub]]
set text [regsub {[\x00-\x1f\x7f-\xff]} $text $oct]
}
my newpath
my moveto $x $y
# rotation
if {[dict exists $opt_text rotate]} {
set rot_a [dict get $opt_text rotate]
if {$rot_a != 0} {
set rot "$rot_a rotate "
set rot_a [expr {0 - $rot_a}]
set rot_m "$rot_a rotate "
}
}
# alignment, default left
set align " show stroke"
if {[dict exists $opt_text align]} {
if {[dict get $opt_text align] eq "right"} {
set align " dup stringwidth pop neg 0 rmoveto show"
}
if {[dict get $opt_text align] eq "center" || \
[dict get $opt_text align] eq "centre"} \
{
set align " dup stringwidth pop 2 div neg 0 rmoveto show"
}
}
dict append opt pspages "($text) $rot $align $rot_m\n"
return true
}
method curve {x1 y1 x2 y2 x3 y3 x4 y4} {
variable opt
# dashed lines? XXXXX
if {[dict get $opt pspagecount] == 0 && ![dict get $opt eps]} {
# Cannot draw on to non-page when not an eps file XXXXX
return false
}
my newpath
my moveto $x1 $y1
dict append opt pspages \
"$x2 ux $y2 uy " \
"$x3 ux $y3 uy " \
"$x4 ux $y4 uy curveto stroke\n"
return true
}
method curvextend {x1 y1 x2 y2 x3 y3} {
variable opt
# curveto may follow a lineto etc...
dict set opt pspages [regsub {eto stroke\n$} [dict get $opt pspages] \
"eto\n" \
"$x1 ux $y1 uy " \
"$x2 ux $y2 uy " \
"$x3 ux $y3 uy curveto stroke\n"
return true
}
# internal method, avoid it
method newpath {} {
variable opt
dict append opt pspages "newpath\n"
return true
}
# internal method, avoid it
method moveto {x y} {
variable opt
dict append opt pspages "$x ux $y uy moveto\n"
return true
}
method importepsfile {} {
error "importepsfile method not implemented, try importepsdata"
}
method importepsdata {args} {
variable bbllx undefined
variable bblly undefined
variable bburx undefined
variable bbury undefined
variable bbw undefined
variable bbh undefined
variable eps undefined
variable line undefined
variable opt
variable opt_discard undefined
variable opt_epsdata [dict create]
variable pagew undefined
variable pageh undefined
variable result undefined
variable scalex undefined
variable scaley undefined
if {[lindex $args 0] == "-opt"} {
set args [lassign $args opt_discard opt_epsdata]
}
if {[llength $args] != 5} {
error "importepsdata: wrong number of arguments"
return false
}
lassign $args source x1 y1 x2 y2
if {![dict exists $opt_epsdata overlap]} {
dict set opt_epsdata overlap false
}
if {![dict exists $opt_epsdata stretch]} {
dict set opt_epsdata stretch false
}
set eps [::pentcl::EpsSimpleClass new [dict create source $source]]
set result [$eps get_bbox]
lassign $result bbllx bblly bburx bbury
set pagew [expr {$x2 - $x1}]
set pageh [expr {$y2 - $y1}]
set bbw [expr {$bburx - $bbllx}]
set bbh [expr {$bbury - $bblly}]
if {$bbw == 0 || $bbh == 0} {
error "importepsdata: Bounding Box has zero dimension"
return false
}
set scalex [expr {double($pagew) / $bbw}]
set scaley [expr {double($pageh) / $bbh}]
if {![dict get $opt_epsdata stretch]} {
if {![dict get $opt_epsdata overlap]} {
if {$scalex > $scaley} {
set scalex $scaley
} else {
set scaley $scalex
}
} else {
if {$scalex > $scaley} {
set scaley $scalex
} else {
set scalex $scaley
}
}
}
$eps scale $scalex $scaley
$eps translate [expr {0 - $bbllx}] [expr {0 - $bblly}]
my add_eps $eps $x1 $y1
return true
}
method importeps {epsobj xpos ypos} {
my add_eps $epsobj $xpos $ypos
return true
}
method add_eps {epsobj xpos ypos} {
variable opt
if {[info object class $epsobj] ne "::pentcl::EpsSimpleClass"} {
error "internal error: add_eps[0] must be eps object"
}
if {[dict get $opt pspagecount] == 0 && ![dict get $opt eps]} {
# Cannot draw on to non-page when not an eps file
error "importeps: no current page"
return false
}
if {![dict get $opt usedimporteps]} {
dict append opt psfunctions {/BeginEPSF {
/b4_Inc_state save def /dict_count countdictstack def
/op_count count 1 sub def userdict begin /showpage { } def
0 setgray 0 setlinecap 1 setlinewidth 0 setlinejoin
10 setmiterlimit [ ] 0 setdash newpath /languagelevel where {
pop languagelevel 1 ne {
false setstrokeadjust false setoverprint
} if
} if
} bind def
/EndEPSF {
count op_count sub {pop} repeat countdictstack dict_count
sub {end} repeat b4_Inc_state restore
} bind def
}
# end of psfunctions PostScript code block
dict set opt usedimporteps true
}
dict append opt pspages "BeginEPSF\n" \
"$xpos ux $ypos uy translate\n" \
"1 ux 1 uy scale\n" \
[$epsobj get_include_data $xpos $ypos] \
"EndEPSF\n"
return true
}
}
package provide pentcl $::pentcl::version
# example.tcl (0.07b2)
# } Examples for pentcl.tcl
# based on example by Matthew Newton, 09 November 2003
set auto_path [linsert $auto_path 0 [pwd]]
package require pentcl
proc mynewpage {ps title} {
$ps newpage
$ps box 10 10 200 287
$ps line 10 277 200 277
$ps setfont Times-Roman 14
$ps text 15 280 "Pentcl example file: $title"
}
variable ps undefined
variable eps undefined
variable demosquare undefined
variable directeps undefined
variable y undefined
# First, create an EPS file for use later
set ps [::pentcl::PsSimpleClass new [dict create \
xsize 100 \
ysize 100 \
colour true \
eps true \
reencode undefined] \
]
$ps setlinewidth 5
$ps box 10 10 90 90
$ps setlinewidth thin
$ps line 0 50 100 50
$ps line 50 0 50 100
$ps line 0 40 0 60
$ps line 100 40 100 60
$ps line 40 0 60 0
$ps line 40 100 60 100
set demosquare [$ps get]
# Let's also create an EPS object directly from it
# set directeps [::pentcl::EpsSimpleClass new [dict create source [$ps get]]]
set directeps [$ps geteps]
unset ps
# Now generate the demo document. Start by creating the A4 document.
set ps [::pentcl::PsSimpleClass new [dict create \
papersize A4 \
units mm \
colour true \
eps false \
reencode undefined] \
]
# Create page (EPS import from a file, demo-square.eps)
mynewpage $ps "EPS import functions"
$ps setfont Courier 10
set opt [dict create rotate -90]
$ps setcolour red
$ps box 20 210 45 260
$ps importepsdata $demosquare 20 210 45 260
$ps setcolour darkred
$ps text -opt $opt 14 270 {$ps importepsdata $demosquare 20 210 45 260}
$ps setcolour green
$ps box 80 210 105 260
$ps importepsdata -opt [dict create stretch true] $demosquare 80 210 105 260
$ps setcolour darkgreen
$ps text -opt $opt 74 270 \
{$ps importepsdata -opt [dict create stretch true] $demosquare 80 210 105 260}
$ps setcolour blue
$ps box 140 210 165 260
$ps importepsdata -opt [dict create overlap true] $demosquare 140 210 165 260
$ps setcolour darkblue
$ps text -opt $opt 134 270 \
{$ps importepsfile -opt [dict create overlap true] $demosquare 140 210 165 260}
$ps setcolour 200 0 200
$ps box 30 30 90 90
set eps [::pentcl::EpsSimpleClass new \
[dict create source $demosquare clip true] \
]
$eps scale [expr {double(60) / 100}]
$eps translate 50 50
$eps rotate 20
$eps translate -50 -50
$ps importeps $eps 30 30
$ps setfont Courier 10
set y 90
$ps text 100 [incr y -5] {set eps [::pentcl::EpsSimpleClass new \ }
$ps text 110 [incr y -5] { [dict create source $demosquare]]}
$ps text 100 [incr y -5] {$eps scale [expr {60.0 / 100}]}
$ps text 100 [incr y -5] {$eps translate 50 50}
$ps text 100 [incr y -5] {$eps rotate 20}
$ps text 100 [incr y -5] {$eps translate -50 -50}
$ps text 100 [incr y -5] {$ps importeps $eps 30 30}
# Create page (using generated EPS object)
mynewpage $ps "EPS import functions (using internal EPS object)"
$ps setfont Courier 10
set opt [dict create rotate -60]
$ps setcolour red
$ps box 20 210 45 260
#$ps importepsdata $demosquare 20 210 45 260
$directeps reset
$directeps scale [expr {25.0 / [$directeps width]}]
$ps importeps $directeps 20 210
$ps setcolour darkred
$ps text -opt $opt 30 205 {$directeps reset}
$ps text -opt $opt 25 205 {$directeps scale [expr {25.0 / [$directeps width]}]}
$ps text -opt $opt 20 205 {$ps importeps $directeps 20 210}
$ps setcolour green
$ps box 80 210 105 260
#$ps importepsdata -opt [dict create stretch true] $demosquare 80 210 105 260
$directeps reset
$directeps scale \
[expr {25.0 / [$directeps width ]}] \
[expr {50.0 / [$directeps height]}]
$ps importeps $directeps 80 210
$ps setcolour darkgreen
$ps text -opt $opt 90 205 {$directeps reset}
$ps text -opt $opt 85 205 {$directeps scale \
[expr {25.0 / [$directeps width ]}] \
[expr {50.0 / [$directeps height]}]}
$ps text -opt $opt 80 205 {$ps importeps $directeps 80 210}
$ps setcolour blue
$ps box 140 210 165 260
$directeps reset
$directeps scale [expr {50.0 / [$directeps height]}]
$ps importeps $directeps 140 210
$ps setcolour darkblue
$ps text -opt $opt 150 205 {$directeps reset}
$ps text -opt $opt 145 205 \
{$directeps scale [expr {50.0 / [$directeps height]}]}
$ps text -opt $opt 140 205 {$ps importeps $directeps 140 210}
$ps setcolour 200 0 200
$ps box 30 30 90 90
$directeps reset
$directeps translate 50 50
$directeps rotate 20
$directeps translate -50 -50
set eps [::pentcl::PsSimpleClass new \
[dict create eps true xsize 100 ysize 100]]
$eps importeps $directeps 0 0
set directeps [$eps geteps]
$directeps scale [expr {60.0 / 100}]
$ps importeps $directeps 30 30
$ps setfont Courier 10
set y 80
$ps text 100 [incr y -5] {$directeps reset}
$ps text 100 [incr y -5] {$directeps translate 50 50}
$ps text 100 [incr y -5] {$directeps rotate 20}
$ps text 100 [incr y -5] {$directeps translate -50 -50}
$ps text 100 [incr y -5] {# round-about way to set clipping path}
$ps text 100 [incr y -5] {set eps [::pentcl::PsSimpleClass new \ }
$ps text 110 [incr y -5] { [dict create eps true xsize 100 ysize 100]]}
$ps text 100 [incr y -5] {$eps importeps $directeps 0 0}
$ps text 100 [incr y -5] {set directeps [$eps geteps]}
$ps text 100 [incr y -5] {$directeps scale [expr {60.0 / 100}]}
$ps text 100 [incr y -5] {$ps importeps $directeps 30 30}
# Write out the document.
set fh [open "demo.ps" w]
puts -nonewline $fh [$ps get]
close $fh