lib/tcl/matgen.tcl

   1 #----------------------------------------------------------------------
   2 # matgen.tcl v0.7 --- An xcircuit Tcl extension for importing matlab
   3 #                     postscript files
   4 # Copyright (c) 2008  Wim Vereecken
   5 #                     Wim.Vereecken@gmail.com
   6 #                     Wim.Vereecken@esat.kuleuven.be
   7 #
   8 # This program is free software; you can redistribute it and/or modify
   9 # it under the terms of the GNU General Public License as published by
  10 # the Free Software Foundation; either version 2 of the License, or
  11 # (at your option) any later version.
  12 #
  13 # This program is distributed in the hope that it will be useful,
  14 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 # GNU General Public License for more details.
  17 #----------------------------------------------------------------------
  18
  19 # "lset" forward compatibility routine from wiki.tcl.tk---"lset" is
  20 # used in these routines, and was new with Tcl version 8.4.
  21
  22 if {[package vcompare [package provide Tcl] 8.4] < 0} {
  23    proc tcl::K {a b} {return $a}
  24    proc lset {listName index val} {
  25       upvar $listName list
  26       set list [lreplace [tcl::K $list [set list {}]] $index $index $val]
  27    }
  28 }
  29
  30 #----------------------------------------------------------------------
  31
  32 proc xcircuit::promptimportmatlab {} {
  33    .filelist.bbar.okay configure -command \
  34       {matgen [.filelist.textent.txt get]; wm withdraw .filelist}
  35    .filelist.listwin.win configure -data "ps"
  36    .filelist.textent.title.field configure -text "Select file to import:"
  37    .filelist.textent.txt delete 0 end
  38    xcircuit::popupfilelist
  39 }
  40
  41 #----------------------------------------------------------------------
  42
  43 proc matgen {argv} {
  44 global XCOps XCWinOps
  45 # PART 1: Command line parser_______________________________
  46 # load-axes property is set
  47 set axes 1
  48 # set default scale factor
  49 set scalefactor 0.2
  50 # set default line width
  51 set linewidth 1.00
  52 # set default line width
  53 set bold 0
  54 # set default file name
  55 set filenames {}
  56 # set default text size
  57 set matlab_textsize 100
  58 # parse all command line args
  59 puts "Checking options..."
  60 foreach arg $argv {
  61         # if -noaxes key is found, disable axes
  62         if [string compare $arg "-noaxes"]==0 then {
  63                 set axes 0
  64                 puts "  *** Axes are disabled"
  65         }
  66         if [regexp {\-scale=(\d+\.*\d*)} $arg matchresult sub1] then {
  67                 set scalefactor [expr $sub1*0.20]
  68                 puts "  *** Scalefactor set to $scalefactor"
  69         }
  70         if [regexp {\-lw=(\d+\.*\d*)} $arg matchresult sub1] then {
  71                 set linewidth $sub1
  72                 puts "  *** Linewidth set to $linewidth"
  73         }
  74         if [regexp {\-bold} $arg matchresult] then {
  75                 set bold 1
  76                 puts "  *** Bold fonts are enabled"
  77         }
  78         if [regexp {(.*\.e?ps)} $arg matchresult sub1] then {
  79                 lappend filenames $sub1
  80                 set file [lindex $filenames [expr [llength $filenames]-1]]
  81         }
  82 }
  83
  84 if {[llength $argv] < 1} then {
  85         puts "  *** no arguments found...\n"
  86         puts "matgen.tcl 0.7"
  87         puts "Written by Wim Vereecken\n"
  88         puts "Usage:"
  89         puts "   matgen \"\[options\] file.eps \[file2.eps\] ...\"\n"
  90         puts "Options:"
  91         puts "   -noaxes: strip axes data"
  92         puts "   -scale=x: rescale by factor x"
  93         puts "   -lw=x: scale linewidth by factor x"
  94         puts "   -bold: use bold text labels\n"
  95         puts "Example:"
  96         puts "   matgen \"-scale=0.7 -lw=3 file.eps\"\n"
  97         return 0
  98 }
  99
 100 # PART 2: Parse and process the source matlab eps file_______
 101 # The extension of the source files that will be examined
 102 puts "Checking for valid matlab postscript (eps) files..."
 103 ## Search in the current directory for files with an .eps
 104 ## extension. If the file is recognized as a matlab .eps
 105 ## file, add the source file to @foundsources.
 106
 107 set validfiles {};
 108 foreach file $filenames {
 109         if [regexp {e?ps} $file matchresult] then {
 110                 # try to open $file
 111                 if [catch {open $file r} result] {
 112                         puts "Warning: $result"
 113                         return -1
 114                 } else {
 115                         set fp $result
 116                         set data [read $fp]
 117                         close $fp
 118                 }
 119                 # split data in seperate lines
 120                 set data [split $data "\n"]
 121                 # read every line and search for "Creator: MATLAB"
 122                 foreach line $data {
 123                         # check if the source is a matlab eps
 124                         if [regexp {Creator: MATLAB} $line matchresult] then {
 125                                 lappend validfiles $file
 126                                 puts "  *** $file is a valid Matlab plot";
 127                                 # break searching here
 128                                 break
 129                         }
 130                 }
 131         }
 132 }
 133
 134 # exit with message when no source files are found
 135 if [llength $validfiles]<1 {
 136         puts "  *** No valid matlab .eps files found. Bye!";
 137         return -1
 138 }
 139
 140 # PART 3____________________________________________________
 141 foreach file $validfiles {
 142         puts "Processing $file...";
 143         # open each matlab eps file
 144         if [catch {open $file r} result] {
 145                 puts "Warning: $result"
 146                 return -1
 147         } else {
 148                 set fp $result
 149                 set data [read $fp]
 150                 close $fp
 151         }
 152         # the stack emulator
 153         set source_stack ""
 154         # the xcircuit output vector
 155         set xcircuit_output ""
 156         # the xcircuit lib definitions
 157         set xcircuit_libdefs ""
 158         # the color definitions library
 159         set colordefs ""
 160
 161         # split data in seperate lines
 162         set data [split $data "\n"]
 163         set object_list {}
 164         foreach line $data {
 165                 append source_stack "\x0a$line"
 166                 # Skip first part of matlab $source_stack if noaxes is set
 167                 if [regexp {\/c8} $line matchresult] then {
 168                         if {$axes == 0} then {
 169                                 # clear output
 170                                 set xcircuit_output ""
 171                         } else {
 172                                 # select all items in page, make object, and deselect
 173                                 if {[llength $object_list] > 0} then {
 174                                         select $object_list
 175                                         set axes_object [object make "axes"]
 176                                         deselect $axes_object
 177                                 }
 178                         }
 179                 }
 180                 # Extract polylines from the matlab $source_stack
 181                 if [regexp {(\d+)\s*MP\sstroke} $line matchresult sub1] {
 182                         # extract the number of vertices of the polyline
 183                         set num_vertices $sub1
 184                         # the number of arguments to read is thus 2*num_vertices
 185                         set num_args [expr $num_vertices*2]
 186                         # extract the vertices list of the polyline
 187                         set re "\\x0a+\\s*((?:\-?\\d+\\x20*\\x0a*)+?)\\s+$num_vertices\\s+MP\\sstroke"
 188                         if [regexp $re $source_stack matchresult sub1] then {
 189                                 # replace 1+ spaces by the ":" separator
 190                                 regsub -all {\s+} $sub1 ":" sub1
 191                                 # split $sub1 based on the ":" separator
 192                                 set polyline_vertices [split $sub1 ":"]
 193                                 # the polyline_vertices list contains all vertices
 194                                 # --> {<undefined data> x1 y1 x2 y2 ... xn yn}
 195                         } else {
 196                                 puts "Error in polyline regular expression. Exiting..."
 197                                 return -1
 198                         }
 199                         # convert the arguments to the xcircuit coordinate format.
 200                         # The matlab polyline coordinates are relative to each other,
 201                         # starting for the last value of the postscript stack.
 202                         # XCircuit needs absolute coordinates for the polyline vertices.
 203                         # Some recalculation is thus needed to obtain absolute coordinates.
 204                         for {set i [expr $num_args-4]} {$i>=0} {incr i -2} {
 205                                 # calculate x-coordinates
 206                                 set prev_point_x [lindex $polyline_vertices $i]
 207                                 set current_point_x [lindex $polyline_vertices [expr $i+2]]
 208                                 lset polyline_vertices $i [expr $prev_point_x+$current_point_x]
 209                                 # calculate y-coordinates
 210                                 set prev_point_y [lindex $polyline_vertices [expr $i+1]]
 211                                 set current_point_y [lindex $polyline_vertices [expr $i+3]]
 212                                 lset polyline_vertices [expr $i+1] [expr $prev_point_y+$current_point_y]
 213                         }
 214                         # Rescaling feature. Should be re-implemented in a decent way
 215                         for {set i 0} {$i<$num_args} {incr i 1} {
 216                                 lset polyline_vertices $i [expr int([lindex $polyline_vertices $i]*$scalefactor)]
 217                         }
 218                         # Flip the y-axis coordinates. XCircuit's coordinate system seems to use
 219                         # the left hand rule.
 220                         for {set i 1} {$i<$num_args} {incr i 2} {
 221                                 lset polyline_vertices $i [expr [lindex $polyline_vertices $i]*-1]
 222                         }
 223                         # create the tcl command and draw the polygon
 224                         set prev_point_x 0
 225                         set prev_point_y 0
 226                         set num_vertices 0
 227                         set tcl_command ""
 228                         eval "fill 0"
 229                         for {set i 0} {$i<$num_args} {incr i 2} {
 230                                 # the number of vertices xcircuit can handle is limited to 250
 231                                 if {$num_vertices == 200} then {
 232                                         eval "lappend object_list \[polygon make 200 $tcl_command\]"
 233                                         set prev_point_x 0
 234                                         set prev_point_y 0
 235                                         set num_vertices 0
 236                                         set tcl_command ""
 237                                         # resume last point in next polyline
 238                                         incr i -2
 239                                 }
 240                                 # extract the current x- and y-coordinates
 241                                 set current_point_x [lindex $polyline_vertices $i]
 242                                 set current_point_y [lindex $polyline_vertices [expr $i+1]]
 243                                 # drop the current vertex if distance from previous point is too small
 244                                 if {   abs([expr $current_point_x - $prev_point_x]) < 1
 245                                     && abs([expr $current_point_y - $prev_point_y]) < 1} then {
 246                                         # drop the current vertex
 247                                         continue
 248                                 # add the current vertex to the tcl_command string
 249                                 } else {
 250                                         # increase the number of vertices in the tcl_command
 251                                         incr num_vertices 1
 252                                         # append the current vertex to the tcl_command string
 253                                         # format: "polygon make N {x1 y1} {x2 y2} ... {xn yn}"
 254                                         append tcl_command "\{$current_point_x $current_point_y\} "
 255                                         # save the current vertex for future reference
 256                                         set prev_point_x $current_point_x
 257                                         set prev_point_y $current_point_y
 258                                 }
 259                         }
 260                         # Evaluate the tcl_command
 261                         eval "lappend object_list \[polygon make $num_vertices $tcl_command\]"
 262                         # flush stack
 263                         set source_stack ""
 264                         set line ""
 265                 }
 266                 # Extract filled polylines from the matlab $source_stack
 267                 if [regexp {(\d+)\s+MP} $line matchresult sub1] {
 268                         set num_vertices $sub1
 269                         set num_args [expr $num_vertices*2]
 270                         # extract the vertices list of the polyline
 271                         set re "\\x0a+\\s*((?:\-?\\d+\\x20*\\x0a*)+)\\s+$num_vertices\\s+MP"
 272                         if [regexp $re $source_stack matchresult sub1] then {
 273                                 # replace 1+ spaces by the ":" separator
 274                                 regsub -all {\s+} $sub1 ":" sub1
 275                                 # split $sub1 based on the ":" separator
 276                                 set polyline_vertices [split $sub1 ":"]
 277                                 # the polyline_vertices list contains all vertices
 278                                 # --> {<undefined data> x1 y1 x2 y2 ... xn yn}
 279                         } else {
 280                                 puts "Error in filled polyline regular expression. Exiting..."
 281                                 return -1
 282                         }
 283                         # convert the arguments to the xcircuit coordinate format.
 284                         # The matlab polyline coordinates are relative to each other,
 285                         # starting for the last value of the postscript stack.
 286                         # XCircuit needs absolute coordinates for the polyline vertices.
 287                         # Some recalculation is thus needed to obtain absolute coordinates.
 288                         for {set i [expr $num_args-4]} {$i>=0} {incr i -2} {
 289                                 # calculate x-coordinates
 290                                 set prev_point_x [lindex $polyline_vertices $i]
 291                                 set current_point_x [lindex $polyline_vertices [expr $i+2]]
 292                                 lset polyline_vertices $i [expr $prev_point_x+$current_point_x]
 293                                 # calculate y-coordinates
 294                                 set prev_point_y [lindex $polyline_vertices [expr $i+1]]
 295                                 set current_point_y [lindex $polyline_vertices [expr $i+3]]
 296                                 lset polyline_vertices [expr $i+1] [expr $prev_point_y+$current_point_y]
 297                         }
 298                         # Rescaling feature. Should be re-implemented in a decent way
 299                         for {set i 0} {$i<$num_args} {incr i 1} {
 300                                 lset polyline_vertices $i [expr int([lindex $polyline_vertices $i]*$scalefactor)]
 301                         }
 302                         # Flip the y-axis coordinates. XCircuit's coordinate system seems to use
 303                         # the left hand rule.
 304                         for {set i 1} {$i<$num_args} {incr i 2} {
 305                                 lset polyline_vertices $i [expr [lindex $polyline_vertices $i]*-1]
 306                         }
 307                         # create the tcl command and draw the polygon
 308                         set prev_point_x 0
 309                         set prev_point_y 0
 310                         set num_vertices 0
 311                         set tcl_command ""
 312                         for {set i 0} {$i<$num_args} {incr i 2} {
 313                                 # the number of vertices xcircuit can handle is limited to 250
 314                                 if {$num_vertices > 200} then break
 315                                 # extract the current x- and y-coordinates
 316                                 set current_point_x [lindex $polyline_vertices $i]
 317                                 set current_point_y [lindex $polyline_vertices [expr $i+1]]
 318                                 # drop the current vertex if distance from previous point is too small
 319                                 if {   abs([expr $current_point_x - $prev_point_x]) < 2
 320                                     && abs([expr $current_point_y - $prev_point_y]) < 2} then {
 321                                         # drop the current vertex
 322                                         continue
 323                                 # add the current vertex to the tcl_command string
 324                                 } else {
 325                                         # increase the number of vertices in the tcl_command
 326                                         incr num_vertices 1
 327                                         # append the current vertex to the tcl_command string
 328                                         # format: "polygon make N {x1 y1} {x2 y2} ... {xn yn}"
 329                                         append tcl_command "\{$current_point_x $current_point_y\} "
 330                                         # save the current vertex for future reference
 331                                         set prev_point_x $current_point_x
 332                                         set prev_point_y $current_point_y
 333                                 }
 334                         }
 335                         # Evaluate the tcl_command. Only write if we have a valid color,
 336                         # different from white (white color index is 1 in xcircuit)
 337                         if {[color get] != 1} then {
 338                                 eval "fill 100"
 339                                 eval "lappend object_list \[polygon make $num_vertices $tcl_command\]"
 340                                 eval "fill 0"
 341                         }
 342                         # flush stack
 343                         set source_stack ""
 344                         set line ""
 345                 }
 346                 # Extract lines from the matlab $source_stack
 347                 set re "(\\d+)\\s+(\\d+)\\s+mt\\s+(\\d+)\\s+(\\d+)\\sL"
 348                 if [regexp $re $line matchresult sub1 sub2 sub3 sub4] then {
 349                         set x1 [expr int($sub1*$scalefactor)]
 350                         set y1 [expr int(-$sub2*$scalefactor)]
 351                         set x2 [expr int($sub3*$scalefactor)]
 352                         set y2 [expr int(-$sub4*$scalefactor)]
 353                         # Create the tcl command and draw the line
 354                         eval "lappend object_list \[polygon make 2 {$x1 $y1} {$x2 $y2}\]"
 355                         # clear the source stack
 356                         set source_stack ""
 357                         set line ""
 358                 }
 359                 # Extract points from the matlab $source_stack
 360                 set re "(\\d+)\\s+(\\d+)\\s+PD"
 361                 if [regexp $re $line matchresult sub1 sub2] then {
 362                         set x1 [expr int($sub1*$scalefactor)]
 363                         set y1 [expr -int($sub2*$scalefactor)]
 364                         set dotsize [expr int(15*$scalefactor)]
 365                         # concatenate all lines in one vector
 366                         eval "fill 100"
 367                         eval "lappend object list \[arc make \{$x1 $y1\} $dotsize\]"
 368                         eval "fill 0"
 369                         # clear the source stack
 370                         set source_stack ""
 371                         set line ""
 372                 }
 373                 # Extract axes labels from the matlab $source_stack
 374                 set re "(\\d+)\\s+(\\d+)\\s+mt\\s*\\n\\((.*)\\)"
 375                 if [regexp $re $source_stack matchresult sub1 sub2 sub3] then {
 376                         set x1 [expr int($sub1*$scalefactor)]
 377                         set y1 [expr -int($sub2*$scalefactor)]
 378                         set labeltext $sub3
 379                         # some experimental rescaling. Should be reimplemented in the future
 380                         set textsize [expr $matlab_textsize*4*$scalefactor/168]
 381                         # concatenate all text in one vector
 382                         # also remove empty labels (causes segfault in xcircuit-3.4.26)
 383                         if {$bold == 1 && [regexp {[^\s]+} $labeltext]} then {
 384                                 eval "label style bold"
 385                                 eval "label scale $textsize"
 386                                 eval "lappend object_lsit \[label make normal \"$labeltext\" \{$x1 $y1\}\]"
 387                         } elseif [regexp {[^\s]+} $labeltext] {
 388                                 eval "label scale $textsize"
 389                                 eval "lappend object_list \[label make normal \"$labeltext\" \{$x1 $y1\}\]"
 390                         }
 391                         # clear the source stack
 392                         set source_stack ""
 393                         set line ""
 394                 }
 395                 # Extract color definitions from the matlab $source_stack
 396                 set re "(\\/c\\d+\\s+\\{\\s\\d+\\.\\d+\\s+\\d+\\.\\d+\\s+\\d+\\.\\d+\\s+sr\\}\\sbdef)"
 397                 if [regexp $re $source_stack matchresult sub1] then {
 398                         # add color definition to library
 399                         append colordefs $sub1
 400                         # clear the source stack
 401                         set source_stack ""
 402                         set line ""
 403                 }
 404                 # Extract the text size from the matlab $source_stack
 405                 set re "(\\d+) FMSR"
 406                 if [regexp $re $line matchresult sub1] then {
 407                         set matlab_textsize $sub1
 408                         append colordefs $sub1
 409                         # clear the source stack
 410                         set source_stack ""
 411                         set line ""
 412                 }
 413                 # Retrieve the color specified on the matlab $source_stack
 414                 set re "(c\\d+)"
 415                 if [regexp $re $line matchresult sub1] then {
 416                         # extract color from the library
 417                         set re "\\/$sub1\\s+\\{\\s(\\d+\\.\\d+)\\s+(\\d+\\.\\d+)\\s+(\\d+\\.\\d+)\\s+sr\\}\\sbdef"
 418                         if [regexp $re $colordefs matchresult sub1 sub2 sub3] then {
 419                                 set red [expr int($sub1*255)]
 420                                 set green [expr int($sub2*255)]
 421                                 set blue [expr int($sub3*255)]
 422                                 set rgb [dec2rgb $red $green $blue]
 423                                 # add color to xcircuit output
 424                                 set color_index [eval "color add $rgb"]
 425                                 eval "color set $color_index"
 426                                 # clear the source stack
 427                                 set source_stack ""
 428                                 set line ""
 429                         }
 430                 }
 431                 # Extract grayscale colors from the matlab $source_stack
 432                 set re "(\[0-9\]*\\.\[0-9\]+|\[0-9\]+)\\ssg"
 433                 if [regexp $re $line matchresult sub1] then {
 434                         set greylevel [expr int($sub1*255)]
 435                         set rgb [dec2rgb $greylevel $greylevel $greylevel]
 436                         # add color to xcircuit output
 437                         set color_index [eval "color add $rgb"]
 438                         eval "color set $color_index"
 439                         # clear the source stack
 440                         set source_stack ""
 441                         set line ""
 442                 }
 443                 # Extract solid/dotted linestyle ftom the matlab $source_stack
 444                 set re "((?:SO)|(?:DO)|(?:DA)|(?:DD))"
 445                 if [regexp $re $line matchresult sub1] then {
 446                         if {$sub1 == "DO"} then {
 447                                 eval "border dotted"
 448                         } elseif {$sub1 == "SO"} then {
 449                                 eval "border solid"
 450                         } elseif {$sub1 == "DA"} then {
 451                                 eval "border dashed"
 452                         } elseif {$sub1 == "DD"} then {
 453                                 eval "border solid"
 454                         }
 455                         # clear the source stack
 456                         set source_stack ""
 457                         set line ""
 458                 }
 459         }
 460         puts "  *** $file import OK";
 461 # >> end of foreach file
 462 }
 463 # >> end of proc matgen
 464 }
 465
 466 # PART 4____________________________________________________
 467 # Extract from util-color.tcl
 468 # Copyright (c) 1998 Jeffrey Hobbs
 469 #
 470 # dec2rgb --
 471 #
 472 # See the file "license.terms" for information on usage and
 473 # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 474 #
 475 #
 476 #   Takes a color name or dec triplet and returns a #RRGGBB color.
 477 #   If any of the incoming values are greater than 255,
 478 #   then 16 bit value are assumed, and #RRRRGGGGBBBB is
 479 #   returned, unless $clip is set.
 480 #
 481 # Arguments:
 482 #   r           red dec value, or list of {r g b} dec value or color name
 483 #   g           green dec value, or the clip value, if $r is a list
 484 #   b           blue dec value
 485 #   clip        Whether to force clipping to 2 char hex
 486 # Results:
 487 #   Returns a #RRGGBB or #RRRRGGGGBBBB color
 488 #
 489 proc dec2rgb {r {g 0} {b UNSET} {clip 0}} {
 490     if {![string compare $b "UNSET"]} {
 491         set clip $g
 492         if {[regexp {^-?(0-9)+$} $r]} {
 493             foreach {r g b} $r {break}
 494         } else {
 495             foreach {r g b} [winfo rgb . $r] {break}
 496         }
 497     }
 498     set max 255
 499     set len 2
 500     if {($r > 255) || ($g > 255) || ($b > 255)} {
 501         if {$clip} {
 502             set r [expr {$r>>8}]; set g [expr {$g>>8}]; set b [expr {$b>>8}]
 503         } else {
 504             set max 65535
 505             set len 4
 506         }
 507     }
 508     return [format "#%.${len}x%.${len}x%.${len}x" \
 509             [expr {($r>$max)?$max:(($r<0)?0:$r)}] \
 510             [expr {($g>$max)?$max:(($g<0)?0:$g)}] \
 511             [expr {($b>$max)?$max:(($b<0)?0:$b)}]]
 512 }
 513