顯示具有 Example 標籤的文章。 顯示所有文章
顯示具有 Example 標籤的文章。 顯示所有文章

2022-07-27

Last Sunday

Write a script to list Last Sunday of every month in the given year.

#!/usr/bin/tclsh
#
# Write a script to list Last Sunday of every month in the given year.
#

proc lastDay {month year} {
    set days [clock format [clock scan "+1 month -1 day" \
        -base [clock scan "$month/01/$year"]] -format %d]
}

proc getLastSunday {baseDate} {
    set base [clock scan $baseDate -format "%Y%m%d"]
    set day_of_week [clock format $base -format %u]

    # Sunday may report as 0 or 7.
    # If 7, it is not necessary to adjust.
    if {$day_of_week != 7} {
       set timestamp [clock scan "12:00 last sunday" -base $base]
    } else {
       set timestamp $base
    }

    return [clock format $timestamp -format "%Y-%m-%d"]
}


if {$argc >= 1} {
    set year [lindex $argv 0]
} else {
    set year 2022
    puts "Set year to 2022."
}

for {set i 1} {$i <= 12} {incr i} {
    set lday [lastDay $i $year]
    set ltime [format %04d%02d%02d $year $i $lday]
    set sday [getLastSunday $ltime]
    puts $sday
}

2022-03-24

Missing Permutation

只是做一點程式練習。


You are given possible permutations of the string 'PERL'.

PELR, PREL, PERL, PRLE, PLER, PLRE, EPRL, EPLR, ERPL,
ERLP, ELPR, ELRP, RPEL, RPLE, REPL, RELP, RLPE, RLEP,
LPER, LPRE, LEPR, LRPE, LREP

Write a script to find any permutations missing from the list.

#!/usr/bin/env tclsh

proc permutations { list size } {
    if { $size == 0 } {
        return [list [list]]
    }

    set retval {}
    for { set i 0 } { $i < [llength $list] } { incr i } {
        set firstElement [lindex $list $i]
        set remainingElements [lreplace $list $i $i]
        foreach subset [permutations $remainingElements [expr { $size - 1 }]] {
            lappend retval [linsert $subset 0 $firstElement]
        }
    }

    return $retval
}

set compare [list PELR PREL PERL PRLE PLER PLRE EPRL EPLR ERPL \
ERLP ELPR ELRP RPEL RPLE REPL RELP RLPE RLEP \
LPER LPRE LEPR LRPE LREP]

set result [list]
foreach r [permutations [list P E R L] 4] {
    set nr [join $r ""]
    lappend result $nr
}

set result [lsort $result]
set compare [lsort $compare]
set len [llength $result]
for {set i 0} {$i < $len} {incr i} {
    set ri [lindex $result $i]
    set ci [lindex $compare $i]

    if {[string compare $ri $ci] != 0} {
        puts $ri
        break
    }
}

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"
    }
}

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-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-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"
}