2021-10-14

tcl-lmdb v0.4.2

 

檔案放置網頁

tcl-lmdb - Tcl interface to the Lightning Memory-Mapped Database

About

This is the Lightning Memory-Mapped Database (LMDB) extension for Tcl using the Tcl Extension Architecture (TEA).

LMDB is a Btree-based database management library with an API similar to BerkeleyDB. The library is thread-aware and supports concurrent read/write access from multiple processes and threads. The DB structure is multi-versioned, and data pages use a copy-on-write strategy, which also provides resistance to corruption and eliminates the need for any recovery procedures. The database is exposed in a memory map, requiring no page cache layer of its own. This extension provides an easy to use interface for accessing LMDB database files from Tcl.

Main Change

  1. Update LMDB source code.
  2. generic/tclmdb.c: Improve code to create list


這一樣也是一個 checkpoint 版本,只是建立 tag 追蹤從上一個版本以來的變化。tcl-lmdb 有一個小變動,更改了幾個 Tcl_NewListObj 的部份,設定 List 的數目,其它的沒有變動。

tcl-opencv v0.11

tcl-opencv

 

第一次 tag 的時候發現 ::cv::readOpticalFlow and ::cv::writeOpticalFlow 可以在 OpenCV 3.x  使用,但是需要 contrib module optflow(OpenCV 4.0 才移進 video module),所以沒有編譯 optflow module 的 3.x 版會編譯失敗。可是這是別人提供的 patch,我似乎最好不要直接 mark 掉,所以我移掉 0.11 的 tag,更新文件提醒有這件事以後,才又再 re-tag 一次。

因為這個問題,我在 OpenSUSE build service 上的 OpenSUSE LEAP 15.2 需要將  science/openSUSE_Leap_15.2 repository 放在第一位(這樣就會使用 OpenCV 4.5.x,而不是 3.3.x)才行,所以我也更新了 RPM spec,直接設定 OpenCV 版本 >= 4.5。

如果不是自己編譯,那麼 Linux distribution 的套件怎麼選擇 contrib module  是個問題,很明顯的 Linux distribution 間會有不同的選法,這對於我來說是個大問題(簡單的說就是 Debian/Ubuntu 可以編譯過的,OpenSUSE 不一定可以,反之亦然)。最簡單的做法就是進入 main module 才考慮加入套件的 command。

2021-10-04

PLplot, Tcl and openSUSE

我不知道在其它平台的情況怎麼樣,但是有趣的地方在於,如果我自己從 source code build 以後安裝,問題反而小一點。

首先是使用 zypper 安裝:

sudo zypper in plplot-common plplot-tcltk-devel plplot-driver-cairo plplot-driver-svg

從安裝檔案可以發現,pkgIndex.tcl 在 /usr/share/plplot5.15.0 (ps. 版本號要看安裝的版本而定),所以要讓 Tcl shell 可以正確找到的話,需要在 .tclshrc 或者是執行 tclsh 後加入下面的命令:

lappend auto_path /usr/share/plplot5.15.0

可能是因為設定的關係,pkgIndex.tcl 的目錄搜尋設定是錯的,下面是修正的設定:

    if {![string compare -length $bLen $buildDir $pkgIndexDir]} then {
        set searchdirs [list "/home/abuild/rpmbuild/BUILD/plplot-5.15.0/build/bindings/tcl"]
    } else {
        set searchdirs [list "/usr/lib64"]
    }
    if {![string compare -length $bLen $buildDir $pkgIndexDir]} then {
        set searchdirs [list "/home/abuild/rpmbuild/BUILD/plplot-5.15.0/build/drivers"]
    } else {
        set searchdirs [list "/usr/lib64/plplot5.15.0/drivers"]
    }
    if {![string compare -length $bLen $buildDir $pkgIndexDir]} then {
        set searchdirs [list "/home/abuild/rpmbuild/BUILD/plplot-5.15.0/build/drivers"]
    } else {
        set searchdirs [list "/usr/lib64/plplot5.15.0/drivers"]
    }

 

如果使用 tclsh ,還需要:

package require Pltcl

 

但是設定完上列的項目,在 pltcl 執行 plinit 初始化仍然會有下面的錯誤訊息:

plInitDispatchTable: Could not open drivers directory, aborting operation

或者是 tclsh 沒有選擇列表的情況下有下列的訊息:

Enter device number or keyword:

這表示 PLplot 找不到 driver 的位置(但是其實你已經安裝了)。 一個解法是設定 PLPLOT_DRV_DIR,例如下面的設定:

export PLPLOT_DRV_DIR=/usr/lib64/plplot5.15.0/drivers

2021-09-24

OpenCV ANN_MLP

下面是用來測試 tcl-opencv 新加入的 ANN_MLP command,寫了一個簡單的測試程式來測試:

package require opencv

proc showImage {image columns name} {
    set bigImage [cv::Mat::Mat 0 0 $::cv::CV_32F]

    for {set i 0} {$i < [$image rows]} {incr i} {
        set row [$image rowRange $i [expr $i + 1]]
        set rs  [$row reshape 0 $columns]
        $bigImage push_back $rs

        $row close
        $rs close
    }

    set bigImageT [$bigImage transpose]
    ::cv::imshow $name $bigImageT

    $bigImageT close
    $bigImage close
}

#
# Download file from:
# https://github.com/opencv/opencv/tree/master/samples/data/data01.xml
#
set filename "data01.xml"

set f [::cv::FileStorage]
$f open $filename $::cv::FileStorage::READ
set dataMat [$f readMat datamat]
set labelsMat [$f readMat labelsmat]
$f close

set data [$dataMat convert $::cv::CV_32F]
set labels [$labelsMat convert $::cv::CV_32F]
puts "Loading training data... read [$data rows] rows of data"

$dataMat close
$labelsMat close

set data_train [cv::Mat::Mat 0 0 $::cv::CV_32F]
set data_test  [cv::Mat::Mat 0 0 $::cv::CV_32F]
set labels_train  [cv::Mat::Mat 0 0 $::cv::CV_32F]
set labels_test   [cv::Mat::Mat 0 0 $::cv::CV_32F]

for {set i 0} {$i < [$data rows]} {incr i} {
    if {[expr $i%2]==0} {
         $data_train push_back [$data rowRange $i [expr $i + 1]]
         $labels_train push_back [$labels rowRange $i [expr $i + 1]]
    } else {
         $data_test push_back [$data rowRange $i [expr $i + 1]]
         $labels_test push_back [$labels rowRange $i [expr $i + 1]]
    }
}

$data close
$labels close

# MLP does not support categorical variables by explicitly.
# Update our labels
set res_train [::cv::Mat::zeros [$labels_train rows] 2 $::cv::CV_32F]
for {set i 0} {$i < [$labels_train rows]} {incr i} {
    set value [expr int([$labels_train at [list $i 0] 0])]
    $res_train at [list $i $value] 0 1
}

set res_test [::cv::Mat::zeros [$labels_test rows] 2 $::cv::CV_32F]
for {set i 0} {$i < [$labels_test rows]} {incr i} {
    set value [expr int([$labels_test at [list $i 0] 0])]
    $res_test at [list $i $value] 0 1
}

showImage $data_train 28 "train data"
showImage $data_test 28 "test data"
cv::waitKey 0

set term [::cv::TermCriteria [expr $::cv::EPS | $::cv::COUNT] 500 0.0001]

set layers [::cv::Mat::Mat 1 3 $::cv::CV_32S]
$layers at [list 0 0] 0 [$data_train cols]
$layers at [list 0 1] 0 10
$layers at [list 0 2] 0 [$res_train cols]

set mlp [::cv::ml::ANN_MLP]
$mlp setLayerSizes $layers
$mlp setActivationFunction $::cv::ml::MLP_SIGMOID_SYM 0 0
$mlp setTrainMethod $::cv::ml::MLP_BACKPROP 0.0001 0
$mlp setTermCriteria $term

puts "Training..."
set trainData [::cv::ml::TrainData $data_train $::cv::ml::ROW_SAMPLE $res_train]
$mlp train $trainData 
$trainData close
$data_train close
$labels_train close
$res_train close
$term close
$layers close

$mlp save "mlp.xml"
$mlp close

set mlp [::cv::ml::ANN_MLP::load "mlp.xml"]

#
# MLP will give us a vector of "probabilities" at the prediction stage
#
puts "Predicting..."
set response [$mlp predict $data_test]
set res [lindex $response 1]

puts ""
puts "Labels test: "
set labels_test2 [$labels_test convert $::cv::CV_32S]
for {set i 0} {$i < [$labels_test2 rows]} {incr i} {
    puts -nonewline "[$labels_test2 at [list $i 0] 0] "
}

puts ""
set correct 0
for {set i 0} {$i < [$labels_test2 rows]} {incr i} {
    set row [$res rowRange $i [expr $i + 1]]
    set rowt [$row transpose]
    set rvalue [cv::minMaxIdx $rowt]
    set max [lindex $rvalue 1]
    set maxidx [lindex $max 1]
  
    $row close
    $rowt close
    puts -nonewline "$maxidx "
    if {$maxidx==[$labels_test2 at [list $i 0] 0]} {
        incr correct
    }
}
puts ""
puts "accuracy: [expr 100 * $correct/[$labels_test rows]]"

$res close
$data_test close
$labels_test close
$labels_test2 close
$res_test close

OpenCV RTrees

下面是用來測試 tcl-opencv 新加入的 RTrees command,寫了一個簡單的測試程式來測試:

package require opencv

proc showImage {image columns name} {
    set bigImage [cv::Mat::Mat 0 0 $::cv::CV_32F]

    for {set i 0} {$i < [$image rows]} {incr i} {
        set row [$image rowRange $i [expr $i + 1]]
        set rs  [$row reshape 0 $columns]
        $bigImage push_back $rs

        $row close
        $rs close
    }

    set bigImageT [$bigImage transpose]
    ::cv::imshow $name $bigImageT

    $bigImageT close
    $bigImage close
}

#
# Download file from:
# https://github.com/opencv/opencv/tree/master/samples/data/data01.xml
#
set filename "data01.xml"

set f [::cv::FileStorage]
$f open $filename $::cv::FileStorage::READ
set dataMat [$f readMat datamat]
set labelsMat [$f readMat labelsmat]
$f close

set data [$dataMat convert $::cv::CV_32F]
set labels [$labelsMat convert $::cv::CV_32S]
puts "Loading training data... read [$data rows] rows of data"

$dataMat close
$labelsMat close

set data_train [cv::Mat::Mat 0 0 $::cv::CV_32F]
set data_test  [cv::Mat::Mat 0 0 $::cv::CV_32F]
set labels_train  [cv::Mat::Mat 0 0 $::cv::CV_32S]
set labels_test   [cv::Mat::Mat 0 0 $::cv::CV_32S]

for {set i 0} {$i < [$data rows]} {incr i} {
    if {[expr $i%2]==0} {
         $data_train push_back [$data rowRange $i [expr $i + 1]]
         $labels_train push_back [$labels rowRange $i [expr $i + 1]]
    } else {
         $data_test push_back [$data rowRange $i [expr $i + 1]]
         $labels_test push_back [$labels rowRange $i [expr $i + 1]]
    }
}

$data close
$labels close

showImage $data_train 28 "train data"
showImage $data_test 28 "test data"
cv::waitKey 0

set term [::cv::TermCriteria [expr $::cv::EPS | $::cv::COUNT] 5000 0.00000001]

set rt [::cv::ml::RTrees]
$rt setMaxCategories 2
# It is necessary to setup max
$rt setMaxDepth 20
$rt setMinSampleCount 1
$rt setTruncatePrunedTree 1
$rt setUse1SERule 1
$rt setUseSurrogates 0
$rt setCVFolds 1
$rt setCalculateVarImportance 1
$rt setTermCriteria $term

puts "Training..."
set trainData [::cv::ml::TrainData $data_train $::cv::ml::ROW_SAMPLE $labels_train]
$rt train $trainData
$trainData close
$data_train close
$labels_train close
$term close

$rt save "rt.xml"
$rt close

set rt [::cv::ml::RTrees::load "rt.xml"]

puts "Predicting..."
set response [$rt predict $data_test]
set res [lindex $response 1]

puts ""
puts "Labels test: "
for {set i 0} {$i < [$labels_test rows]} {incr i} {
    puts -nonewline "[$labels_test at [list $i 0] 0] "
}
puts ""
puts "Response: "
set res2 [$res convert $::cv::CV_32S]
for {set i 0} {$i < [$res2 rows]} {incr i} {
    puts -nonewline "[$res2 at [list $i 0] 0] "
}

puts ""
set correct 0
for {set i 0} {$i < [$labels_test rows]} {incr i} {
    if {[$res2 at [list $i 0] 0]==[$labels_test at [list $i 0] 0]} {
        incr correct
    }
}
puts "accuracy: [expr 100 * $correct/[$labels_test rows]]"

$res close
$res2 close
$data_test close
$labels_test close

2021-09-23

OpenCV Boost

下面是用來測試 tcl-opencv 新加入的 Boost command,寫了一個簡單的測試程式來測試:

package require opencv

proc showImage {image columns name} {
    set bigImage [cv::Mat::Mat 0 0 $::cv::CV_32F]

    for {set i 0} {$i < [$image rows]} {incr i} {
        set row [$image rowRange $i [expr $i + 1]]
        set rs  [$row reshape 0 $columns]
        $bigImage push_back $rs

        $row close
        $rs close
    }

    set bigImageT [$bigImage transpose]
    ::cv::imshow $name $bigImageT

    $bigImageT close
    $bigImage close
}

#
# Download file from:
# https://github.com/opencv/opencv/tree/master/samples/data/data01.xml
#
set filename "data01.xml"

set f [::cv::FileStorage]
$f open $filename $::cv::FileStorage::READ
set dataMat [$f readMat datamat]
set labelsMat [$f readMat labelsmat]
$f close

set data [$dataMat convert $::cv::CV_32F]
set labels [$labelsMat convert $::cv::CV_32S]
puts "Loading training data... read [$data rows] rows of data"

$dataMat close
$labelsMat close

set data_train [cv::Mat::Mat 0 0 $::cv::CV_32F]
set data_test  [cv::Mat::Mat 0 0 $::cv::CV_32F]
set labels_train  [cv::Mat::Mat 0 0 $::cv::CV_32S]
set labels_test   [cv::Mat::Mat 0 0 $::cv::CV_32S]

for {set i 0} {$i < [$data rows]} {incr i} {
    if {[expr $i%2]==0} {
         $data_train push_back [$data rowRange $i [expr $i + 1]]
         $labels_train push_back [$labels rowRange $i [expr $i + 1]]
    } else {
         $data_test push_back [$data rowRange $i [expr $i + 1]]
         $labels_test push_back [$labels rowRange $i [expr $i + 1]]
    }
}

$data close
$labels close

showImage $data_train 28 "train data"
showImage $data_test 28 "test data"
cv::waitKey 0

set boost [::cv::ml::Boost]
# It is necessary to setup max
$boost setMaxDepth 10
$boost setUseSurrogates 0
$boost setBoostType $::cv::ml::BOOST_REAL
$boost setWeakCount 100
$boost setWeightTrimRate 0.95

puts "Training..."
set trainData [::cv::ml::TrainData $data_train $::cv::ml::ROW_SAMPLE $labels_train]
$boost train $trainData
$trainData close
$data_train close
$labels_train close

$boost save "boost.xml"
$boost close

set boost [::cv::ml::Boost::load "boost.xml"]

puts "Predicting..."
set response [$boost predict $data_test]
set res [lindex $response 1]

$boost close

puts ""
puts "Labels test: "
for {set i 0} {$i < [$labels_test rows]} {incr i} {
    puts -nonewline "[$labels_test at [list $i 0] 0] "
}
puts ""
puts "Response: "
set res2 [$res convert $::cv::CV_32S]
for {set i 0} {$i < [$res2 rows]} {incr i} {
    puts -nonewline "[$res2 at [list $i 0] 0] "
}

puts ""
set correct 0
for {set i 0} {$i < [$labels_test rows]} {incr i} {
    if {[$res2 at [list $i 0] 0]==[$labels_test at [list $i 0] 0]} {
        incr correct
    }
}
puts "accuracy: [expr 100 * $correct/[$labels_test rows]]"

$res close
$res2 close
$data_test close
$labels_test close

OpenCV DTrees

下面是用來測試 tcl-opencv 新加入的 DTrees command,寫了一個簡單的測試程式來測試:

package require opencv

proc showImage {image columns name} {
    set bigImage [cv::Mat::Mat 0 0 $::cv::CV_32F]

    for {set i 0} {$i < [$image rows]} {incr i} {
        set row [$image rowRange $i [expr $i + 1]]
        set rs  [$row reshape 0 $columns]
        $bigImage push_back $rs

        $row close
        $rs close
    }

    set bigImageT [$bigImage transpose]
    ::cv::imshow $name $bigImageT

    $bigImageT close
    $bigImage close
}

#
# Download file from:
# https://github.com/opencv/opencv/tree/master/samples/data/data01.xml
#
set filename "data01.xml"

set f [::cv::FileStorage]
$f open $filename $::cv::FileStorage::READ
set dataMat [$f readMat datamat]
set labelsMat [$f readMat labelsmat]
$f close

set data [$dataMat convert $::cv::CV_32F]
set labels [$labelsMat convert $::cv::CV_32S]
puts "Loading training data... read [$data rows] rows of data"

$dataMat close
$labelsMat close

set data_train [cv::Mat::Mat 0 0 $::cv::CV_32F]
set data_test  [cv::Mat::Mat 0 0 $::cv::CV_32F]
set labels_train  [cv::Mat::Mat 0 0 $::cv::CV_32S]
set labels_test   [cv::Mat::Mat 0 0 $::cv::CV_32S]

for {set i 0} {$i < [$data rows]} {incr i} {
    if {[expr $i%2]==0} {
         $data_train push_back [$data rowRange $i [expr $i + 1]]
         $labels_train push_back [$labels rowRange $i [expr $i + 1]]
    } else {
         $data_test push_back [$data rowRange $i [expr $i + 1]]
         $labels_test push_back [$labels rowRange $i [expr $i + 1]]
    }
}

$data close
$labels close

showImage $data_train 28 "train data"
showImage $data_test 28 "test data"
cv::waitKey 0

set dt [::cv::ml::DTrees]
$dt setMaxCategories 2
# It is necessary to setup max
$dt setMaxDepth 20
$dt setMinSampleCount 1
$dt setTruncatePrunedTree 1
$dt setUse1SERule 1
$dt setUseSurrogates 0
$dt setCVFolds 1

puts "Training..."
set trainData [::cv::ml::TrainData $data_train $::cv::ml::ROW_SAMPLE $labels_train]
$dt train $trainData
$trainData close
$data_train close
$labels_train close

$dt save "dt.xml"

puts "Predicting..."
set response [$dt predict $data_test]
set res [lindex $response 1]

$dt close

puts ""
puts "Labels test: "
for {set i 0} {$i < [$labels_test rows]} {incr i} {
    puts -nonewline "[$labels_test at [list $i 0] 0] "
}
puts ""
puts "Response: "
set res2 [$res convert $::cv::CV_32S]
for {set i 0} {$i < [$res2 rows]} {incr i} {
    puts -nonewline "[$res2 at [list $i 0] 0] "
}

puts ""
set correct 0
for {set i 0} {$i < [$labels_test rows]} {incr i} {
    if {[$res2 at [list $i 0] 0]==[$labels_test at [list $i 0] 0]} {
        incr correct
    }
}
puts "accuracy: [expr 100 * $correct/[$labels_test rows]]"

$res close
$res2 close
$data_test close
$labels_test close

2021-09-22

OpenCV SVMSGD

下面是用來測試 tcl-opencv 新加入的  SVMSGD command,寫了一個簡單的測試程式來測試:

package require opencv

proc showImage {image columns name} {
    set bigImage [cv::Mat::Mat 0 0 $::cv::CV_32F]

    for {set i 0} {$i < [$image rows]} {incr i} {
        set row [$image rowRange $i [expr $i + 1]]
        set rs  [$row reshape 0 $columns]
        $bigImage push_back $rs

        $row close
        $rs close
    }
    
    set bigImageT [$bigImage transpose]
    ::cv::imshow $name $bigImageT

    $bigImageT close
    $bigImage close
}

#
# Download file from:
# https://github.com/opencv/opencv/tree/master/samples/data/data01.xml
#

set filename "data01.xml"

set f [::cv::FileStorage]
$f open $filename $::cv::FileStorage::READ
set dataMat [$f readMat datamat]
set labelsMat [$f readMat labelsmat]
$f close

# Notice: SVMSGD label type is CV_32F
set data [$dataMat convert $::cv::CV_32F]
set labels [$labelsMat convert $::cv::CV_32F]
puts "Loading training data... read [$data rows] rows of data"

$dataMat close
$labelsMat close

set data_train [cv::Mat::Mat 0 0 $::cv::CV_32F]
set data_test  [cv::Mat::Mat 0 0 $::cv::CV_32F]
set labels_train  [cv::Mat::Mat 0 0 $::cv::CV_32F]
set labels_test   [cv::Mat::Mat 0 0 $::cv::CV_32F]

for {set i 0} {$i < [$data rows]} {incr i} {
    if {[expr $i%2]==0} {
         $data_train push_back [$data rowRange $i [expr $i + 1]]
         $labels_train push_back [$labels rowRange $i [expr $i + 1]]
    } else {
         $data_test push_back [$data rowRange $i [expr $i + 1]]
         $labels_test push_back [$labels rowRange $i [expr $i + 1]]
    }
}

$data close
$labels close

# SVMSGD labels is -1 and 1, so update our labels
for {set i 0} {$i < [$labels_train rows]} {incr i} {
    if {[$labels_train at [list $i 0] 0]==0} {
        $labels_train at [list $i 0] 0 -1.0
    }
    puts [$labels_train at [list $i 0] 0]
}

for {set i 0} {$i < [$labels_test rows]} {incr i} {
    if {[$labels_test at [list $i 0] 0]==0} {
        $labels_test at [list $i 0] 0 -1.0
    }
}

showImage $data_train 28 "train data"
showImage $data_test 28 "test data"
cv::waitKey 0

set term [::cv::TermCriteria [expr $::cv::EPS | $::cv::COUNT] 1000 0.001]

set svmsgd [::cv::ml::SVMSGD]
$svmsgd setSvmsgdType $::cv::ml::SVMSGD_ASGD
$svmsgd setMarginType $::cv::ml::SVMSGD_HARD_MARGIN
$svmsgd setMarginRegularization 0.00001
$svmsgd setInitialStepSize 0.05
$svmsgd setStepDecreasingPower 0.75
$svmsgd setTermCriteria $term

puts "Training..."
set trainData [::cv::ml::TrainData $data_train $::cv::ml::ROW_SAMPLE $labels_train]
$svmsgd train $trainData
$trainData close
$data_train close
$labels_train close
$term close

$svmsgd save "svmsgd.xml"

puts "Predicting..."
set response [$svmsgd predict $data_test]
set res [lindex $response 1]

$svmsgd close

puts ""
puts "Labels test: "
for {set i 0} {$i < [$labels_test rows]} {incr i} {
    puts -nonewline "[$labels_test at [list $i 0] 0] "
}
puts ""
puts "Response: [$res size]"
for {set i 0} {$i < [$res rows]} {incr i} {
    puts -nonewline "[$res at [list $i 0] 0] "
}

puts ""
set correct 0
for {set i 0} {$i < [$labels_test rows]} {incr i} {
    if {[$res at [list $i 0] 0]==[$labels_test at [list $i 0] 0]} {
        incr correct
    }
}
puts "accuracy: [expr 100 * $correct/[$labels_test rows]]"

$res close
$data_test close
$labels_test close

OpenCV LogisticRegression

OpenCV 也在 ML module 提供了 Logistic Regression。

下面是用來測試 tcl-opencv 新加入的  LogisticRegression command,寫了一個簡單的測試程式來測試:

package require opencv

proc showImage {image columns name} {
    set bigImage [cv::Mat::Mat 0 0 $::cv::CV_32F]

    for {set i 0} {$i < [$image rows]} {incr i} {
        set row [$image rowRange $i [expr $i + 1]]
        set rs  [$row reshape 0 $columns]
        $bigImage push_back $rs

        $row close
        $rs close
    }
    
    set bigImageT [$bigImage transpose]
    ::cv::imshow $name $bigImageT

    $bigImageT close
    $bigImage close
}

#
# Download file from:
# https://github.com/opencv/opencv/tree/master/samples/data/data01.xml
#
set filename "data01.xml"

set f [::cv::FileStorage]
$f open $filename $::cv::FileStorage::READ
set dataMat [$f readMat datamat]
set labelsMat [$f readMat labelsmat]
$f close

# Notice: LogisticRegression label type is CV_32F
set data [$dataMat convert $::cv::CV_32F]
set labels [$labelsMat convert $::cv::CV_32F]
puts "Loading training data... read [$data rows] rows of data"

$dataMat close
$labelsMat close

set data_train [cv::Mat::Mat 0 0 $::cv::CV_32F]
set data_test  [cv::Mat::Mat 0 0 $::cv::CV_32F]
set labels_train  [cv::Mat::Mat 0 0 $::cv::CV_32F]
set labels_test   [cv::Mat::Mat 0 0 $::cv::CV_32F]

for {set i 0} {$i < [$data rows]} {incr i} {
    if {[expr $i%2]==0} {
         $data_train push_back [$data rowRange $i [expr $i + 1]]
         $labels_train push_back [$labels rowRange $i [expr $i + 1]]
    } else {
         $data_test push_back [$data rowRange $i [expr $i + 1]]
         $labels_test push_back [$labels rowRange $i [expr $i + 1]]
    }
}

$data close
$labels close

showImage $data_train 28 "train data"
showImage $data_test 28 "test data"
cv::waitKey 0

set logi [::cv::ml::LogisticRegression]
$logi setLearningRate 0.001
$logi setIterations 10
$logi setRegularization $::cv::ml::LOGISTIC_REG_L2
$logi setTrainMethod $::cv::ml::LOGISTIC_BATCH
$logi setMiniBatchSize 1

puts "Training..."
set trainData [::cv::ml::TrainData $data_train $::cv::ml::ROW_SAMPLE $labels_train]
$logi train $trainData
$trainData close
$data_train close
$labels_train close

$logi save "logi.xml"

puts "Predicting..."
set response [$logi predict $data_test]
set res [lindex $response 1]

$logi close

puts ""
puts "Labels test: "
set labels_test2 [$labels_test convert $::cv::CV_32S]
for {set i 0} {$i < [$labels_test2 rows]} {incr i} {
    puts -nonewline "[$labels_test2 at [list $i 0] 0] "
}
puts ""
puts "Response: "
for {set i 0} {$i < [$res rows]} {incr i} {
    puts -nonewline "[$res at [list $i 0] 0] "
}

puts ""
set correct 0
for {set i 0} {$i < [$labels_test2 rows]} {incr i} {
    if {[$res at [list $i 0] 0]==[$labels_test2 at [list $i 0] 0]} {
        incr correct
    }
}
puts "accuracy: [expr 100 * $correct/[$labels_test2 rows]]"

$res close
$data_test close
$labels_test close
$labels_test2 close

2021-09-18

OpenCV kmeans

k-means clustering (維基百科)


我的問題是要怎麼確認我新加到 tcl-opencv 的 kmeans command 是不是有加正確,所以寫了一個簡單的測試程式來測試:

package require opencv

set k [expr 1 + int(5 * rand())]
set samplecount [expr 500 + int(500 * rand())]

set colors [list [list 255 0 0 0] [list 0 0 255 0] \
                 [list 0 255 0 0] [list 0 165 255 0] \
                 [list 255 165 0 0] [list 255 255 255 0]]

set image [::cv::Mat::Mat 512 512 $::cv::CV_8UC3]
set term [::cv::TermCriteria [expr $::cv::EPS | $::cv::COUNT] 10 1]

while {1} {
    $image setTo [list 0 0 0 0]
    set points [cv::Mat::Mat $samplecount 1 $::cv::CV_32FC2]
    cv::randu $points [list 0 0 0 0] [list 512 512 0 0]

    set result [cv::kmeans $points $k None $term 3 $::cv::KMEANS_PP_CENTERS]
    puts "K = $k, compactness: [lindex $result 0]"

    set labels [lindex $result 1]
    for {set i 0} {$i < [$points rows]} {incr i} {
        set x [expr int([$points at [list $i 0] 0])]
        set y [expr int([$points at [list $i 0] 1])]

        set color [lindex $colors [expr int([$labels at [list $i 0] 0])]]
        cv::circle $image $x $y 2 $color 1 $cv::LINE_AA 0
    }

    set output [lindex $result 2]
    for {set i 0} {$i < [$output rows]} {incr i} {
        set x [expr int([$output at [list $i 0] 0])]
        set y [expr int([$output at [list $i 1] 0])]
        set color [lindex $colors $i]
        cv::circle $image $x $y 40 $color 1 $cv::LINE_AA 0
    }

    ::cv::imshow "Result" $image

    $labels close
    $points close
    
    set key [::cv::waitKey 0]
    if {$key==[scan "q" %c] || $key == 27} {
        break
    } else {
        set k [expr 2 + int(3 * rand())]
        set samplecount [expr 200 + int(1000 * rand())]
    }
}

$image close
$term close

2021-09-14

Tclunqlite v0.3.7

 Tclunqlite

這是一個小更新的版本,將 UnQLite 的 source code 更新到最新的版本,所以將版本升為 v0.3.7。

2021-09-01

tcl-opencv: Tcl extension for OpenCV library

tcl-opencv

 

在使用 C++ 寫 OpenCV 小程式的時候,我突然間對怎麼實作一個  Tcl extension for OpenCV library 有了想法,所以花時間寫出來一個驗證想法。現在我把成品放到 Github 上。

2021-08-05

tcl-imagebytes: To and from byte array and Tk photo image

tcl-imagebytes

 

在寫 tcl-stbimage 時,腦中浮現了一個想法。所以我可以將 tcl-stbimage 拿到的 byte array 給 Tk 的 photo image 使用嗎?搜尋了一下,是有 C API 可以做這件事的,所以寫了這個套件來測試這個想法。

2021-08-03

tcl-stbimage: Tcl extension for stb_image

tcl-stbimage

 

stb_image 支援常用的圖檔格式,不過我會寫這個是因為如果要測試 OpenCL image object,就需要載入圖檔的資料才行,所以寫了這個 extension 用來載入圖檔的資料。

2021-08-01

tcl-opencl: Tcl extension for OpenCL

tcl-opencl


只是重新學習 OpenCL 的一些概念,再看一次 OpenCL API 的使用,所以測試的時候使用 ocl-icdPoCL 的組合來測試,然後把我所理解的部份試著轉換為 Tcl extension 寫出來。

OpenCL 這幾年的發展不太順利,雖然去年推出了 OpenCL 3.0,但是最開始的推動者 Apple 在之前就已經從 MAC OS X 移除了內建的 OpenCL。雖然如此,但是 PoCL 這個 OpenCL 自由軟體的實作品也仍然展現了  OpenCL 的優點,就是這是一個開放的標準。

2021-07-25

tcl-gremlin

tcl-gremlin: Gremlin Server driver for Tcl


上一篇文章的延續,整合成為一個套件。只有簡單的測試過,目前已經可以使用 Websocket 連線 Gremlin server,送出 query string 然後取得結果。

2021-07-20

Websocket

Apache TinkerPop 的 Gremlin Server 使用 Websocket 或者是 HTTP 協定與 client 溝通。 如果是 Websocket,使用的指令如下:

bin/gremlin-server.sh conf/gremlin-server-classic.yaml

而使用者可以透過 Websocket 傳送 script string 給 Gremlin Server 執行,並且取得執行的結果。

Tcllib 提供了 websocket server 與 client 的實作,這裡測試 client 的部份。 下面就是使用 Tcl 寫的測試程式(改寫自 Tcllib 文件的範例):

package require websocket
package require uuid
::websocket::loglevel debug

proc handler { sock type msg } {
    switch -glob -nocase -- $type {
        co* {
            puts "Connected on $sock"
        }
        te* {
            puts "RECEIVED: $msg"
        }
        cl* -
        dis* {
        }
    }    
}

proc test { sock } {
    puts "[::websocket::conninfo $sock type] from \
          [::websocket::conninfo $sock sockname] to \
          [::websocket::conninfo $sock peername]"

    set id [::uuid::uuid generate]
    set msg "{\"requestId\":\"$id\",
              \"op\":\"eval\",
              \"processor\":\"\",
              \"args\":{\"gremlin\":\"g.V(x).out()\",
                        \"bindings\":{\"x\":1},
                        \"language\":\"gremlin-groovy\"}}"

    ::websocket::send $sock text $msg
}

set sock [::websocket::open ws://localhost:8182/gremlin handler]
after 400 test $sock
vwait forever

Gremlin server 除了支援 TEXT type 的訊息,也支援 BINARY type 的訊息,下面是相關的測試:

package require websocket
package require uuid
::websocket::loglevel debug

proc handler { sock type msg } {
    switch -glob -nocase -- $type {
        co* {
            puts "Connected on $sock"
        }
        bi* {
            puts "RECEIVED: $msg"
            set ::received 1
        }
        cl* -
        dis* {
        }
    }    
}

proc test { sock } {
    puts "[::websocket::conninfo $sock type] from \
          [::websocket::conninfo $sock sockname] to \
          [::websocket::conninfo $sock peername]"

    set id [::uuid::uuid generate]
    set msg "{\"requestId\":\"$id\",
              \"op\":\"eval\",
              \"processor\":\"\",
              \"args\":{\"gremlin\":\"g.V(x).out()\",
                        \"bindings\":{\"x\":1},
                        \"language\":\"gremlin-groovy\"}}"
    set mimetype "application/json"
    set length [binary format c [string length $mimetype]]
    set finalmsg [string cat $length $mimetype $msg]

    ::websocket::send $sock binary $finalmsg
}

set sock [::websocket::open ws://localhost:8182/gremlin handler]
after 400 test $sock
set received 0
vwait received
after 100
::websocket::close $sock 1000

2021-07-16

Invert Bit

You are given integers 0 <= $m <= 255 and 1 <= $n <= 8.

Write a script to invert $n bit from the end of the binary representation of $m and print the decimal representation of the new binary number.

#!/usr/bin/env tclsh

if {$argc >= 2} {
    set m [lindex $argv 0]
    set n [lindex $argv 1]
} else {
    puts "Please input two numbers, m and n."
    exit    
}

if {$m < 0 || $m > 255} {
    puts "Number requires 0 <= M <= 255"
    exit
}

if {$n < 1 || $n > 8} {
    puts "Number requires 1 <= N <= 8"
    exit
}

set bnumber [format %08b $m]
set string1 ""
set string3 ""
set string2 [string index $bnumber [expr 8 - $n]]
if {$n < 8} {
    set string1 [string range $bnumber 0 [expr 8 - $n - 1]]
}
if {$n > 1} {
    set string3 [string range $bnumber [expr 8 - $n + 1] end]
}

if {[string compare $string2 "1"]==0} {
    set result [string cat $string1 "0" $string3]
} else {
    set result [string cat $string1 "1" $string3]
}

puts [format "%d" 0b$result]

2021-07-05

Swap Odd/Even bits

You are given a positive integer $N less than or equal to 255.

Write a script to swap the odd positioned bit with even positioned bit and print the decimal equivalent of the new binary representation.

#!/usr/bin/env tclsh
if {$argc >= 1} {
    set number [lindex $argv 0]
} elseif {$argc == 0} {
    puts "Please input a number"
    exit    
}

if {$number <=0 || $number > 255} {
    puts "Number requires 0 < N <= 255"
    exit
}

set bnumber [format %08b $number]
set length [string length $bnumber]
set answer ""
for {set i 0} {$i < $length} {incr i 2} {
    set n1 [string index $bnumber $i]
    set n2 [string index $bnumber [expr $i + 1]]
    set answer [string cat $answer $n2 $n1]
}
puts [format "%d" 0b$answer]

Clock Angle

You are given time $T in the format hh:mm.

Write a script to find the smaller angle formed by the hands of an analog clock at a given time.

#!/usr/bin/env tclsh

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

set clockstring [split $timestring ":"]
set hour [lindex $clockstring 0]
set second [lindex $clockstring 1]

# Remove leading zero to let expr work correctly
scan $hour %d hour
scan $second %d second

if {$hour < 0 || $hour >= 12} {
    puts "Invalid hour data."
}

if {$second < 0 || $second >= 60} {
    puts "Invalid second data."
}

set secvalue [expr $second * 6]
set hourvalue [expr ($hour * 30) + ($secvalue / 12)]

if {$hourvalue > $secvalue} {
    set value1 [expr 360 - $hourvalue + $secvalue]
    set value2 [expr $hourvalue - $secvalue]
    if {$value1 > 0 && $value1 < $value2} {
        puts "$value1 degree"
    } else {
        puts "$value2 degree"
    }
} else {
    set value1 [expr 360 - $secvalue + $hourvalue]
    set value2 [expr $secvalue - $hourvalue]
    if {$value1 > 0 && $value1 < $value2} {
        puts "$value1 degree"
    } else {
        puts "$value2 degree"
    }
}

tcl-awthemes

tcl-awthemes 簡介:

awdark and awlight themes for Tk, loosely based on the adwaita themes. Scalable themes: awdark, awlight, black, winxpblue, breeze, arc, clearlooks.


我發現有些 Linux Distribution 有包這個 套件,所以寫了 tcl-awthemes-spec 用來打包成 RPM 檔案並且在 openSUSE 使用。

2021-07-04

tcl-rocksdb TLS error issue

我發現 tcl-rocksdb 在載入時會出現 TLS error: cannot allocate memory in static TLS block 的問題,經過搜尋與研究,是因為 RocksDB 使用了 jemalloc,而 jemalloc 在 5.0 之後就會有這個問題

解決的方法有幾個,一個是連結 jemalloc 時使用 static library 而非動態連結;一個是編譯 jemalloc 時加入選項 --disable-initial-exec-tls 來解決 TLS error issue,但是這樣使用者就要自己編譯 jemalloc。

另外的解決方法就是暫時在 RocksDB 關掉 jemalloc,沒有使用 jemalloc 就沒有載入問題。經過思考,因為我目前不想要在自己的 OBS repo 放一個 jemalloc,所以暫時關掉了我放在 OpenSUSE Build Service 上 RocksDB jemalloc 的選項,這樣連結到 rocksdb 的程式或者是函式庫就不會出現載入問題。

2021-06-29

Swap Nibbles

You are given a positive integer $N.

Write a script to swap the two nibbles of the binary representation of the given number and print the decimal number of the new binary representation.

To keep the task simple, we only allow integer less than or equal to 255.

#!/usr/bin/env tclsh
#
# You are given a positive integer $N.
# Write a script to swap the two nibbles of the binary representation of the 
# given number and print the decimal number of the new binary representation.
# To keep the task simple, we only allow integer less than or equal to 255.
#
if {$argc >= 1} {
    set number [lindex $argv 0]
} elseif {$argc == 0} {
    puts "Please input a number"
    exit    
}

if {$number <=0 || $number > 255} {
    puts "Number requires 0 < N <= 255"
    exit
}

set number1 [format %04b [expr $number & 0xf]]
set number2 [format %04b [expr ($number >> 4) & 0xf]]
puts [format "%d" 0b$number1$number2]

2021-06-22

Tcl / Tk 8.7a5 RELEASED

Tcl / Tk 8.7a5 RELEASED


這是 Tcl/Tk 8.7 第三個公開的 alpha 測試版,下面是更新的內容。

This release is a development release, and should only be considered for deployment use after considerable testing.

New Commands and Features
* [TIP 542,575] Support for switchable Full Unicode support
* [TIP 597] [string is unicode] and better utf-8/utf-16/cesu-8 encodings
* [TIP 588] Unicode for (X11) keysyms
* [TIP 595] Unicode-aware/case-sensitive Loadable Library handling
* [TIP 325] System tray and system notification
* [TIP 529] Add metadata dictionary property to tk photo image
* [TIP 584] Better introspection for ttk
* [TIP 481] Tcl_GetStringFromObj() with size_t length parameter
* [TIP 587] Default utf-8 for [source]
* [TIP 565] Gracefully ignore non-existent tags in canvas raise/lower
* [TIP 563] Scrollwheel on Horizontal Scrollbar Scrolls Without Shift
* [TIP 591] Rotate ttk::notebook window with mousewheel on tab
* [TIP 474] Uniform mouse wheel events
* [TIP 551] Permit underscore in numerical literals in source code
* [TIP 574] Add a 'tag delete' command to the ttk::treeview widget
* [TIP 564] Specify ttk font sizes in points on X11
* [TIP 586] C String Parsing Support for [binary scan]
* [TIP 598] Tcl_WinConvertError
* [TIP 580] Tk_GetDoublePixelsFromObj and 5 more
* [TIP 585] INDEX_TEMP_TABLE flag for Tcl_GetIndexFromObj()
* [TIP 582] Comments in Expressions
* [TIP 557] C++ support for Tcl
* 'end' argument to [$canvas insert]
* Implement 64-bit seek on Zip channels
* bind substitution %S
* Drop TCL_WINDOW_EVENTS from Tcl's [update idletasks]
* [chan truncate] for reflected channels
* tzdata updated to Olson's tzdata2021a

Deprecations/Migration aids
* [TIP 592] End support: Windows XP, Server 2003, Vista, Server 2008
* [TIP 590] Recommend lowercase Package Names
* [TIP 538] Externalize libtommath
* [TIP 543] Eliminate `TCL_INTERP_DESTROYED` flag value
* [TIP 559] Eliminate public routine `Tcl_FreeResult`
* [TIP 562] Deprecate channel types 1-4
* [TIP 578] Death to TCL_DBGX
* [TIP 569] Eliminate Comments That Serve Lint
* Restore Tcl [update] when Tk is destroyed
* Solve XKeycodeToKeysym deprecation
*** POTENTIAL INCOMPATIBILITY -- Tk 8.7 now requires X11R6 ***

Fix crashes or hangs in ...
* [string index abcd 0-0x10000000000000000]
* [set l {}; lpop l]
* tests binary-79.[12]
* [fconfigure stdout] on Windows
* Tcl_Unload()
* SVG memory overflow
* [tkwait]
* Aqua: dead keys as menu accelerator

Bug/Regression Repair
* [chan postevent] revised to be event-driven, as name implies
*** POTENTIAL INCOMPATIBILITY ***
* [string trim*] on astral characters
* deletion trace on imported ensemble
* Aqua: double click bind with changing focus
* Follow Mac OSX Key-repeat setting
* update scrollbars on treeview 

2021-06-21

Binary Palindrome

You are given a positive integer $N.

Write a script to find out if the binary representation of the given integer is Palindrome. Print 1 if it is otherwise 0.

#!/usr/bin/env tclsh

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

if {$number < 0} {
    puts "0"
} elseif {$number >= 0} {
    set result [format %b $number]
    set res [string reverse $result]
    if {[string compare $result $res]==0} {
        puts "1"
    } else {
        puts "0"
    }
}

2021-06-14

Missing Row

You are given text file with rows numbered 1-15 in random order but there is a catch one row in missing in the file.

11, Line Eleven
1, Line one
9, Line Nine
13, Line Thirteen
2, Line two
6, Line Six
8, Line Eight
10, Line Ten
7, Line Seven
4, Line Four
14, Line Fourteen
3, Line three
15, Line Fifteen
5, Line Five

Write a script to find the missing row number.

這裡使用 tclcsv 讀取檔案內容,跟著再排序以後印出結果。

package require tclcsv

proc mysortproc {x y} {
    set len1 [lindex $x 0]
    set len2 [lindex $y 0]

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

set infile [open "input.dat" r]
set filedata [tclcsv::csv_read $infile]
close $infile
set tmpList [lsort -command mysortproc $filedata]
set len [llength $tmpList]
for {set i 0} {$i < $len} {incr i} {
     set mylist [lindex $tmpList $i]
     if {[lindex $mylist 0] != [expr $i + 1]} {
         puts "Mising row number: [expr $i + 1]"
         break
     }
}

2021-06-07

Sum of Squares

You are given a number $N >= 10. Write a script to find out if the given number $N is such that sum of squares of all digits is a perfect square. Print 1 if it is otherwise 0.

#!/usr/bin/tclsh
# You are given a number $N >= 10.
# Write a script to find out if the given number $N is such 
# that sum of squares of all digits is a perfect square.
# Print 1 if it is otherwise 0.

puts -nonewline "Input: "
flush stdout
gets stdin number
if {$number < 10} {
    puts "Number requires >= 10."
    exit
}

set total 0
set mylist [split $number ""]
foreach substring $mylist {
    set result [expr $substring * $substring]
    set total [expr $total + $result]
}

set root [expr int(sqrt($total))]
set check [expr $root * $root]
if {$total==$check} {
    puts "Output: 1"
} else {
    puts "Output: 0"
}

2021-05-24

Higher Integer Set Bits

You are given a positive integer $N. Write a script to find the next higher integer having the same number of 1 bits in binary representation as $N.

#!/usr/bin/tclsh

proc nexthigher {x} {
    set next 0

    if {$x} {
        set rightOne [expr $x & -$x]
        set nextHigherOneBit [expr $x + $rightOne]
        set rightOnesPattern [expr $x ^ $nextHigherOneBit]
        set rightOnesPattern [expr $rightOnesPattern / $rightOne]
        set rightOnesPattern [expr $rightOnesPattern >> 2]
        set next [expr $nextHigherOneBit | $rightOnesPattern]
    }

    return $next
}

if {$argc >= 1} {
    set number [lindex $argv 0]
} elseif {$argc == 0} {
    exit    
}

if {$number < 0} {
    exit
}

puts "Output: [nexthigher $number]"

2021-04-26

Transpose File

You are given a text file. Write a script to transpose the contents of the given file.

Input File

name,age,sex
Mohammad,45,m
Joe,20,m
Julie,35,f
Cristina,10,f

Output:

name,Mohammad,Joe,Julie,Cristina
age,45,20,35,10
sex,m,m,f,f

處理程式:

package require struct::matrix

set infile [open "input.dat" r]

# Read data
set filedata [list]
while { [gets $infile line] >= 0 } {
    set mylist [split $line ","]
    lappend filedata $mylist
}
close $infile

set maxrow [llength $filedata]
set maxcol [llength [lindex $filedata 0]]

::struct::matrix data
for {set i 0} {$i < $maxcol} {incr i} {
    data add column
}

for {set i 0} {$i < $maxrow} {incr i} {
    data add row [lindex $filedata $i]
}

data transpose

set rows [data rows]
for {set row 0} {$row < $rows} {incr row} {
    set mylist [data get row $row]
    set result [join $mylist ","]
    puts $result
}
data destroy

或者使用 tcllib csv 配合 struct::matrix 來處理:

package require csv
package require struct::matrix

::struct::matrix data
set infile [open "input.dat" r]
csv::read2matrix $infile data  , auto
close $infile

data transpose

set rows [data rows]
for {set row 0} {$row < $rows} {incr row} {
    set mylist [data get row $row]
    set result [join $mylist ","]
    puts $result
}
data destroy

或者使用 tclcsv 讀出資料,再配合 struct::matrix 來處理:

package require tclcsv
package require struct::matrix

set infile [open "input.dat" r]
set filedata [tclcsv::csv_read $infile]
close $infile

set maxrow [llength $filedata]
set maxcol [llength [lindex $filedata 0]]

::struct::matrix data
for {set i 0} {$i < $maxcol} {incr i} {
    data add column
}

for {set i 0} {$i < $maxrow} {incr i} {
    data add row [lindex $filedata $i]
}

data transpose

set rows [data rows]
for {set row 0} {$row < $rows} {incr row} {
    set mylist [data get row $row]
    set result [join $mylist ","]
    puts $result
}
data destroy

也可以使用 SQLite3 In-Memory Database 來處理,首先將資料儲存到表格中,然後依序選出以後再印出來:

package require tdbc::sqlite3
tdbc::sqlite3::connection create db ":memory:"

set statement [db prepare {create table mydata (name TEXT, age integer, sex char(1))}]
$statement execute
$statement close

set infile [open "input.dat" r]

# Read first line, field name
gets $infile line
set titles [split $line ","]

# Read data
while { [gets $infile line] >= 0 } {
    set mylist [split $line ","]
    set name [lindex $mylist 0]
    set age [lindex $mylist 1]
    set sex [lindex $mylist 2]
    
    set statement [db prepare {insert into mydata values (:name, :age, :sex)}]
    $statement execute
    $statement close
}
close $infile

# Output
for {set i 0} {$i < [llength $titles]} {incr i} {
    set field [lindex $titles $i]
    puts -nonewline "$field"
    set statement [db prepare "select $field from mydata"]
    
    $statement foreach row {
        puts -nonewline ",[dict get $row $field]"
    }

    $statement close
    puts ""
}
db close

Valid Phone Numbers

You are given a text file. Write a script to display all valid phone numbers in the given text file.

Acceptable Phone Number Formats
+nn  nnnnnnnnnn
(nn) nnnnnnnnnn
nnnn nnnnnnnnnn

Input File

0044 1148820341
 +44 1148820341
  44-11-4882-0341
(44) 1148820341
  00 1148820341

Output

0044 1148820341
 +44 1148820341
(44) 1148820341

處理的程式:

set infile [open "input.dat" r]

while { [gets $infile line] >= 0 } {
    set data [string trim $line]
    if {[regexp {(^\+\d{2}|^\(\d{2}\)|^\d{4})\s\d{10}$} $data]} {
        puts $line
    }
}
close $infile

2021-04-19

Chowla Numbers

Write a script to generate first 20 Chowla Numbers, named after, Sarvadaman D. S. Chowla, a London born Indian American mathematician. It is defined as:
C(n) = (sum of divisors of n) - 1 - n

proc chowla {n} {
    set sum 0
    for {set i 2} {[expr $i * $i] <= $n} {incr i} {
        if {[expr $n % $i]==0} {
            set sum [expr $sum + $i]
            set j [expr int($n / $i)]
            if {$j != $i} {
                set sum [expr $sum + $j]
            }
        }
    }

    return $sum
}

for {set i 1} {$i <= 20} {incr i} {
    puts "chowla($i) = [chowla $i]"
}

2021-04-14

Bell Numbers

Write a script to display top 10 Bell Numbers. Please refer to wikipedia page for more informations.

proc bellNumber {n} {
    array set bell {}

    set bell(0,0) 1
    for {set i 1} {$i <= $n} {incr i} {
        set decri [expr $i -1]
        set bell($i,0) $bell($decri,$decri)

        for {set j 1} {$j <= $i} {incr j} {
            set decrj [expr $j -1]
            set bell($i,$j) [expr $bell($decri,$decrj) + $bell($i,$decrj)]
        }
    }

    return $bell($n,0)
}

for {set i 1} {$i <= 10} {incr i} {
    puts "n=$i, Bell Number=[bellNumber $i]"
}

2021-04-11

ooxml 1.6

 ooxml 是一個讀寫 Office Open XML "XLSX" (since Excel 2007) 的套件,使用 TEA 架構。需要 Tcl >= 8.6.7,  tclvfs::zip >= 1.4.2 與 tdom >= 0.9.0,所以在使用前要先安裝 tclvfs::zip 與 tdom,Tcl 的版本需要 8.6.7 或者是更新的版本。

今天我嘗試製作 ooxml RPM  檔案,RPM spec 可以看這裡。 

2021-04-01

Decimal String

You are given numerator and denominator i.e. $N and $D.

Write a script to convert the fraction into decimal string. If the fractional part is recurring then put it in parenthesis.

#!/usr/bin/env tclsh

proc fractionToDecimal {numerator denominator} {
    set n $numerator
    set d $denominator

    if {$n==0} {
        return "0"
    }

    if {($n > 0) ^ ($d > 0)} {
        set solution "-"
    } else {
        set solution ""        
    }

    set n [expr abs($n)]
    set d [expr abs($d)]

    # integral part
    append solution [expr $n / $d]
    set n [expr $n % $d]
    if {$n==0} {
        return $solution
    }

    append solution "."

    # fractional part
    set mymap [dict create $n [string length $solution]]
    while {$n != 0} {
        set n [expr $n * 10]
        set r [expr $n / $d]
        append solution $r
        set n [expr $n % $d]
        if {[dict exists $mymap $n]==1} {
            set index [dict get $mymap $n]
            set result [string range $solution 0 [expr $index-1]]
            append result "("
            append result [string range $solution $index end]
            append result ")"
            set solution $result
            break
        } else {
            dict set mymap $n [string length $solution]
        }
    }

    return $solution
}

if {$argc != 2} {
    exit
}

set n [lindex $argv 0]
set d [lindex $argv 1]
puts [fractionToDecimal $n $d]

2021-03-30

Maximum Gap

You are given an array of integers @N.

Write a script to display the maximum difference between two successive elements once the array is sorted.

If the array contains only 1 element then display 0.

#!/usr/bin/env tclsh
#
# You are given an array of integers @N.
# Write a script to display the maximum difference between 
# two successive elements once the array is sorted.
# If the array contains only 1 element then display 0.
#

if {$argc == 0} {
    exit
} elseif {$argc == 1} {
    puts "0"
    exit
}

set len [llength $argv]
set mylist [lsort -integer $argv]
set max 0
for {set count 1} {$count < $len} {incr count} {
    set prev [lindex $mylist [expr $count - 1]]
    set curr [lindex $mylist $count]

    set result [expr $curr - $prev]
    if {$result > $max} {
        set max $result
    }
}

puts $max

2021-03-23

The Name Game

You are given a $name.

Write a script to display the lyrics to the Shirley Ellis song The Name Game. Please checkout the wiki page for more information.

#!/usr/bin/env tclsh
#
# You are given a $name.
# Write a script to display the lyrics to
# the Shirley Ellis song The Name Game.
#
if {$argc >= 1} {
    set xname [lindex $argv 0]
} elseif {$argc == 0} {
    puts "Please input a string"
    exit    
}

if {[string length $xname] <= 1} {
    puts "Please give a longer string"
    exit
}

set yname [string range $xname 1 end]
puts "$xname, $xname, bo-b$yname"
puts "Bonana-fanna fo-f$yname"
puts "Fee fi mo-m$yname"
puts "$xname!"

2021-03-18

FUSC Sequence

Write a script to generate first 50 members of FUSC Sequence.

The sequence defined as below:
fusc(0) = 0
fusc(1) = 1
for n > 1:
when n is even: fusc(n) = fusc(n / 2),
when n is odd: fusc(n) = fusc((n-1)/2) + fusc((n+1)/2)

#!/usr/bin/env tclsh
#
# Write a script to generate first 50 members of FUSC Sequence.
# fusc(0) = 0
# fusc(1) = 1
# for n > 1:
# when n is even: fusc(n) = fusc(n / 2),
# when n is odd: fusc(n) = fusc((n-1)/2) + fusc((n+1)/2)
#
proc fusc {n} {
    if {$n == 0}  {
        return 0
    } elseif {$n == 1} {
        return 1
    } elseif {$n > 1} {
        set checkn [tcl::mathop::% $n 2]
        if {$checkn==0} {
            return [fusc [tcl::mathop::/ $n 2]]
        } else {
            set subn [tcl::mathop::- $n 1]
            set addn [tcl::mathop::+ $n 1]
            return [tcl::mathop::+ [fusc [tcl::mathop::/ $subn 2]] [fusc [tcl::mathop::/ $addn 2]]]
        }
    } else {
        return -code error "Invalid input"
    }
}

set results [list]
for {set i 0} {$i < 50} {incr i} {
    lappend results [fusc $i]
}
set r [join $results ", "]
puts $r

2021-03-08

Chinese Zodiac

You are given a year $year.

Write a script to determine the Chinese Zodiac for the given year $year. Please check out wikipage for more information about it.

#!/usr/bin/env tclsh
# You are given a year $year.
# Write a script to determine the Chinese Zodiac
# for the given year $year.

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

if {$year <= 0} {
    puts "Year requires > 0."
    exit    
}

# The animal cycle: Rat, Ox, Tiger, Rabbit, Dragon, Snake, Horse, Goat,
# Monkey, Rooster, Dog, Pig.
# The element cycle: Wood, Fire, Earth, Metal, Water.
set animal [list Monkey Rooster Dog Pig Rat Ox Tiger Rabbit Dragon Snake Horse Goat]
set element [list Metal Metal Water Water Wood Wood Fire Fire Earth Earth]

set a [lindex $animal [expr $year % 12]]
set e [lindex $element [expr $year % 10]]
puts "$e $a"

2021-03-05

Rare Number

Given an integer N, the task is to check if N is a Rare Number.

Rare Number is a number N which is non-palindromic and N+rev(N) and N-rev(N) are both perfect squares where rev(N) is the reverse of the number N.

#!/usr/bin/env tclsh
#
# Given an integer N, the task is to check if N is a Rare Number.
#

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

if {$nvalue <= 0} {
    puts "Number requires > 0."
    exit
}

proc reverseNumber {num} {
    set rev_num 0
    while {$num > 0} {  
        set rev_num [expr $rev_num * 10 + $num % 10]  
        set num [expr $num / 10]
    }  
    return $rev_num
}

proc isPerfectSquare {x} {
    if {$x <= 0 } {
        return 0
    }

    set sr [expr round(sqrt(double($x)))]
    set result [expr $sr * $sr]    
    if {$result==$x} {
        return 1
    }

    return 0
}

proc isRare {nvalue} {
    set rvalue [reverseNumber $nvalue]
    if {$nvalue==$rvalue} {
        return 0
    }

    set addvalue [expr $nvalue + $rvalue]
    set subvalue [expr $nvalue - $rvalue]
    if {[isPerfectSquare $addvalue] && [isPerfectSquare $subvalue]} {
        return 1;
    }

    return 0;
}

if {[isRare $nvalue]==1} {
    puts "Yes"
} else {
    puts "No"
}

2021-02-08

Unique Subsequence

You are given two strings $S and $T. Write a script to find out count of different unique subsequences matching $T without changing the position of characters.

這題可以用遞迴來理解,下面就是基本條件:

  • Given the string T is an empty string, returning 1 as an empty string can be the subsequence of all.
  • Given the string S is an empty string, returning 0 as no string can be the subsequence of an empty string.
#!/usr/bin/env tclsh
#
# You are given two strings $S and $T.
# Write a script to find out count of different unique 
# subsequences matching $T without changing the position 
# of characters.
#
proc findSubsequenceCount {str1 str2 n m} {
    array set mat {}

    if {$m > $n} {
        return 0
    }

    if {$m == 0} {
        return 1
    }

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

    set nvalue [tcl::mathop::- $n 1]
    set mvalue [tcl::mathop::- $m 1]

    if {[string index $str1 $nvalue] != [string index $str2 $mvalue]} {
        return [findSubsequenceCount $str1 $str2 $nvalue $m]
    } else {
        return [tcl::mathop::+ [findSubsequenceCount $str1 $str2 $nvalue $m] \
               [findSubsequenceCount $str1 $str2 $nvalue $mvalue]]
    }
}

if {$argc != 2} {
    exit
}

set s1 [lindex $argv 0]
set s2 [lindex $argv 1]
set n [string length $s1]
set m [string length $s2]

set r [findSubsequenceCount $s1 $s2 $n $m]
puts "Output: $r"

使用動態規畫的解法:

#!/usr/bin/env tclsh
#
# You are given two strings $S and $T.
# Write a script to find out count of different unique 
# subsequences matching $T without changing the position 
# of characters.
#
proc findSubsequenceCount {str1 str2} {
    array set mat {}

    set n [string length $str1]
    set m [string length $str2]

    if {$n == 0 && $m == 0} {
        return 1
    }

    if {$m > $n} {
        return 0
    }

    # An empty string can't have another string as suhsequence 
    for {set i 1} {$i <= $m} {incr i} {
        set mat($i,0) 0
    }

    # An empty string is subsequence of all
    for {set j 0} {$j <= $n} {incr j} {
        set mat(0,$j) 1
    }

    for {set i 1} {$i <= $m} {incr i} {
        for {set j 1} {$j <= $n} {incr j} {
            set ivalue [tcl::mathop::- $i 1]
            set jvalue [tcl::mathop::- $j 1]

            if {[string index $str2 $ivalue] != [string index $str1 $jvalue]} {
                set mat($i,$j) $mat($i,$jvalue)
            } else {
                set mat($i,$j) [tcl::mathop::+ $mat($i,$jvalue) $mat($ivalue,$jvalue)]
            }
        }
    }

    return $mat($m,$n)
}

if {$argc != 2} {
    exit
}

set s1 [lindex $argv 0]
set s2 [lindex $argv 1]

set r [findSubsequenceCount $s1 $s2]
puts "Output: $r"

2021-01-26

Binary Substrings

You are given a binary string $B and an integer $S. Write a script to split the binary string $B of size $S and then find the minimum number of flips required to make it all the same.

使用 string range 分組,再比對字串。使用好幾個 for 迴圈,所以效率會不太好。

#!/usr/bin/env tclsh
#
# You are given a binary string $B and an integer $S.
# Write a script to split the binary string $B of size $S and
# then find the minimum number of flips required to make it all
# the same.
#
# Input: $B = “101100101”, $S = 3
# Output: 1
#

if {$argc >= 2} {
    set orgstring [lindex $argv 0]
    set number [lindex $argv 1]

    if {![string is integer $number]} {
        puts "S should be a number."
        exit
    }
    
    if {$number <= 0} {
        puts "S should be > 0."
        exit
    }
} else {
    exit
}

set len [string length $orgstring]
if {[expr $len % $number] != 0} {
    puts "Invalid input."
    exit
}

set stringlist {}
set max [expr $len / $number]
for {set i 0} {$i < $max} {incr i} {
   set mystring [string range $orgstring [expr $number * $i] [expr $number * $i + ($number - 1)]]
   lappend stringlist $mystring
}

set results {}
for {set i 0} {$i < $max} {incr i} {
    set count 0
    for {set j 0} {$j < $max} {incr j} {
        if {$i != $j} {
            set first [lindex $stringlist $i]
            set second [lindex $stringlist $j]
            for {set k 0} {$k < $number} {incr k} {
                if {[string index $first $k] != [string index $second $k]} {
                    incr count
                }
            }
        }
    }

    lappend results $count
}

puts "Input: \$B = \“$orgstring\”, \$S = $number"
puts "Output: [::tcl::mathfunc::min {*}$results]"

2021-01-25

Caesar Cipher

You are given string $S containing alphabets A..Z only and a number $N. Write a script to encrypt the given string $S using Caesar Cipher with left shift of size $N.

下面是 Caesar Cipher 的實作,使用 format 命令造出相對應的表格,並且使用 string toupper 轉換字串(用來確定輸入都是大寫字母), 再使用 string map 來產出需要的結果。事實上我在轉換表格同時處理了大寫和小寫,只是題目只要求大寫,以及處理 left shift 的要求。

#!/usr/bin/env tclsh
#
# You are given string $S containing alphabets A..Z only and a number $N.
# Write a script to encrypt the given string $S using Caesar Cipher with 
# left shift of size $N.
#
# Input: $S = "THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG", $N = 3
# Output: "QEB NRFZH YOLTK CLU GRJMP LSBO QEB IXWV ALD"
#

set encryptMap {}
set decryptMap {}

proc createEncMap {shift} {
    set shift [expr 26 - $shift]
    for {set i 0} {$i < 26} {incr i} {
        append ::encryptMap [format "%c %c %c %c " \
            [expr {$i+65}] [expr {($i+$shift)%26+65}] \
            [expr {$i+97}] [expr {($i+$shift)%26+97}]]
    }
}

proc createDecMap {shift} {
    set shift [expr 26 - $shift]
    for {set i 0} {$i < 26} {incr i} {
        append ::decryptMap [format "%c %c %c %c " \
            [expr {$i+65}] [expr {($i-$shift)%26+65}] \
            [expr {$i+97}] [expr {($i-$shift)%26+97}]]
    }
}

if {$argc >= 2} {
    set orgstring [lindex $argv 0]
    set shift [lindex $argv 1]

    set orgstring [string toupper $orgstring]
    if {![string is integer $shift]} {
        puts "N should be a number."
        exit
    }
    set shift [expr abs($shift)%26]
} else {
    exit
}

createEncMap $shift
createDecMap $shift
set result [string map $encryptMap $orgstring]
puts "Plain: $orgstring"
puts "Output: $result"
puts "Check: [string map $decryptMap $result]"

2021-01-24

Edit Distance

You are given two strings $S1 and $S2. Write a script to find out the minimum operations required to convert $S1 into $S2. The operations can be 'insert', 'remove' or 'replace' a character.

可以參考維基百科 Edit distance 的解釋。 這裡使用最簡單(但是執行效率不佳)的遞迴版本實作。

#!/usr/bin/env tclsh
#
# You are given two strings $S1 and $S2.
# Write a script to find out the minimum operations required to 
# convert $S1 into $S2. The operations can be 'insert', 'remove' 
# or 'replace' a character.
#
proc editdistance {str1 str2 m n} {
    if {$m == 0} {
        return $n
    }

    if {$n == 0} {
        return $m
    }

    set mvalue [tcl::mathop::- $m 1]
    set nvalue [tcl::mathop::- $n 1]

    # If last characters of two strings are same, nothing
    # much to do. Ignore and count for remaining strings.
    if {[string index $str1 $mvalue] == [string index $str2 $nvalue]} {
        return [editdistance $str1 $str2 $mvalue $nvalue]
    }

    # To insert, remove or replace operation
    return [tcl::mathop::+ 1 [tcl::mathfunc::min \
                   [editdistance $str1 $str2 $m $nvalue] \
                   [editdistance $str1 $str2 $mvalue $n] \
                   [editdistance $str1 $str2 $mvalue $nvalue]]]
}

if {$argc != 2} {
    exit
}

set s1 [lindex $argv 0]
set s2 [lindex $argv 1]

set r [editdistance $s1 $s2 [string length $s1] [string length $s2]]
puts "Output: $r"

如果觀察程式的運作,可以注意到,會一再重覆計算一些已經計算過的項目。 因此一個改進的方向是 dynamic programming,運用陣列記住已經算過的值,這樣就可以避免重複計算, 讓程式計算速度更快。所以建立一個 mxn 的陣列,並且記錄已經計算過的值,最後 dp(m,n) 就是答案。

#!/usr/bin/env tclsh
#
# You are given two strings $S1 and $S2.
# Write a script to find out the minimum operations required to 
# convert $S1 into $S2. The operations can be 'insert', 'remove' 
# or 'replace' a character.
#
proc editdistance {str1 str2 m n} {
    array set dp {}

    for {set i 0} {$i <= $m} {incr i} {
        for {set j 0} {$j <= $n} {incr j} {
            set ivalue [tcl::mathop::- $i 1]
            set jvalue [tcl::mathop::- $j 1]

            if {$i == 0} {
                set dp($i,$j) $j
            } elseif {$j == 0} {
                set dp($i,$j) $i
            } elseif {[string index $str1 $ivalue] == [string index $str2 $jvalue]} {
                set dp($i,$j) $dp($ivalue,$jvalue)
            } else {
                set dp($i,$j) [tcl::mathop::+ 1 [tcl::mathfunc::min \
                   $dp($i,$jvalue) $dp($ivalue,$j) $dp($ivalue,$jvalue)]]
            }
        }
    }

    return $dp($m,$n)
}

if {$argc != 2} {
    exit
}

set s1 [lindex $argv 0]
set s2 [lindex $argv 1]

set r [editdistance $s1 $s2 [string length $s1] [string length $s2]]
puts "Output: $r"

但是上面的解法如果是比較大的字串,就會需要很多空間儲存。觀察程式的計算, 可以發現當我們在計算第二列的時候,只需要第一列的結果(以此類推)。 所以我們可以使用一個 2xm 的陣列來計算。

#!/usr/bin/env tclsh
#
# You are given two strings $S1 and $S2.
# Write a script to find out the minimum operations required to 
# convert $S1 into $S2. The operations can be 'insert', 'remove' 
# or 'replace' a character.
#
proc editdistance {str1 str2 m n} {
    array set dp {}

    # Base condition when second string is empty
    for {set i 0} {$i <= $m} {incr i} {
        set dp(0,$i) $i
    }

    for {set i 1} {$i <= $n} {incr i} {
        for {set j 0} {$j <= $m} {incr j} {
            set ivalue [tcl::mathop::- $i 1]
            set jvalue [tcl::mathop::- $j 1]

            if {$j == 0} {
                set dp([tcl::mathop::% $i 2],$j) $i
            } elseif {[string index $str1 $jvalue] == [string index $str2 $ivalue]} {
                set dp([tcl::mathop::% $i 2],$j) $dp([tcl::mathop::% $ivalue 2],$jvalue)
            } else {
                set dp([tcl::mathop::% $i 2],$j) \
                    [tcl::mathop::+ 1 [tcl::mathfunc::min \
                        $dp([tcl::mathop::% $i 2],$jvalue) \
                        $dp([tcl::mathop::% $ivalue 2],$j) \
                        $dp([tcl::mathop::% $ivalue 2],$jvalue)]]
            }
        }
    }

    return $dp([tcl::mathop::% $n 2],$m)
}

if {$argc != 2} {
    exit
}

set s1 [lindex $argv 0]
set s2 [lindex $argv 1]

set r [editdistance $s1 $s2 [string length $s1] [string length $s2]]
puts "Output: $r"

2021-01-21

Reverse Words

Write a script to reverse the order of words in the given string. The string may contain leading/trailing spaces. The string may have more than one space between words in the string. Print the result without leading/trailing spaces and there should be only one space between words.

#!/usr/bin/env tclsh
#
# Write a script to reverse the order of words in the given string. 
# The string may contain leading/trailing spaces. The string may
# have more than one space between words in the string. Print the
# result without leading/trailing spaces and there should be only
# one space between words.
#
if {$argc >= 1} {
    set orgstring [lindex $argv 0]
} elseif {$argc == 0} {
    puts "Please input a string"
    exit    
}

set theWords [regexp -all -inline {\S+} [string trim $orgstring]]
set result [lreverse $theWords]
puts "Output: [join $result " "]"

2021-01-11

Palindrome Number

You are given a number $N. Write a script to figure out if the given number is Palindrome. Print 1 if true otherwise 0.

#!/usr/bin/tclsh
#
# Palindome Number:
# You are given a number $N. Write a script to figure out if 
# the given number is Palindrome. Print 1 if true otherwise 0.
#

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

if {$number < 0} {
    puts "0"
} elseif {$number > 0} {
    set p $number
    set res 0
    while {$p > 0} {
        set res [expr $res * 10 + $p % 10]
        set p [expr $p / 10]
    }
    if {$number == $res} {
        puts "1"
    } else {
        puts "0"
    }
} else {
    puts "1"
}

也可以使用 string reverse 來解。

#!/usr/bin/tclsh
#
# Palindome Number:
# You are given a number $N. Write a script to figure out if
# the given number is Palindrome. Print 1 if true otherwise 0.
#

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

if {$number < 0} {
    puts "0"
} elseif {$number > 0} {
    set res [string reverse $number]
    if {[string compare $number $res]==0} {
        puts "1"
    } else {
        puts "0"
    }
} else {
    puts "1"
}

2021-01-07

Group Anagrams

You are given an array of strings. Write a script to group Anagrams together in any random order.

下面是我試著解的結果:

#!/usr/bin/tclsh
#
# You are given an array of strings @S. Write a script to 
# group Anagrams together in any random order.
#
if {$argc == 0} {
    puts "Please input a string"
    exit
}

set len [llength $argv]
set inlist $argv
set result [dict create]
for {set index 0} {$index < $len} {incr index} {
    set tmpstring [lindex $inlist $index]
    set tmplist [lsort [split $tmpstring ""]]
    set key [join $tmplist ""]
    if {[dict exists $result $key]} {
        set value [dict get $result $key]
        lappend value $tmpstring
        dict set result $key $value
    } else {
        set value [list]
        lappend value $tmpstring
        dict set result $key $value
    }
}

puts "Output:"
foreach {key value} $result {
    puts $value
}

也可以使用 array:

#!/usr/bin/tclsh
#
# You are given an array of strings @S. Write a script to 
# group Anagrams together in any random order.
#
if {$argc == 0} {
    puts "Please input a string"
    exit
}

set len [llength $argv]
set inlist $argv
array set result {}
for {set index 0} {$index < $len} {incr index} {
    set tmpstring [lindex $inlist $index]
    set tmplist [lsort [split $tmpstring ""]]
    set key [join $tmplist ""]

    # If arrayName is not the name of an array variable, 
    # or if the array contains no elements, 
    # then an empty list is returned. 
    set value [lindex [array get result $key] 1]
    lappend value $tmpstring
    array set result [list $key $value]
}

puts "Output:"
foreach {key value} [array get result] {
    puts $value
}

2021-01-05

tkimg 1.4.12

在最近 tkimg 釋出了 1.4.12,可以在 tkImg 下載。

1.4.x 版本的可以在 8.3 或者是之後的使用,看下列的說明。

This file contains a collection of format handlers for the Tk photo image type, and a new image type, pixmaps. It can be used in combination with Tcl/Tk 8.3 or later but 8.6 or newer are highly recommended.

更新:
版本號有打錯, 重新更正過來。