Summary edit
HJG: Inspired by Xmas Tree from RS, here is a version where you can decorate the tree yourself.- Use option-menus to select color and type of decoration
- Click on canvas to place it
- Right-click to remove an item
- F1 to show console
- Cut+paste your design from the console-log to the proc Decorate
- Save program + restart it
Code edit
#!/bin/sh
# Restart with tcl: -*- mode: tcl; tab-width: 4; -*- \
exec wish $0 ${1+"$@"}
# XmasTree3.tcl - HaJo Gurt - 2005-12-23 - http://wiki.tcl.tk/15176
#: Design your own Christmas Tree - international version
# See also: Xmas Tree by R. Suchenwirth 2005-12-22, http://wiki.tcl.tk/15164
#
# Click to place new decorations
# Right-click to remove
# F1 to show console
# Cut+paste your design from console-log to proc Decorate
#
# 2005-12-23 First Version
# 2005-12-24 added: small bell, small candle, lantern
# 2005-12-25 msgcat
# Todo:
# Save to image/jpg, load/save layout (serialize to file), move items,
# more generic / resizable tree,
# more decoration-items (lametta, garlands ...)
#########1#########2#########3#########4#########5#########6#########7#####
package require Tk
package require msgcat
namespace import msgcat::mc msgcat::mcset
# Tcl 8.4 initializes the locale from ::env(LC_ALL) or ::env(LC_MESSAGES),
# but on Windows these might not be set, so you have to select yourself:
msgcat::mclocale en
#msgcat::mclocale de ;# <=====<< Select language
# DE - German messages:
mcset de "Merry Christmas !" "Frohe Weihnachten !"
mcset de "red" "rot"
mcset de "yellow" "gelb"
mcset de "orange" "orange"
mcset de "gold" "golden"
mcset de "green" "grün"
mcset de "green4" "dunkelgrün"
mcset de "cyan" "türkis"
mcset de "blue" "blau"
mcset de "magenta" "magenta"
mcset de "white" "weiss"
mcset de "gray" "grau"
mcset de "black" "schwarz"
mcset de "random" "zufällig"
mcset de "Candle1" "Kerze1"
mcset de "Candle2" "Kerze2"
mcset de "Bauble4" "Kugel4"
mcset de "Bauble6" "Kugel6"
mcset de "Bauble8" "Kugel8"
mcset de "Bell4" "Glocke4"
mcset de "Bell6" "Glocke6"
mcset de "Lantern1" "Laterne1"
mcset de "Star4" "Stern4"
mcset de "Star5" "Stern5"
mcset de "Star6" "Stern6"
mcset de "Star8" "Stern8"
#########1#########2#########3#########4#########5#########6#########7#####
proc every {ms body} {eval $body; after $ms [info level 0]}
proc lpick list {lindex $list [expr {int(rand()*[llength $list])}]}
proc Color {nr} {
set c [lindex {red orange yellow green cyan blue magenta pink grey20 } $nr]
}
proc OptionMenu {w varName firstValue args} {
#: internationalized version of tk_optionMenu, see http://wiki.tcl.tk/14574
upvar #0 $varName var
if {![info exists var]} {
set var $firstValue
}
menubutton $w -text [::msgcat::mc $firstValue] -indicatoron 1 -menu $w.menu \
-relief raised -bd 2 -highlightthickness 2 -anchor c \
-direction flush
menu $w.menu -tearoff 0
$w.menu add radiobutton -label [::msgcat::mc $firstValue] -variable $varName \
-value $firstValue -command "UpdateOptionMenuLabel $w $varName"
foreach i $args {
$w.menu add radiobutton -label [::msgcat::mc $i] -variable $varName \
-value $i -command "UpdateOptionMenuLabel $w $varName"
}
return $w.menu
}
proc UpdateOptionMenuLabel {w v} {
upvar #0 $v x
$w configure -text [::msgcat::mc $x]
}
#########1#########2#########3#########4#########5#########6#########7#####
proc DeleteItem {} {
#: Find all parts of an item and delete them, e.g. candle+flame
set Tags [.c itemcget current -tag ]
puts "-$Tags"
foreach Nr [split $Tags] {
if { [string index $Nr 0] == "i"} { .c delete $Nr }
}
}
proc NewItem { i x y c } {
#: Schedule new item to put on tree
set ItemType [string map {Candle C Lantern L Star s Bauble b Bell B } $i ]
if { $i=="random" } {
set ItemType [lpick {C1 C2 L1 B4 B6 b4 b6 b8 s4 s5 s6 s8} ]
}
if { $c=="random" } {
set c [lpick {red orange gold yellow green cyan blue magenta white gray} ]
}
incr ::nItem 1
switch -- $ItemType {
C1 { NewCandle $x $y $c 1 }
C2 { NewCandle $x $y $c 2 }
L1 { NewLantern $x $y $c 1 }
B4 { NewBell $x $y $c 4 }
B6 { NewBell $x $y $c 6 }
s4 { NewStar $x $y $c 4 }
s5 { NewStar $x $y $c 5 -18 }
s6 { NewStar $x $y $c 6 }
s8 { NewStar $x $y $c 8 }
b8 { NewBauble $x $y $c 8 }
b6 { NewBauble $x $y $c 6 }
b4 { NewBauble $x $y $c 4 }
default { bell; puts "?? $i $x $y $c" }
}
}
#########1#########2#########3#########4#########5#########6#########7#####
proc NewCandle {x1 y1 {c red} {s 2} } {
#: Create new decoration: Candle with flame
.c create rect $x1 $y1 \
[expr $x1+4] [expr $y1-$s*10 ] -fill $c -tags "Candle i$::nItem"
.c create oval [expr $x1-1] [expr $y1-$s*10- 1] \
[expr $x1+5] [expr $y1-$s*10-11] -fill yellow -tags "Flame i$::nItem"
puts " C$s $x1 $y1 $c"
}
proc NewLantern {x1 y1 {c red} {s 1} } {
#: Create new decoration: Lantern
.c create poly $x1 $y1 \
[expr $x1-10] [expr $y1+ 5] \
[expr $x1+11] [expr $y1+ 5] -tags "Lantern i$::nItem" -fill white
.c create rect [expr $x1- 6] [expr $y1+ 5] \
[expr $x1+ 6] [expr $y1+20] -tags "Lantern i$::nItem" -fill white
.c create rect [expr $x1- 4] [expr $y1+ 7] \
[expr $x1+ 4] [expr $y1+18] -tags "Lantern i$::nItem" -fill $c
.c create line [expr $x1- 4] [expr $y1+ 7] \
[expr $x1+ 4] [expr $y1+18] -tags "Lantern i$::nItem"
.c create line [expr $x1+ 4] [expr $y1+ 7] \
[expr $x1- 4] [expr $y1+18] -tags "Lantern i$::nItem"
puts " L$s $x1 $y1 $c"
}
proc NewBell {x1 y1 {c gold} {size 4} } {
#: Create new decoration: Bell
if {$size==6} {
.c create oval [expr $x1- 6] [expr $y1+0] \
[expr $x1+ 6] [expr $y1+22] -fill $c -tags "Bell i$::nItem"
.c create poly $x1 [expr $y1+10] \
[expr $x1-12] [expr $y1+20] \
[expr $x1+12] [expr $y1+20] -fill $c -tags "Bell i$::nItem"
} else {
.c create oval [expr $x1- 4] [expr $y1+ 0] \
[expr $x1+ 4] [expr $y1+15] -fill $c -tags "Bell i$::nItem"
.c create poly $x1 [expr $y1+ 5] \
[expr $x1- 8] [expr $y1+14] \
[expr $x1+ 8] [expr $y1+14] -fill $c -tags "Bell i$::nItem"
}
puts " B$size $x1 $y1 $c"
}
proc Star { {x 100} {y 20} {n 5} {rot 0} {size {8 24}} } {
#: create polygon for a star
# at position $x $y
# with $n rays
# with inner size [lindex $size 0]
# and outer size [lindex $size 1]
# rotated by $rot degrees
set rot [expr {3.14159 * $rot / 180.0}]
set inc [expr {6.28318 / $n}]
foreach {mind maxd} $size break
for {set i 0} {$i < $n} {incr i} {
lappend star [expr {cos($inc * $i + $rot) * $maxd / 2.0 + $x}]
lappend star [expr {sin($inc * $i + $rot) * $maxd / 2.0 + $y}]
lappend star [expr {cos($inc * ($i + 0.5) + $rot) * $mind / 2.0 + $x}]
lappend star [expr {sin($inc * ($i + 0.5) + $rot) * $mind / 2.0 + $y}]
}
return $star
}
proc NewStar {x y {c gold} {n 4} {rot 0} } {
#: Create new decoration: Star
set star [Star $x $y $n $rot]
.c create polygon $star -outline black -width 1 -fill $c -tags "Star i$::nItem"
puts " s$n $x $y $c"
}
proc NewBauble {x y {c grey} {s 4} } {
#: Create new decoration: Bauble = Sphere, glass ball
.c create oval [expr $x-$s] [expr $y-$s] [expr $x+$s] [expr $y+$s] \
-fill $c -tag "Bauble i$::nItem"
puts " b$s $x $y $c"
}
#########1#########2#########3#########4#########5#########6#########7#####
proc Flicker {id} {
#: Fast color-cycling to flicker a candle-flame
set Color [lpick {yellow "light yellow" orange gold goldenrod red red2 linen white}]
.c itemconfig $id -fill $Color
if {$Color != "yellow" } {after 20 Flicker $id}
}
proc Animate {} {
#: Select a candle and make it flicker
set Selection [.c find withtag Flame]
if { $Selection != "" } { Flicker [lpick $Selection] }
}
#########1#########2#########3#########4#########5#########6#########7#####
proc MakeTree { {xm 200} {ym 300} } {
#: Build a simple christmas-tree
.c create poly 70 290 130 290 100 270 -fill black
.c create rect 95 250 105 275 -fill brown
foreach dx {40 55 70 85 100} y {20 60 100 140 180} {
.c create poly 100 $y \
[expr 100-$dx] [expr $y+70] \
[expr 100+$dx] [expr $y+70] -fill darkgreen -tag tree
}
}
proc Decorate {} {
#: Put some decorations on the tree
#!! Cut+paste your design here from the console-output !!
foreach {i x y c} { s8 100 20 gold C1 16 241 red C2 55 123 red
C2 155 166 red
L1 173 245 red
B4 42 165 magenta
B6 123 211 gold
s4 85 203 white
s5 110 76 blue
b4 91 120 cyan
s6 108 152 yellow
b6 54 244 green
b8 166 213 gray
} { NewItem $i $x $y $c }
}
#########1#########2#########3#########4#########5#########6#########7#####
pack [canvas .c -width 200 -height 300 -background darkblue]
frame .f1
pack .f1
OptionMenu .m1 Color red orange gold yellow green green4 cyan blue magenta white gray random
OptionMenu .m2 ItemType Candle1 Candle2 Lantern1 Bell4 Bell6 \
Bauble4 Bauble6 Bauble8 Star4 Star5 Star6 Star8 random
pack .m1 .m2 -in .f1 -side left
set nItem 0
MakeTree
Decorate
wm title . [mc "Merry Christmas !"]
bind .c <1> { NewItem $ItemType %x %y $Color }
bind .c <3> { DeleteItem }
bind . <F1> { console show }
bind . <Escape> { source $argv0 }
every 200 { Animate }
focus -force .
# Debug:
if 0 {
catch {console show}
proc int x { expr int($x) }
bind .c <Motion> {wm title . "[int [%W canvasx %x]],[int [%W canvasy %y]]=[.c find withtag current]"}
}
#.Comments edit
Now with international support, thanks to msgcat and Tk internationalization.See also: A tiny drawing program - TclBrix - Toy car workshop - Xmas Stars - Xmas Tree - Advent Wreathgold 25Nov2017, added pix.
