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
Related
I am trying to uniquify the file content. The game and score is repeated sometimes, I am trying to write out to file1
Input:
game score
a 1
a 1
a 2
b 1
b 2
b 2
Output:
Uniq1 a 1
Uniq2 a 2
Uniq3 b 1
Uniq4 b 2
Code:
while {[gets $inputfile] > 0} {
set g1 [lindex $token end]
set g2 [lindex $token end-1]
incr gcount
puts $file1 "Uniq$gcount =$g1 $g2"
}
Just store the lines as keys in a dict and iterate over the keys after reading all the input to print the values (In the order they appear in the input) without including duplicates. Example:
#!/usr/bin/env tclsh
proc main {} {
# Discard header line
gets stdin
while {[gets stdin line] > 0} {
dict set lines $line 1
}
set i 1
dict for {line _} $lines {
puts "Uniq$i $line"
incr i
}
}
main
Running this produces:
Uniq1 a 1
Uniq2 a 2
Uniq3 b 1
Uniq4 b 2
I think there are a few options, depending on the complexity. If the duplicates for example always occur one after the other, then I would just save the current row as previous row and when I get to the next row, I compare it to the previous row:
set previous(g1) ""
set previous(g2) ""
while {[gets $inputfile] > 0} {
set g1 [lindex $token end]
set g2 [lindex $token end-1]
if {$previous(g1) != $g1 && $previous(g2) != $g2} {
incr gcount
puts $file1 "Uniq$gcount $g1 $g2"
set previous(g1) $g1
set previous(g2) $g2
}
}
If the duplicate could happen anywhere, then I'd do it like this:
array set previous {}
while {[gets $inputfile] > 0} {
set g1 [lindex $token end]
set g2 [lindex $token end-1]
if {![info exists previous($g1,$g2)]} {
incr gcount
puts $file1 "Uniq$gcount $g1 $g2"
set previous($g1,$g2) ""
}
}
Hi I am having a code as stated below
module abcd( a , b , c ,da , fa, na , ta , ma , ra ,
ta, la , pa );
input a , b, da ,fa , na , ta , ma;
output c , ra ,ta ,
la ,pa ;
wire a , b , da , fa ,na ,
ta , ma;
// MBIST Structures
mbist_hsm_p::mbist_out_hsm_t mbist_out_hsm;
mbist_hsm_p::mbist_in_hsm_t mbist_in_hsm;
// HMS
kkkks ;
jsskks;
endmodule
Need to take the range between "MBIST Structures " and "//" and the take the first line as a input variable and second line as a output variable.
For example , I am trying below stated code
proc findrange {data start {stop ;}} {
# Find the starting pattern
set x1 [string first $start $data]
if {$x1 < 0} {
# Pattern not found
return
}
# Skip the pattern
incr x1 [string length $start]
# Find the ending pattern after the starting position
set x2 [string first $stop $data $x1]
if {$x2 < 0} {
# Return the remainder of the data when no ending pattern is found
return [string range $data $x1 end]
} else {
# Return the text between the starting and ending patterns
return [string range $data $x1 [expr {$x2 - 1}]]
}
}
set chan [open "mode.v"]
set code [read $chan]
close $chan
set var4 [ findrange $code "MBIST Structures" \/\/]
echo $var4 is printing these variables
mbist_hsm_p::mbist_out_hsm_t mbist_out_hsm;
mbist_hsm_p::mbist_in_hsm_t mbist_in_hsm;
I want to have two lists
$input should be "mbist_hsm_p::mbist_out_hsm_t mbist_out_hsm;"
$output should be "mbist_hsm_p::mbist_in_hsm_t mbist_in_hsm;"
How to create these variables from the var4 variable
When I am trying out to print out the $var4 variable , it is printing 4 independent variables
foreach p $var4 {
echo $p
}
mbist_hsm_p::mbist_out_hsm_t
mbist_out_hsm;
mbist_hsm_p::mbist_in_hsm_t
mbist_in_hsm;
Rather it should be " mbist_hsm_p::mbist_out_hsm_t mbist_out_hsm;"
and other one should be "mbist_hsm_p::mbist_in_hsm_t mbist_in_hsm;"
Two lists I am looking for
$input and $output
With a short input file like this, it is much easier to read the whole file into a variable. And for the described task I think string first is a better choice than string match.
So this is how I would do it:
proc findrange {data start {stop ;}} {
# Find the starting pattern
set x1 [string first $start $data]
if {$x1 < 0} {
# Pattern not found
return
}
# Skip the pattern
incr x1 [string length $start]
# Find the ending pattern after the starting position
set x2 [string first $stop $data $x1]
if {$x2 < 0} {
# Return the remainder of the data when no ending pattern is found
return [string range $data $x1 end]
} else {
# Return the text between the starting and ending patterns
return [string range $data $x1 [expr {$x2 - 1}]]
}
}
set chan [open "mod1.v"]
set code [read $chan]
close $chan
set out [open "output.file.txt" "w"]
puts $out [findrange $code input]
puts $out [findrange $code output]
close $out
There is some change in the white space between your input and the desired
output you specified. But you didn't indicate the rules for that transformation and they are not obvious. So, I am ignoring that for the moment.
I have a list which I am trying to modify and make a new list based on what I am trying to achieve.
Original List
$> set a {123.4:xyz 123.4:pqr 123.4:xyz 123.4:abc 123.4:mno}
$> puts $a
$> 123.4:xyz 123.4:pqr 123.4:xyz 123.4:abc 123.4:mno
I want my new list to contain following elements
$> puts $a
$> xyz pqr xyz abc mno
I tried split $a : but it did not work out for me. Please suggest what can be done.
set b [list]
foreach item $a {
catch {
regexp {\:(.*)} $item match tail
lappend b $tail
}
}
puts $b
It's possible to do above with split instead of regexp; I prefer regexp because you can extract arbitrary patterns this way.
If you've got Tcl 8.6:
set a [lmap x $x {regsub {^[^:]*:} $x ""}]
In 8.5, it's easier if you store in another variable:
set b {}
foreach x $a {
lappend b [regsub {^[^:]*:} $x ""]
}
In 8.4 and before, you also need a slightly different syntax for regsub:
set b {}
foreach x $a {
# Mandatory write back to a variable...
regsub {^[^:]*:} $x "" x
# Store the value; it isn't reflected back into the source list by [foreach]
lappend b $x
}
One Liner:
% set a {123.4:xyz 123.4:pqr 123.4:xyz 123.4:abc 123.4:mno}
% 123.4:xyz 123.4:pqr 123.4:xyz 123.4:abc 123.4:mno
set b [regexp -inline -all {[a-z]+} $a]
% xyz pqr xyz abc mno
Taddaaaa... No split required, if you have regex.
set a {123.4:xyz 123.4:pqr 123.4:xyz 123.4:abc 123.4:mno}
for {set i 0} {$i < [llength $a]} {incr i} {
lset a $i [lindex [split [lindex $a $i] ":"] 1]
}
puts $a
By making use of split command:
set a { 123.4:xyz 123.4:pqr 123.4:xyz 123.4:abc 123.4 :mno }
set c [list]
foreach ele $a {
lappend c [lindex [split $ele ":"] 1]
}
puts $c
output : xyz pqr xyz abc mno
set input {123.4:xyz 123.4:pqr 123.4:xyz 123.4:abc 123.4:mno}
set a ""
for {set i 0} {$i<[llength $input]} {incr i} {
set a "$a [string trim [lindex $input $i] {0,1,2,3,4,5,6,7,8,9,.,:}]"
}
This will trim the input.
If you have 8.5 and tcllib:
struct::list map $a {apply {{elem} {lindex [split $elem :] end}}}
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} {
# ...
}
I found a wiki page about how to calculate the depth of a list:
http://wiki.tcl.tk/11602
How can I rewrite the above code as a single proc using tcl 8.6 features lmap and apply? Perhaps "apply" is not really needed.
proc max list {
set res [lindex $list 0]
foreach e [lrange $list 1 end] {if {$e>$res} {set res $e}}
set res
}
# llmap perhaps can be replaced with lmap from Tcl 8.6
proc llmap {func list} {
set res {}
foreach e $list {lappend res [$func $e]}
set res
}
proc ldepth list {
expr {
[llength $list] == 0? 1:
[expr {[lindex $list 0] eq $list}]? 0:
1+[max [llmap ldepth $list]]
}
}
The first level of adaptation already gets us close to where you want to go, sufficiently so that this is what I'd consider as a production solution:
proc ldepth {list} {
expr {
[llength $list] == 0 ? 1 :
[lindex $list 0] eq $list ? 0 :
1 + [tcl::mathfunc::max {*}[lmap e $list {
ldepth $e
}]]
}
}
This uses the standard lmap and tcl::mathfunc::max (which is the implementation of the max() function). Note that expansion and tcl::mathfunc::max are features of Tcl 8.5, but they're very useful here.
Eliminating expansion
Let's see if we can get rid of that call to tcl::mathfunc::max with the expansion.
proc ldepth {list} {
set m -inf
expr {
[llength $list] == 0 ? 1 :
[lindex $list 0] eq $list ? 0 :
1 + [lindex [lmap e $list {
set m [expr { max($m, [ldepth $e]) }]
}] end]
}
}
Hmm, that's just a touch ugly. We might as well do this:
proc ldepth {list} {
set m -inf
expr {
[llength $list] == 0 ? 1 :
[lindex $list 0] eq $list ? 0 :
[foreach e $list {
set m [expr { max($m,[ldepth $e]) }]
}
expr {$m + 1}]
}
}
This definitely isn't getting better, except in that it doesn't keep so much state around (just a running maximum, not a list of depths). Let's go back to the version with lmap!
(What is really needed for true beauty is lfold, but that didn't get done on the grounds that sometimes you've just got to stop adding features and call a release.)
“Eliminating” recursion
The other way we can go is to see about removing the outer recursion. We can't completely eliminate the recursion altogether — we're dealing with a recursive operation over a recursive structure — but we don't need to put it in the outer level where a rename ldepth fred will cause problems. We do this by using apply to create an internal procedure-like thing, and since we're doing recursive calls, we pass the lambda term into itself. (There are tricks you can do to get that value without explicitly passing it in, but they're ugly and we might as well be honest here.)
proc ldepth {list} {
set ldepth {{ldepth list} {expr {
[llength $list] == 0 ? 1 :
[lindex $list 0] eq $list ? 0 :
1 + [tcl::mathfunc::max {*}[lmap e $list {
apply $ldepth $ldepth $e
}]]
}}
apply $ldepth $ldepth $list
}
Full-bytecode version
Subject to still doing a recursive call.
proc ldepth {list} {
expr {
[llength $list] == 0 ? [return 1] :
[lindex $list 0] eq $list ? [return 0] :
[set m -inf
foreach e $list {
set m [expr {[set d [ldepth $e]]+1>$m ? $d+1 : $m}]
}
return $m]
}
}
Fully recursion-free by using a work queue instead. This is 8.5 code — no 8.6 features required — and you could write this to be 8.4-suitable by replacing the lassigns:
proc ldepth {list} {
set work [list $list 0]
set maxdepth 0
while {[llength $work]} {
### 8.4 version
# foreach {list depth} $work break
# set work [lrange $work 2 end]
set work [lassign $work[unset -nocomplain work] list depth]
if {[llength $list] == 0} {
incr depth
} elseif {[lindex $list 0] ne $list} {
incr depth
foreach e $list {
lappend work $e $depth
}
continue
}
set maxdepth [expr {$maxdepth<$depth ? $depth : $maxdepth}]
}
return $maxdepth
}
The moral of the story? The 8.6 features don't make sense for everything.
Here's a simple one that works.
It just flattens the list until it can't be flattened any further. The number of attempts is the depth. No recursion needed.
proc ldepth {lst} {
set depth 1
set fatter $lst
set flatter [join $fatter]
while {$flatter ne $fatter} {
set fatter $flatter
set flatter [join $fatter]
incr depth
}
return depth
}
Hope this helps!