# proc Einrichten {} { # # Einrichten des Hauptfensters #
global Canv
global Zaehler
set Zaehler 1#
toplevel .wavelet -class Toplevel -cursor left_ptr
wm focusmodel .wavelet passive
wm overrideredirect .wavelet 0
wm resizable .wavelet 1 1
wm geometry .wavelet 1280x720+20+40
wm title .wavelet "Wavelet"
wm deiconify .wavelet#
frame .wavelet.oben
frame .wavelet.unten -height 60 -background systemDialogBackgroundActive
set Canv [canvas .wavelet.oben.plotRect -background LightSkyBlue \
-borderwidth 3 -highlightthickness 3]
ttk::spinbox .wavelet.unten.zahl -values [list 1 2 4 8 16 32 64]
.wavelet.unten.zahl set 64
ttk::button .wavelet.unten.rechnen -text "Rechnen" -width 10
ttk::button .wavelet.unten.cancelBut -text "Abbrechen" -width 10 \
-command exit
ttk::button .wavelet.unten.fertigBut -text "Fertig" -width 10 \
-default active -command exit#
pack .wavelet.oben.plotRect -fill both -expand yes
grid rowconfigure .wavelet { 0 } -weight 5 -pad 0
grid rowconfigure .wavelet { 1 } -weight 0 -minsize 60
grid columnconfigure .wavelet { 0 } -weight 1 -pad 0
grid .wavelet.oben -column 0 -row 0 -sticky nsew
grid .wavelet.unten -column 0 -row 1 -sticky nsew#
grid columnconfigure .wavelet.unten 0 -weight 0 -minsize 18
grid columnconfigure .wavelet.unten {1 2 3} -weight 1 -minsize 18
grid .wavelet.unten.zahl -column 0 -row 0 -padx 18 -sticky ew
grid .wavelet.unten.rechnen -column 1 -row 0 -padx 18 -sticky ew
grid .wavelet.unten.cancelBut -column 2 -row 0 -padx 12 -sticky ew
grid .wavelet.unten.fertigBut -column 3 -row 0 -padx 18 -sticky ew#
raise .wavelet
} # # proc Plotten { Y n } { #
global Farbe
global Canv#
$Canv delete Linie$n
set Liste [list ]# set Grenze expr {[.wavelet2 * .unten.zahl get}]
set Grenze [llength $Y]
set X 50
set dX [expr {16 * 128 / $Grenze}]
set i 1
while {$i < $Grenze} {
lappend Liste $X
lappend Liste [expr {640 - 3 * [lindex $Y $i]}]
incr i 2
incr X $dX
}
if {$n >= [array size Farbe]} {
set n [expr {$n - [array size Farbe]}]
}
$Canv create line $Liste -fill $Farbe($n) -width 3 -tags Linie$n} # # proc Rechnen { Y } { #
global Farbe
global Canv
global Zaehler#
Haar::forwardTrans $Y
set Grenze [.wavelet.unten.zahl get]# # Hier gezielt Koeffizienten nullen, wenn gefiltert werden soll #
Haar::filter $Grenze
#
Plotten [Haar::inverseTrans $Grenze] $Zaehler
incr Zaehler} # # proc main {} { #
global Farbe
global Canv#
set Y [ list \
0 77.6875 1 78.1875 2 82.0625 3 85.5625 4 86.7500 5 82.4375 \
6 82.2500 7 82.7500 8 81.2500 9 79.5625 10 80.2813 11 79.8750 \
12 77.7500 13 74.7500 14 78.5000 15 79.1875 16 78.8125 17 80.3125 \
18 80.1250 19 79.3125 20 83.7500 21 89.8125 22 87.7500 23 91.1250 \
24 94.4375 25 92.7500 26 98.0000 27 97.1875 28 99.4375 29 101.7500 \
30 108.5000 31 109.0000 32 105.2500 33 105.5000 34 110.0000 35 107.0000 \
36 107.2500 37 103.3125 38 102.8750 39 102.4375 40 102.0000 41 101.3125 \
42 97.4375 43 100.5000 44 107.7500 45 110.2500 46 114.3125 47 111.2500 \
48 114.8125 49 112.6875 50 109.4375 51 108.0625 52 104.5625 53 103.2500 \
54 110.5625 55 110.7500 56 116.3125 57 123.6250 58 120.9375 59 121.6250 \
60 127.6875 61 126.0625 62 126.3750 63 124.3750 ]
array set Farbe [ list 0 black 1 blue 2 green 3 red ]#
Einrichten
.wavelet.unten.rechnen configure -command [list Rechnen $Y]#
Plotten $Y 0
} # # # Tiefpassfilter mit modischen Wavelets # # This software was written and is copyrighted by Ian Kaplan, Bear # Products International, www.bearcave.com, 2001. # # allerdings in Java, dies hier ist Tcl. Und die Arbeit von Herrn Kaplan # ist ein schöner Einstieg, aber mehr auch nicht. # # Um alles so einfach wie sinnvoll zu halten, werden nur die sehr simplen # Haar-Wavelets verwendet. Die sind so simpel, daß die Wavelet-Bezeichnung # schon fast irreführend ist. # package provide Haar 1.0
namespace eval Haar {
variable forward 1
variable inverse 2
variable vec
variable avg
variable dif
variable logN} # # proc Haar::predict { N direction } { # # Haar predict step #
variable forward
variable inverse
variable vec#
set half [expr {$N >> 1}]#
for {set i 0} {$i < $half} {incr i} {
set predictVal $vec($i)
set j [expr {$i + $half}]
if {$direction == $forward} {
set vec($j) [expr {$vec($j) - $predictVal}]
} elseif {$direction == $inverse} {
set vec($j) [expr {$vec($j) + $predictVal}]
} else {
tk_messageBox -icon warning -type ok \
-title "Fehler in Funktion Haar::predict" \
-message "Bad direction value $direction"
}
}} # # proc Haar::update { N direction } { # # Update step of the Haar wavelet transform. #
variable forward
variable inverse
variable vec#
set half [expr {$N >> 1}]#
for {set i 0} {$i < $half} {incr i} {
set j [expr {$i + $half}]
set updateVal [expr {$vec($j) / 2.0}]
if {$direction == $forward} {
set vec($i) [expr {$vec($i) - $updateVal}]
} elseif {$direction == $inverse} {
set vec($i) [expr {$vec($i) + $updateVal}]
} else {
tk_messageBox -icon warning -type ok \
-title "Fehler in Funktion Haar::update" \
-message "Bad direction value $direction"
}
}} # # proc Haar::split { N } { # # Split the vec into even and odd elements, # where the even elements are in the first half # of the vector and the odd elements are in the # second half. #
variable vec
#
set start 1
set end [expr {$N - 1}]#
while {$start < $end} {
for {set i $start} {$i < $end} {incr i} {
set tmp $vec($i)
set vec($i) $vec([incr i])
set vec($i) $tmp
}
incr start
incr end -1
}} # # proc Haar::merge { N } { # # Merge the odd elements from the second half of the N element # region in the array with the even elements in the first # half of the N element region. The result will be the # combination of the odd and even elements in a region # of length N. #
variable vec
#
set half [expr {$N >> 1}]
set start [expr {$half - 1}]
set end $half#
while {$start > 0} {
for {set i $start} {$i < $end} {incr i} {
set tmp $vec($i)
set vec($i) $vec([incr i])
set vec($i) $tmp
}
incr start -1
incr end
}} # # proc Haar::forwardTrans { Y } { #
variable forward
variable inverse
variable vec
variable avg
variable dif
variable logN#
set N [expr {[llength $Y] / 2}]
array set vec $Y#
set i 0
for {set n 0} {$n < $N} {incr n 2} {
set m [expr {$n + 1}]
set avg($i,0) [expr {($vec($n) + $vec($m)) / 2}]
set dif($i,0) [expr {($vec($n) - $vec($m)) / 2}]
incr i
}
set max [expr {$N >> 1}]
set j 1
while {$max > 1} {
set i 0
set j1 [expr {$j - 1}]
for {set n 0} {$n < $max} {incr n 2} {
set m [expr {$n + 1}]
set avg($i,$j) [expr {($avg($n,$j1) + $avg($m,$j1)) / 2}]
set dif($i,$j) [expr {($avg($n,$j1) - $avg($m,$j1)) / 2}]
incr i
}
set max [expr {$max >> 1}]
incr j
}
set logN [expr {$j - 1}]} # # proc Haar::filter { n } { #
variable forward
variable inverse
variable vec
variable dif
variable logN#
set j [expr int($logN - [ld $n] + 1)]
set max $n
while {$j >= 0} {
for {set i 0} {$i < $max} {incr i} {
set dif($i,$j) 0.0
}
incr j -1
set max [expr {$max << 1}]
}} # # proc Haar::inverseTrans { Grenze } { #
variable forward
variable inverse
variable vec
variable avg
variable dif
variable logN# # Der Trick hier: Resampling nur bis zur gewünschten Auflösung. # Das Nullen der Koeffizienten und volles Resampling bedeutet, daß man die # hohe zeitliche Auflösung regeneriert, ohne die hohen Frequenzen wiedergeben # zu wollen. In Folge gäbe es lange Plateaus mit sehr steilen Gradienten. #
set N [array size vec]
puts stdout "inverseTrans : N = $N, logN = $logN"#
set j1 [expr {$logN - 1}]
set loc(0,$j1) [expr {$avg(0,$logN) + $dif(0,$logN)}]
set loc(1,$j1) [expr {$avg(0,$logN) - $dif(0,$logN)}]
set max 4
while {$j1 > 0} {
set i 0
set j $j1
incr j1 -1
for {set n 0} {$n < $max} {incr n 2} {
set m [expr {$n + 1}]
set loc($n,$j1) [expr {$loc($i,$j) + $dif($i,$j)}]
set loc($m,$j1) [expr {$loc($i,$j) - $dif($i,$j)}]
incr i
}
set max [expr {$max << 1}]
if {$max == $Grenze} break
}
set i 0
set j $j1
for {set n 0} {$n < $Grenze} {incr n 2} {
set m [expr {$n + 1}]
set vec($n) [expr {$loc($i,$j) + $dif($i,$j)}]
set vec($m) [expr {$loc($i,$j) - $dif($i,$j)}]
incr i
}#
set Y [list ]
for {set n 0} {$n < $Grenze} {incr n} {
lappend Y $n $vec($n)
}
return $Y} # # # Logarithmus zur Basis 2 (wiki.tcl.tk/819) # proc ld x "expr {log(\$x)/expr log(2)}" # # console show main