(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 ====== ---- !!!!!! %| [Category Language] | [Category Printing] |% !!!!!!