How to extract the required lines from a file using TCL? - tcl

My file looks like this below. I want to extract only id, pos and type from file so that I can use it further. Should I need to treat this data as a list and use lindex syntax to retrieve.
{particles {id pos type v f}
{0 442.3601602032813 775.8494355067412 339.7428247245854 0 -1.0649468656691174 0.3118359585805807 0.7974629587243917 -7.856415738784473 120.82920096524781 80.7680149353967}
{1 75.78431491144367 187.28007812237516 279.3569202413006 0 0.3317344469183915 3.0716559473604916 -1.679965732986453 2.573367640795655 -11.46026754809828 125.75306472245369}
{2 44.167251258358164 371.8839725825084 80.32709197838003 0 -0.6260768510694417 0.9493261445672099 0.9445444874655268 -98.8132600015945 -80.10617403827258 43.578514821777155}
{3 289.0168944249348 193.4364952458922 96.30251497465443 0 -0.5327035586676473 1.028492567403681 4.364969924730662 139.09290151549465 75.46717320097427 -29.955066397359094}
{4 324.94257366360085 404.9215380451672 799.3481016151578 0 -1.2801842708841038 -4.320355658821216 2.9394195915181567 -109.72971491904342 -44.06068452005151 118.2802261191011}
{5 598.4521733790556 447.74320547029174 750.4399422142899 0 1.740414834859398 -0.5926143788565617 1.5937397085063156 -155.08309023301794 186.08101953841978 177.1804659692657}
}
This is the code I have used below. Can anyone tel me the code which I used is correct or not.
set num_part 6
set mol1 0.1666
set mol2 0.8333
set num_conf 2
for {set i 0} {$i < $num_conf} {incr i} {
set f [open "config_$i" "r"]
set part [while { [blockfile $f read auto] != "eof" } {} ]
set g [open "positions" "w"]
blockfile $g write particles {id pos type}
close $f
close $g
set g [open "positions" "r"]
set data [read $g]
close $g
set num0 0
for {set j 0} {$j < [expr { $num_part + 1 }]} {incr j} {
set type [lindex $data 0 $j 4]
if { $type == 0 } {
set tlist [expr $i]
set x0 [lindex $data 0 $j 1]
set y0 [lindex $data 0 $j 2]
set z0 [lindex $data 0 $j 3]
set total1 [ expr { sqrt(($x0 * $x0) + ($y0 * $y0)+ ($z0 * $z0)) }]+0]
incr num0
puts " $i :: $num0 "
set dum 0
for {set k 0} {$k < [expr { $num_part + 1 }]} {incr k} {
set type [lindex $data 0 $k 4]
if { $type == 1 } {
set tlist [expr $i]
set x1 [lindex $data 0 $k 1]
set y1 [lindex $data 0 $k 2]
set z1 [lindex $data 0 $k 3]
set total2 [ expr { sqrt(($x1 * $x1) + ($y1 * $y1)+ ($z1 * $z1)) }]+0]
incr dum
puts " $i :: $dum "
}
}
}
}
}
set h [open "dist12" "w"]
set dist12 [ expr {($mol1 * $total1)-($mol2 * $total2)}]
puts "Distance between cross particles $dist12"
puts $h "\# t $dist12 "
foreach t $tlist dist" $dist12 { puts $h "$t $dist_12" }
close $h

You've a few lines that look suspicious.
1:
set part [while { [blockfile $f read auto] != "eof" } {} ]
The result of while is an empty string, so the above code probably isn't doing what you hope. Not quite sure how to fix it though; blockfile isn't a standard Tcl command.
2:
for {set j 0} {$j < [expr { $num_part + 1 }]} {incr j} {
Not really a correctness issue, but that could be written as:
for {set j 0} {$j < $num_part + 1} {incr j} {
The bytecode generated will be virtually identical, but it's shorter and easier to read.
3:
set tlist [expr $i]
This looks unnecessary and suspcious. We know i is a numeric variable (in fact it contains an integer), so there's no need to pretend it is an expression. It slows things down for no benefit.
You've two occurrences of this.
4:
set total1 [ expr { sqrt(($x0 * $x0) + ($y0 * $y0)+ ($z0 * $z0)) }]+0]
This line is definitely wrong. The number of ] characters doesn't match the number of [ characters, so what you get will be “unexpected”, and that +0 is either useless or harmful. It's probably best to write a procedure to help you with this. Put the procedure at the top of the script.
proc length {x y z} {
expr { sqrt($x*$x + $y*$y + $z*$z) }
}
Then just call it later on:
set total1 [length $x0 $y0 $z0]
The same applies to the calculation of total2 later.
5:
foreach t $tlist dist" $dist12 { puts $h "$t $dist_12" }
Looks like this has a typo: dist" instead of dist. The failure to use dist inside the loop also looks odd; I think you're going wrong here, and should take another look and think about what you actually want to do.

Related

how to code inverse of a 3 X 3 matrix in tcl scripting?

I'm finding difficulty in coding for inverse of a 3x3 matrix in tcl. do we really need packages to code for matrix , i need clear explanation for the following parts with minimal simpler coding
1.how to create matrix ?
2.how to find determinant?
3.how to find inverse of it ?
We don't need packages — they're just Tcl code after all — but they do simplify things quite a bit sometimes.
Matrices are represented in Tcl as lists of lists of numbers; it's the natural representation. Think of them being like this (which is row-major form):
set myMatrix {
{ 1.0 -2.0 3.0 }
{-4.0 5.0 -6.0 }
{ 7.0 -8.0 -9.0 }
}
But that can be rewritten like this (it's just a change of whitespace, which isn't significant):
set myMatrix {{1.0 -2.0 3.0} {-4.0 5.0 -6.0} {7.0 -8.0 -9.0}}
The code to invert such a matrix is on the Tcler's Wiki:
puts [Inverse3 $myMatrix]
# {-1.7222222222222223 -0.7777777777777778 -0.05555555555555555} {-1.4444444444444444 -0.5555555555555556 -0.1111111111111111} {-0.05555555555555555 -0.1111111111111111 -0.05555555555555555}
This is the code from the Wiki page, saved here in case the page gets edited away (and using the optimised _Cofactor3).
proc Inverse3 {matrix} {
if {[llength $matrix] != 3 ||
[llength [lindex $matrix 0]] != 3 ||
[llength [lindex $matrix 1]] != 3 ||
[llength [lindex $matrix 2]] != 3} {
error "wrong sized matrix"
}
set inv {{? ? ?} {? ? ?} {? ? ?}}
# Get adjoint matrix : transpose of cofactor matrix
for {set i 0} {$i < 3} {incr i} {
for {set j 0} {$j < 3} {incr j} {
lset inv $i $j [_Cofactor3 $matrix $i $j]
}
}
# Now divide by the determinant
set det [expr {double([lindex $matrix 0 0] * [lindex $inv 0 0]
+ [lindex $matrix 0 1] * [lindex $inv 1 0]
+ [lindex $matrix 0 2] * [lindex $inv 2 0])}]
if {$det == 0} {
error "non-invertable matrix"
}
for {set i 0} {$i < 3} {incr i} {
for {set j 0} {$j < 3} {incr j} {
lset inv $i $j [expr {[lindex $inv $i $j] / $det}]
}
}
return $inv
}
proc _Cofactor3 {matrix i j} {
set COLS {{1 2} {0 2} {0 1}}
lassign [lindex $COLS $j] row1 row2
lassign [lindex $COLS $i] col1 col2
set a [lindex $matrix $row1 $col1]
set b [lindex $matrix $row1 $col2]
set c [lindex $matrix $row2 $col1]
set d [lindex $matrix $row2 $col2]
set det [expr {$a*$d - $b*$c}]
if {($i+$j) & 1} { set det [expr {-$det}]}
return $det
}

How to sum coordinates in TCL

I have a data file (*.dat) containing x, y, z coordinates. As following:
{26.3612117767334 40.19668960571289 54.13957977294922}
{27.351043701171875 40.57518768310547 54.05387496948242}
{29.48208999633789 42.08218765258789 56.42238235473633}
For this file I need to do a math operation as follow:
Xi + (Xf-Xi/4) ; Yi + (Yf-Yi/4) ; Zi + (Zf-Zi/4)
where "i" is the initial position and "f" the final, meaning that Xi,Yi,Zi are the data on the first line and Xf,Yf,Zf the data on the second.
I need to do these calculation for all the lines in a loop and then stored in a separate file, but I do not have idea how to do it in TCL. Thanks in advance for your help.
Since the contents of your file can be treated as a bunch of tcl lists, one per line (so basically a list of lists), parsing it is dead simple.
Something like:
set f [open file.dat]
set coords [read -nonewline $f]
close $f
for {set i 0} {$i < [llength $coords] - 1} {incr i} {
lassign [lindex $coords $i] xi yi zi
lassign [lindex $coords $i+1] xf yf zf
set xn [expr {$xi + ($xf - $xi/4.0)}]
set yn [expr {$yi + ($yf - $yi/4.0)}]
set zn [expr {$zi + ($zf - $zi/4.0)}]
puts "{$xn $yn $zn}"
}
This skips treating the last line as an initial set of coordinates because there is no next set for it.
This is a good opportunity to write a mathfunc:
proc tcl::mathfunc::f {ai af} {
expr {$ai * 0.75 + $af}
}
proc transform {file} {
set fh [open $file]
# read the first line, aka the initial "previous line"
gets $fh line
scan $line {{%f %f %f}} xi yi zi
# process the rest of the file
while {[gets $fh line] != -1} {
scan $line {{%f %f %f}} xf yf zf
puts "{[expr {f($xi, $xf)}] [expr {f($yi, $yf)}] [expr {f($zi, $zf)}]}"
lassign [list $xf $yf $zf] xi yi zi
}
close $fh
}
transform file.dat
outputs
{47.121952533721924 70.72270488739014 94.65855979919434]}
{49.9953727722168 72.51357841491699 96.96278858184814]}
I present an alternate method that uses lrange to pick the overlapping ranges of sublists that participate (so we can then process them element-wise) and then lmap to apply the same transformation expression to each coordinate axis.
# Same read-in code as Shawn's answer; it's the easiest way
set f [open file.dat]
set coords [read -nonewline $f]
close $f
foreach Ci [lrange $coords 0 end-1] Cf [lrange $coords 1 end] {
# I often like to put expressions on their own line for clarity
puts [list [lmap _i $Ci _f $Cf {expr {
$_i + ($_f - $_i/4.0)
}}]]
}
(The wrapping list call in there puts braces around the result of lmap.)

Print a Pyramid using TCL

I am confused how to concat and repeat a character using PERL. Kindly help me out. I need to print a Pyramid using TCL. Below is my code.
Tcl
set height 10
set spaceChar " "
set pyramidChar ^
for {set i 1} {$i <= $height} {incr i} {
set y "concat {$spaceChar *($height - $i)} {$pyramidChar * $i} "
puts $y
}
PERL < Which works >
print "Please Enter Pyramind Height:";
my $height = <>; chomp($height); # strip of new lines
my $char='^';
for(my $i=1; $i<=$height; ++$i){
print ' ' x ($height-$i) . $char x (2*$i-1), "\n";
You're missing the fact that arithmetic has to be done with the expr command. Also, perl . => tcl append and perl x => tcl string repeat
The translation of your perl is
for {set i 1} {$i <= $height} {incr i} {
puts [string cat [string repeat " " [expr {$height - $i}]] [string repeat $char [expr {$i*2-1}]]]
}
Although long lines of Tcl code can be quite hard to read with all the nested brackets. Perhaps:
for {set i 1} {$i <= $height} {incr i} {
set indent [string repeat " " [expr {$height - $i}]]
set tier [string repeat $char [expr {$i*2-1}]]
puts "$indent$tier"
}
concat is a list operator, not a string operator.
The x operator in perl repeats a string. You cannot translate that to a * in Tcl. You need to use the string repeat command.
To concatenate characters in Tcl, simply put them next to each other, e.g.
set y "[string repeat { } 5][string repeat {^} 2]"
I am using quotes here for clarity -- they're not really necessary in this case. Or use the string cat command.
set y [string cat [string repeat { } 5][string repeat {^} 2]]

How to read number count of words?

How to read number count of words?
Lines has this format:
vertices_count
X, Y
X, Y
X, Y
(X, Y pair can be in the same line)
for example:
3
12.5, 56.8
12.5, 56.8
12.5, 56.8
I would like to read vertices_count number of words(escaping comma):
So for above example reading words should be:
12.5 56.8 12.5 56.8 12.5 56.8
set fh [open f r]
gets $fh num
read $fh data
close $fh
set number_re {-?\d+(?:\.\d*)?|-?\d*\.\d+}
set vertices {}
foreach {_ x y} [regexp -inline -all "($number_re),\\s*($number_re)" $data] {
lappend vertices $x $y
if {[llength $vertices] == $num * 2} break
}
puts $vertices
# => 12.5 56.8 12.5 56.8 12.5 56.8
while {[llength $vertices] < $num * 2} {
gets $fh line
foreach {_ x y} [regexp -inline -all "($number_re),\\s*($number_re)" $line] {
lappend vertices $x $y
if {[llength $vertices] == $num * 2} break
}
}
close $fh
I'm still not clear exactly what you are after. Here is some code to read data from a named file. Judging from your other question, you can have several sets of data in your input stream and this code returns them all as a list. Each element of the list is one set of coordinates
# Read the input from file
set fil [open filename.file]
set input [read $fil]
close $fil
set data [list]; # No output so for
set seekCount yes; # Next token is a vertex count
foreach token [string map {, " "} $input] {
# Convert commas to spaces
if {$seekCount} {
set nCoords [expr $token * 2];
# Save number of coordinates
set datum [list]; # Clean out vertex buffer
} else {
lappend datum $token; # Save coordinate
incr nCoords -1
if {$nCoords <= 0} {
# That was the last coordinate
lappend data $datum; # Append the list of coordinates
set seekCount yes; # and look for anopther count
}
}
}
This is a very quick-and-dirty solution, which makes no attempt to handle errors. One thing, however that it will cope with is variable amounds of whitespace and missing whitespace after the commas.
Good luck, I hope this helps.
This procedure first reads a count line, then reads that number of lines and puts as a list into $varName. It returns the number of elements in $varName, or -1 if EOF occured before a count was read.
proc getNLines {stream varName} {
upvar 1 $varName lines
set lines {}
if {[gets $stream n] < 0} {
return -1
}
while {$n > 0} {
if {[gets $stream line] < 0} {
error "bad data format"
}
lappend lines $line
incr n -1
}
return [llength $lines]
}
while {[getNLines stdin lines] >= 0} {
# ...
}

how to check adjacent values in tcl list?

I have a list like
set val [ list Fa2/0/1 Fa2/0/24 Gi1/0/13 Gi1/0/23 Gi1/1/1 Gi2/0/1 ]
now i want to put it in a loop and execute some commands over each range
like
set number 0
set pattern 0
foreach n $val {
if {$pattern == 0} {
set current $n
regexp {(.*/)(\d+)} $n - pattern number
continue
}
regexp {(.*/)(\d+)} $n - match1 match2
if {$match1 == $pattern} {
#puts "someproc $current - match2"
}
}
I am unable to get this work the output should be like for ech pair or singular value found
someproc Fa2/0/1 - 24
someproc Gi1/0/13 - 23
someproc Gi1/1/1 - 1 #for singular values
someproc Gi2/0/1 - 1
EDIT : i have a list of such data like :
Gi3/0/1 Fa2/0/1 Fa2/0/24 Gi1/0/13 Gi1/0/23 Gi1/1/1 Gi2/0/1 Te1/0/1
where you can say each data can be of type Gi3/0/ or Gi2/0/ or Fa2/0/ these reperesent some range of ports on cisco swicth.Now for every type i need to execute some command for a range.Again taking the above list i can get.
somecommand Gi3/0/1 - 1 # there is only one `Gi3/0/` with number 1.
somecommand Fa2/0/1 - 24 # range of `Fa2/0/` is 1 to 24
similarly,
somecommand Gi1/0/13 - 23
somecommand Gi1/1/1 - 1
and so on
#!/usr/bin/tcl
## Assumptions:
## The pattern will always be X/X/X
## The values are given in list
set val_list [list Fa2/0/1 Fa2/0/24 Gi1/0/13 Gi1/0/23 Gi1/1/1 Gi2/0/1]
array set pattern {}
foreach item $val_list {
set parent [file dir $item]
set val [file tail $item]
if {[info exists pattern($parent,L)] && [info exists pattern($parent,H)] } {
if {$pattern($parent,L) > $val } {
set pattern($parent,L) $val
} elseif { $pattern($parent,H) < $val} {
set pattern($parent,H) $val
}
} else {
set pattern($parent,L) $val
set pattern($parent,H) $val
}
}
array set count {}
foreach pat [array names pattern] {
set pat [lindex [split $pat ,] 0]
if {![info exists count($pat)] } {
puts "$pat $pattern($pat,L) - $pattern($pat,H)"
set count($pat) 1
}
}
/*The output will be
Gi1/0 13 - 23
Fa2/0 1 - 24
Gi2/0 1 - 1
Gi1/1 1 - 1
*/
Hope this is what you are requesting for. I used array "count" to remove duplicate entries in output, which needs to be avoided. Hope if someone can suggest any better way. And FYI I am using 8.4 version of TCL.
If you are not sure how arrays, work, you can edit the code you posted as an answer to this code:
set number 0
set pattern 0
set current 0
set result [list Gi3/0/1 Fa2/0/1 Fa2/0/24 Gi1/0/13 Gi1/0/23 Gi1/1/1 Gi2/0/1 Te1/0/1]
foreach n [lsort $result] {
if {$pattern == 0} {
set current $n
regexp {(.*/)(\d+)} $n - pattern number
continue
}
regexp {(.*/)(\d+)} $n - match1 match2
if {$match1 == $pattern} {
set number $match2
} else {
puts "$current - $number"
set pattern $match1
set number $match2
set current $n
}
}
That works for me :)
The output (note that I sorted the list first so you only have to worry about the increasing $number or $match2 while not having to bother too much about the $pattern):
Fa2/0/1 - 24
Gi1/0/13 - 23
Gi1/1/1 - 1
Gi2/0/1 - 1
Gi3/0/1 - 1
Here is my solution, which does not use array (nothing is wrong with array, my solution just don't need it), and it does it in one pass (i.e. only one loop).
set val [ list Fa2/0/1 Fa2/0/24 Gi1/0/13 Gi1/0/23 Gi1/1/1 Gi2/0/1 ]
set lastPattern ""
set lastNumber 0
lappend val x/1/1; # Add a trailer to ease processing
foreach item $val {
# If item=Fa2/0/1, then pattern=Fa2/0 and number=1
set pattern [file dirname $item]
set number [file tail $item]
if {$pattern == $lastPattern} {
# We have seen this pattern before
puts "$pattern/$lastNumber - $number"
set lastPattern ""
} else {
# This is a new pattern, print the old one if applicable then
# save the pattern and number for later processing
if {$lastPattern != ""} {
puts "$lastPattern/$lastNumber - $lastNumber"
}
set lastPattern $pattern
set lastNumber $number
}
}
set val [lrange $val end-1]; # Remove the trailer
If you want to compare adjacent list elements, it might be cleaner to use a C-style for loop:
for {set i 0} {$i < [llength $val] - 1} {incr i} {
set current [lindex $val $i]
set next [lindex $val [expr {$i+1}]]
# ...
}
Or, a bit more esoteric
set l {a b c d e f g}
foreach current [lrange $l 0 end-1] \
next [lrange $l 1 end] {
puts "$current $next"
}
outputs
a b
b c
c d
d e
e f
f g
You could even write a new control structure, similar to Ruby's each_cons
proc foreach_cons {vars list body} {
foreach varname $vars {upvar 1 $varname $varname}
set numvars [llength $vars]
for {set i 0} {$i <= [llength $list]-$numvars} {incr i} {
lassign [lrange $list $i [expr {$i + $numvars}]] {*}$vars
uplevel 1 $body
}
}
foreach_cons {a b c} $l {puts "$a $b $c"}
a b c
b c d
c d e
d e f
e f g
Why don't you loop over pairs of the list?
foreach {v1 v2} $val {
someproc $v1 $v2
}
You might check if both values are similar, extract the parts that you need etc.
I came up with a awkward solution of my own :
where reslut is the list :
Gi3/0/1 Fa2/0/1 Fa2/0/24 Gi1/0/13 Gi1/0/23 Gi1/1/1 Gi2/0/1 Te1/0/1
#
set number 0
set pattern 0
set last_element [lindex $result end]
set first_element [lindex $result 0]
foreach n $result {
if {$pattern == 0} {
set current $n
set count 0
regexp {(.*/)(\d+)} $n - pattern number
continue
}
regexp {(.*/)(\d+)} $n - match1 match2
if {$match1 == $pattern} {
set count 0
puts " $current - $match2"
continue
} else {
if {"$last_element" == "$n"} {
puts "$last_element"
}
if {"$first_element" == "$current"} {
puts "$first_element"
}
incr count
if {"$count" == 1} {
set pattern $match1
set current $n
continue
} else {
if {$match1 != $pattern} {
puts "$current"
}
}
set pattern $match1
}
set current $n
}
This solution is a little shorter, but requires Tcl 8.5.
First, create a dictionary structure with the first two fields as key and subkey, and collect lists of values from the third field as dictionary values:
set data {}
foreach v $val {
lassign [split $v /] a b c
if {![dict exists $data $a $b]} {
dict set data $a $b {}
}
dict with data $a {
lappend $b $c
set b [lsort –integer $b]
}
}
Then iterate over this dictionary structure, calling the someproc command for each combination of key, subkey, first and last value.
dict for {a v} $data {
dict for {b v} $v {
someproc $a/$b/[lindex $v 0] - [lindex $v end]
}
}
Documentation: dict, foreach, if, lappend, lassign, lindex, set, split