#!/bin/sh
 # Restart with tcl: -*- mode: tcl; tab-width: 4; -*- \
 exec wish $0 ${1+"$@"}

 # XmasTree3.tcl - HaJo Gurt - 2005-12-23 - https://wiki.tcl-lang.org/15176
 #: Design your own Christmas Tree - international version
 # See also: Xmas Tree by R. Suchenwirth 2005-12-22, https://wiki.tcl-lang.org/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 [namespace code [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 https://wiki.tcl-lang.org/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]"}
  }

 #.