Version 2 of Design your own Christmas Tree

Updated 2005-12-23 22:54:01

HJG Inspired by Xmas Tree from RS, here is a version where you can decorate the tree yourself.

  • Click to place a new decoration
  • Right-click to remove an item
  • Cut+paste your design from the console-log to the proc Decorate

The candles are animated with a bit of flickering.

Merry Christmas !


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

 #: XmasTree2.tcl - HaJo Gurt - 2005-12-23 - http://wiki.tcl.tk/15176
 # See also Xmas Tree by R. Suchenwirth 2005-12-22, http://wiki.tcl.tk/15164
 #
 # Click to place new decorations
 # Right-click to remove
 # Cut+paste your design from console-log to proc Decorate
 #
 # 2005-12-23 First Version

 # 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

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

 #########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 ]
    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 Star s Bauble b Bell B } $i ]
    if { $i=="random" } {
      set ItemType [lpick {C b4 b6 b8 s4 s5 s6 s8 B} ]
    }
    if { $c=="random" } {
      set c [lpick {red orange gold yellow green cyan blue magenta white gray} ]
    }
    incr ::nItem 1
    switch  -- $ItemType {
        C       { NewCandle $x $y $c }
        B       { NewBell   $x $y $c }
        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 }
        default { NewBauble $x $y $c 4 }
    }
  }

 #########1#########2#########3#########4#########5#########6#########7#####

  proc NewCandle {x1 y1 {c red}} {
  #: Create new decoration: Candle with flame
    set x2 [expr $x1 + 4]
    .c create rect $x1          $y1 \
                   $x2          [expr $y1-20] -fill $c      -tags "candle i$::nItem"
    .c create oval [expr $x1-1] [expr $y1-21] \
                   [expr $x2+1] [expr $y1-30] -fill yellow  -tags "flame  i$::nItem"
    puts " C $x1 $y1 $c"
  }

  proc NewBell {x1 y1 {c gold}} {
  #: Create new decoration: Bell
    set x2 [expr $x1 + 10]
    .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"
    puts " B $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 {xpos ypos} $pos  break
    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   C 56 124 red   C 16 241 red
           C 159 164 red
           B 143 244 gold
           b4 75 142 cyan
           b6 54 244 green
           b8 164 208 gray
           s4 85 203 blue
           s5 110 76 white
           s6 116 158 yellow
     } {
      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
  tk_optionMenu .m1 Color     red orange gold yellow green cyan blue magenta white gray   random
  tk_optionMenu .m2 ItemType  Candle Bell Bauble4 Bauble6 Bauble8 Star4 Star5 Star6 Star8 random
  pack  .m1 .m2  -in .f1  -side left

  set nItem 0
  MakeTree
  Decorate

  set ItemType "random"
  set ItemType "Candle"
  set Color    "random"
  set Color    orange

  bind .c <1>      { NewItem $ItemType %x %y $Color }
  bind .c <3>      { DeleteItem }
  bind .  <F1>     { console show }
  bind .  <Escape> { source $argv0 }

  wm title . "Merry Christmas !"
  focus -force .

  every 200 { Animate }

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

 #.

See also: Toy cars - Toy car workshop - A tiny drawing program - Xmas Stars - Xmas Tree


Category Graphics | Category Toys