Array of Product

You are given an array of positive integers @N. Write a script to return an array @M where $M[i] is the product of all elements of @N except the index $N[i].

#!/usr/bin/env tclsh
#
# You are given an array of positive integers @N.
# Write a script to return an array @M where $M[i] is the product 
# of all elements of @N except the index $N[i].
#

if {$argc <= 1} {
    puts "Please input a list."
    exit
}

set mylist $argv
set p [tcl::mathop::* {*}$mylist]
set result [list]
foreach element $mylist {lappend result [tcl::mathop::/ $p $element]}
puts $result

使用 lmap 來尋訪串列中的每一個元素來解題，可以改寫如下：

#!/usr/bin/env tclsh
#
# You are given an array of positive integers @N.
# Write a script to return an array @M where $M[i] is the product 
# of all elements of @N except the index $N[i].
#

if {$argc <= 1} {
    puts "Please input a list."
    exit
}

set mylist $argv
set p [tcl::mathop::* {*}$mylist]
set result [lmap element $mylist {tcl::mathop::/ $p $element}]
puts $result

Longest Consecutive Sequences

試著使用 Tcl 解 Longest Consecutive Sequences 問題。

#!/usr/bin/env tclsh
#
# You are given an unsorted array of integers.
# Write a script to find the longest consecutive sequence.
# Print 0 if none sequence found.
#

if {$argc <= 1} {
    puts "Please input a list."
    exit
}

# To compare two list's length
proc mysortproc {x y} {
    set len1 [llength $x]
    set len2 [llength $y]

    if {$len1 > $len2} {
        return -1
    } elseif {$len1 < $len2} {
        return 1
    } else {
        return 0
    }
}

set len [llength $argv]
set mylist [lsort -integer $argv]
set last [lindex $mylist 0]
set index 0
set results [list]
lset results $index [list $last]
for {set count 1} {$count < $len} {incr count} {
    set current [lindex $mylist $count]

    if {$current != [expr $last + 1]} {
       incr index
    }

    set indexlist [lindex $results $index]
    set indexlist [lappend indexlist $current]
    lset results $index $indexlist

    set last $current
}

# Sort our results by using sublists's length
set results [lsort -command mysortproc $results]
if {[llength [lindex $results 0]] > 1} {
    puts [lindex $results 0]
} else {
    puts 0
}

如果要使用 anonymous function，則可以改寫如下：

#!/usr/bin/env tclsh
#
# You are given an unsorted array of integers.
# Write a script to find the longest consecutive sequence.
# Print 0 if none sequence found.
#

if {$argc <= 1} {
    puts "Please input a list."
    exit
}

set len [llength $argv]
set mylist [lsort -integer $argv]
set last [lindex $mylist 0]
set index 0
set results [list]
lset results $index [list $last]
for {set count 1} {$count < $len} {incr count} {
    set current [lindex $mylist $count]

    if {$current != [expr $last + 1]} {
       incr index
    }

    set indexlist [lindex $results $index]
    set indexlist [lappend indexlist $current]
    lset results $index $indexlist

    set last $current
}

# Sort our results by using sublists's length
set results [lsort -command {apply {{x y} {
    set len1 [llength $x]
    set len2 [llength $y]

    if {$len1 > $len2} {
        return -1
    } elseif {$len1 < $len2} {
        return 1
    } else {
        return 0
    }
}}} $results]
if {[llength [lindex $results 0]] > 1} {
    puts [lindex $results 0]
} else {
    puts 0
}

也可以使用其它的方式，直接記錄 Longest Consecutive Sequences 的排序，如下所示：

#!/usr/bin/env tclsh
#
# You are given an unsorted array of integers.
# Write a script to find the longest consecutive sequence.
# Print 0 if none sequence found.
#

if {$argc <= 1} {
    puts "Please input a list."
    exit
}

set len [llength $argv]
set mylist [lsort -integer $argv]
set last [lindex $mylist 0]
set index 0
set curresult [list $last]
set maxresult [list $last]
set curval 1
set maxval 1
for {set count 1} {$count < $len} {incr count} {
    set current [lindex $mylist $count]

    if {$current == [expr $last + 1]} {
       lappend curresult $current
       incr curval

       if {$curval > $maxval} {
           set maxresult $curresult
           set maxval $curval
       }
    } else {
       set curval 1
       set curresult [list $current]
    }

    set last $current
}

if {$maxval > 1} {
    puts $maxresult
} else {
    puts "0"
}

Memfrob

使用者在命令列輸入一個字串，使用 Memfrob 編碼（字串的每個字元 XOR 42）以後輸出結果：

#!/usr/bin/env tclsh

proc memfrob {origString} {
    set length [string length $origString]
    set resultString ""
    for {set count 0} {$count < $length} {incr count} {
        set result [string index $origString $count]
        set result [binary format c [expr [scan $result %c] ^ 42]]
        append resultString $result
    }

    return $resultString
}

if {$argc >= 1} {
    set countString [lindex $argv 0]
} elseif {$argc == 0} {
    puts "Please input a string"
    exit    
}

puts "String: $countString"
puts "Result: [memfrob $countString]"

Web Services for Tcl (tclws) 3.0.0

Web Services for Tcl (tclws) 最近釋出了 3.0.0 版，加入了 -hostProtocol 選項，同時將 Tcl 版本的要求從 8.4 升到 8.6。

在最近一個月 Web Services for Tcl 有比較多的小更新版本，從 2.7.0, 2.7.1 到 3.0.0 這幾個版本的更新。

string reverse

 只是用來測試 string reverse 的 script，用來反轉使用者輸入的數字的程式：

#!/usr/bin/tclsh

puts -nonewline "Please input a number: "
flush stdout
gets stdin number
set positive 1
if {$number < 0} {
    set positive 0
    set number [expr $number * -1]
}

set number [string reverse $number]
if {$positive > 0} {
    puts $number
} else {
    set number [expr $number * -1]
    puts $number
}

TclTLS 1.7.22

 TclTLS 釋出了一個新的版本，1.7.22。

版本更新：
add "version" element with SSL/TLS protocol version to tls::status

已經可以 在網站找到下載的檔案了。

Remove .*history* file

 最近我在試著使用 zsh 作為平常使用的 shell（還在測試中），所以試寫了一個會移除 .*history* 檔案的 zsh shell script：

#!/usr/bin/env zsh

pushd $(pwd)
cd $HOME
for file in $(ls .*history*); do
    rm $file && touch $file
done
popd

那麼如果用 Tcl 寫呢？程式應該會是這個樣子：

#!/usr/bin/env tclsh

set currdir [pwd]
cd $::env(HOME)
set files [glob -nocomplain -type f .*history*]
foreach filename $files {
    file delete -force $filename
    if {[file exists $filename]==0} {
        close [open $filename a]
    }
}
cd $currdir

Pandigital Squares

A pandigital number, like 4730825961, is a ten-digit number in which each digit from zero to nine appears exactly once. A square number, like 25² = 625, is a number with an integral square root. Your task is to write a program that finds all of the pandigital square numbers.

下面是嘗試的結果：

#!/usr/bin/env tclsh

set digital [list "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"]

proc is_pandigital {n} {
    set length [string length $n]
    if {$length != 10 } {
        return 0
    }

    foreach mychar $::digital {
        if {[string first $mychar $n] == -1} {
            return 0
        }
    }

    return 1
}

set minvalue [expr int(floor(sqrt(1023456789)))]
set maxvalue [expr int(floor(sqrt(9876543210)))]

for {set n $minvalue} {$n <= $maxvalue} {incr n} {
    set num [expr $n * $n]
    if {[is_pandigital $num]==1} {
         puts $num
    }
}

tksvg 0.4

tksvg 釋出新的版本 v0.4。

要注意的是，如果是使用 source code 自己編譯，需要更新 Makefile.in 才能夠正確安裝，下面就是 github 上的修改方式：

INSTALL        = @INSTALL@
-INSTALL_FLAGS   = @INSTALL_FLAGS@
-INSTALL_PROGRAM    = @INSTALL_PROGRAM@ $(INSTALL_FLAGS)
-INSTALL_LIBRARY    = @INSTALL_PROGRAM@ $(INSTALL_FLAGS)
+INSTALL_PROGRAM    = @INSTALL_PROGRAM@
+INSTALL_LIBRARY    = @INSTALL_PROGRAM@
INSTALL_DATA    = @INSTALL_DATA@
INSTALL_SCRIPT    = @INSTALL_SCRIPT@

孫子問題

在《孫子算經》裡（共三卷，據推測約成書於西元400年左右）， 下卷的第26題，就是鼎鼎有名的「孫子問題」：
今有物不知其數，三三數之剩二，五五數之剩三，七七數之剩二，問物幾何？

下面是使用迴圈的解法：

#!/usr/bin/env tclsh

proc find {n} {
    set i 0
    set a 0

    if {$n <= 0} {
        return 0;
    }

    while {$i < $n} {
         incr a
         if {[expr ($a%3)==2 && ($a%5)==3 && ($a%7)==2]==1} {
            incr i
         }
    }

    return $a
}

for {set num 1} {$num <= 10} {incr num} {
    puts "The $num answer is [find $num]."
}