How to read number count of words? - tcl

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} {
# ...
}

Related

TCL: reading next line of a file once a certain pattern has been identified

I have this data
# Curve 0 of 2, 7 points
# x y xlow xhigh type
20.781 1 20.781 20.781
20.8102 10 20.8102 20.8102
20.8395 18 20.8395 20.8395
20.8687 13 20.8687 20.8687
20.898 15 20.898 20.898
20.9273 18 20.9273 20.9273
20.9565 13 20.9565 20.9565
# Curve 1 of 2, 7 points
# x y xlow xhigh type
21.635 2 21.635 21.635
21.6625 19 21.6625 21.6625
21.6899 29 21.6899 21.6899
21.7173 63 21.7173 21.7173
21.7447 137 21.7447 21.7447
21.7721 168 21.7721 21.7721
21.7996 109 21.7996 21.7996
All the information is an unique file, i.e block data are separated by three blank lines.
I want to collect the information that is just at the beginning of the next line that has characters # x y xlow xhigh type. Also I want to collect the information that is at the end of each block. In other words, I want to print on screen the values that are in bold letter (20.781 20.9565 21.635 21.7996).
I wrote these lines of code but I don't know how to print the info that is just below the characters # x y.
set input [open "dataHist.dat" r]
while { [gets $input line] != -1 } {
if { [string range 0 4] == "# x y"} {
}
}
Since the first line of each block tells you long it is, you can use that to tell which lines you want to extract the first number from:
#!/usr/bin/env tclsh
proc must_gets {ch var_} {
upvar $var_ var
if {[gets $ch var] < 0} {
error "Premature end of file"
}
}
proc extract_numbers {filename} {
set ch [open $filename]
try {
set nums {}
while {[gets $ch line] >= 0} {
if {[regexp {^# Curve \d+ of \d+, (\d+) points} $line -> nPoints]} {
must_gets $ch line ;# Discard '# x y ...' line.
must_gets $ch line ;# First point line
# Extract first element of it
lappend nums [lindex [split $line] 0]
# Read remaining point lines
for {set n 2} {$n <= $nPoints} {incr n} {
must_gets $ch line
}
# And extract first element of last one
lappend nums [lindex [split $line] 0]
}
}
return $nums
} finally {
chan close $ch
}
}
# 20.781 20.9565 21.635 21.7996
puts [extract_numbers dataHist.dat]

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.)

how to split a file to list of lists TCL

I'm coding TCL and I would like to split a file into two lists of lists,
the file contain:
(1,2) (3,4) (5,6)
(7,8) (9,10) (11,12)
and I would like to get two list
one for each line, that contain lists that each one contain to two number
for example:
puts $list1 #-> {1 2} {3 4} {5 6}
puts [lindex $list1 0] #-> 1 2
puts [lindex $list2 2] #-> 11 12
I tried to use regexp and split but no success
The idea of using regexp is good, but you'll need to do some post-processing on its output.
# This is what you'd read from a file
set inputdata "(1,2) (3,4) (5,6)\n(7,8) (9,10) (11,12)\n"
foreach line [split $inputdata "\n"] {
# Skip empty lines.
# (I often put a comment format in my data files too; this is where I'd handle it.)
if {$line eq ""} continue
# Parse the line.
set bits [regexp -all -inline {\(\s*(\d+)\s*,\s*(\d+)\s*\)} $line]
# Example results of regexp:
# (1,2) 1 2 (3,4) 3 4 (5,6) 5 6
# Post-process to build the lists you really want
set list([incr idx]) [lmap {- a b} $bits {list $a $b}]
}
Note that this is building up an array; long experience says that calling variables list1, list2, …, when you're building them in a loop is a bad idea, and that an array should be used, effectively giving variables like list(1), list(2), …, as that yields a much lower bug rate.
An alternate approach is to use a simpler regexp and then have scan parse the results. This can be more effective when the numbers aren't just digit strings.
foreach line [split $inputdata "\n"] {
if {$line eq ""} continue
set bits [regexp -all -inline {\([^()]+\)} $line]
set list([incr idx]) [lmap substr $bits {scan $substr "(%d,%d)"}]
}
If you're not using Tcl 8.6, you won't have lmap yet. In that case you'd do something like this instead:
foreach line [split $inputdata "\n"] {
if {$line eq ""} continue
set bits [regexp -all -inline {\(\s*(\d+)\s*,\s*(\d+)\s*\)} $line]
set list([incr idx]) {}
foreach {- a b} $bits {
lappend list($idx) [list $a b]
}
}
foreach line [split $inputdata "\n"] {
if {$line eq ""} continue
set bits [regexp -all -inline {\([^()]+\)} $line]
set list([incr idx]) {}
foreach substr $bits {
lappend list($idx) [scan $substr "(%d,%d)"]
# In *very* old Tcl you'd need this:
# scan $substr "(%d,%d)" a b
# lappend list($idx) [list $a $b]
}
}
You have an answer already, but it can actually be done a little bit simpler (or at least without regexp, which is usually a good thing).
Like Donal, I'll assume this to be the text read from a file:
set lines "(1,2) (3,4) (5,6)\n(7,8) (9,10) (11,12)\n"
Clean it up a bit, removing the parentheses and any white space before and after the data:
% set lines [string map {( {} ) {}} [string trim $lines]]
1,2 3,4 5,6
7,8 9,10 11,12
One way to do it with good old-fashioned Tcl, resulting in a cluster of variables named lineN, where N is an integer 1, 2, 3...:
set idx 0
foreach lin [split $lines \n] {
set res {}
foreach li [split $lin] {
lappend res [split $li ,]
}
set line[incr idx] $res
}
A doubly iterative structure like this (a number of lines, each having a number of pairs of numbers separated by a single comma) is easy to process using one foreach within the other. The variable res is used for storing result lines as they are assembled. At the innermost level, the pairs are split and list-appended to the result. For each completed line, a variable is created to store the result: its name consists of the string "line" and an increasing index.
As Donal says, it's not a good idea to use clusters of variables. It's much better to collect them into an array (same code, except for how the result variable is named):
set idx 0
foreach lin [split $lines \n] {
set res {}
foreach li [split $lin] {
lappend res [split $li ,]
}
set line([incr idx]) $res
}
If you have the results in an array, you can use the parray utility command to list them in one fell swoop:
% parray line
line(1) = {1 2} {3 4} {5 6}
line(2) = {7 8} {9 10} {11 12}
(Note that this is printed output, not a function return value.)
You can get whole lines from this result:
% set line(1)
{1 2} {3 4} {5 6}
Or you can access pairs:
% lindex $line(1) 0
1 2
% lindex $line(2) 2
11 12
If you have the lmap command (or the replacement linked to below), you can simplify the solution somewhat (you don't need the res variable):
set idx 0
foreach lin [split $lines \n] {
set line([incr idx]) [lmap li [split $lin] {
split $li ,
}]
}
Still simpler is to let the result be a nested list:
set lineList [lmap lin [split $lines \n] {
lmap li [split $lin] {
split $li ,
}
}]
You can access parts of the result similar to above:
% lindex $lineList 0
{1 2} {3 4} {5 6}
% lindex $lineList 0 0
1 2
% lindex $lineList 1 2
11 12
Documentation:
array,
foreach,
incr,
lappend,
lindex,
lmap (for Tcl 8.5),
lmap,
parray,
set,
split,
string
The code works for windows :
TCL file code is :
proc captureImage {} {
#open the image config file.
set configFile [open "C:/main/image_config.txt" r]
#To retrive the values from the config file.
while {![eof $configFile]} {
set part [split [gets $configFile] "="]
set props([string trimright [lindex $part 0]]) [string trimleft [lindex $part 1]]
}
close $configFile
set time [clock format [clock seconds] -format %Y%m%d_%H%M%S]
set date [clock format [clock seconds] -format %Y%m%d]
#create the folder with the current date
set folderPath $props(folderPath)
append folderDate $folderPath "" $date "/"
set FolderCreation [file mkdir $folderDate]
while {0} {
if { [file exists $date] == 1} {
}
break
}
#camera selection to capture image.
set camera "video"
append cctv $camera "=" $props(cctv)
#set the image resolution (XxY).
set resolutionX $props(resolutionX)
set resolutionY $props(resolutionY)
append resolution $resolutionX "x" $resolutionY
#set the name to the save image
set imagePrefix $props(imagePrefix)
set imageFormat $props(imageFormat)
append filename $folderDate "" $imagePrefix "_" $time "." $imageFormat
set logPrefix "Image_log"
append logFile $folderDate "" $logPrefix "" $date ".txt"
#ffmpeg command to capture image in background
exec ffmpeg -f dshow -benchmark -i $cctv -s $resolution $filename >& $logFile &
after 3000
}
}
captureImage
thext file code is :
cctv=Integrated Webcam
resolutionX=1920
resolutionY=1080
imagePrefix=ImageCapture
imageFormat=jpg
folderPath=c:/test/
//camera=video=Integrated Webcam,Logitech HD Webcam C525
This code works for me me accept the code from text file were list of parameters are passed.

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

TCL Program that Compare String

I'm trying to create a program that the First and last characters are compared, Second and second to the last are compared, Third and third to the last are compared, and so on, and if any of these characters match, the two will be converted to the uppercase of that character.
Example:
Please enter a text: Hello Philippines
finals: HEllo PhIlippinEs
I can't create any piece of code, I'm stuck with
puts "Please enter text:"
set myText [gets stdin]
string index $myText 4
Can someone help me please?
This procedure will also capitalize the first i in Phillipines because it's equidistant from the start and the end of the string.
proc compare_chars {str} {
set letters [split $str ""]
for {set i [expr {[llength $letters] / 2}]} {$i >= 0} {incr i -1} {
set a [lindex $letters $i]
set b [lindex $letters end-$i]
if {$a eq $b} {
lset letters $i [set L [string toupper $a]]
lset letters end-$i $L
}
}
join $letters ""
}
puts [compare_chars "Hello Phillipines"]
# outputs => HEllo PhIllipinEs
The simplest way to code this is to use foreach over the split-up characters. (It's formally not the most efficient, but it's very easy to code correctly.)
puts "Please enter text:"
set myText [gets stdin]
set chars [split $myText ""]
set idx 0
foreach a $chars b [lreverse $chars] {
if {[string equals -nocase $a $b]} {
lset chars $idx [string toupper $a]
}
incr idx
}
set output [join $chars ""]
puts $output
Note that the foreach is iterating over a copy of the list; there are no problems with concurrent modification. In fact, the only vaguely-tricky part from a coding perspective is actually that we need to keep track of the index to modify, in the idx variable above.
With Tcl 8.6 you could write:
set chars [split $myText ""]
set output [join [lmap a $chars b [lreverse $chars] {
expr {[string equals -nocase $a $b] ? [string toupper $a] : $a}
}] ""]
That does depend on having the new lmap command though.
If you're really stuck with 8.3 (it's unsupported and has been so for years, so you should be prioritizing upgrading to something more recent) then try this:
set chars [split $myText ""]
set idx [llength $chars]
set output {}
foreach ch $chars {
if {[string equals -nocase $ch [lindex $chars [incr idx -1]]]} {
append output [string toupper $ch]
} else {
append output [string tolower $ch]
}
}
All the features this uses were present in 8.3 (though some were considerably slower than in later versions).