Version 11 of A symmetric doodler

Richard Suchenwirth - This breakfast fun project allows symmetric doodling (free-hand drawing) on a canvas. Besides drawing a line (in selectable color) at cursor position, horizontally and/or vertically mirrored lines are also drawn. Delete a line with right mousebutton, or all with the C button. Enjoy!

KPV Fun. I modified it slightly (in place) so that you can resize it and by right clicking on a color, you can change the background.

KPV My 3 year old daughter requested fatter lines, so I added the ability to select the pen size.

GPS Thanks Richard and Keith for sharing this. I like it and so does my brother. My brother wants the ability to save images, so maybe I'll play around with Img and improve this.

 proc main {} {
    set size      400 ;# canvas height and width
    set axiscolor grey
    set bg        white
    global g

    frame .f -relief sunken -borderwidth 2
    checkbutton .f.hori -text -- -variable g(hori)
    set g(hori) 1
    checkbutton .f.vert -text | -variable g(vert)
    set g(vert) 1
    foreach color {purple red orange yellow green blue white black} {
        radiobutton .f.b$color -width 1 -padx 0 -pady 0 -bg $color \
            -variable g(color) -value $color
        bind .f.b$color <3> [list .c config -bg $color]
    }
    set g(color) black
    button .f.c -text C -width 3 -command {.c delete line}
    frame .f.f -bd 2 -relief raised
    label .f.f.lbl -text "Pen Size" -bd 0
    tk_optionMenu .f.f.w g(w) 1 3 5 7 9 20
    .f.f.w config -highlightthickness 0 -bd 0
    set g(w) 3
    eval pack [winfo children .f] -side left -fill y
    eval pack [winfo children .f.f] -side left -fill y
    symdoodle [canvas .c -height $size -width $size -bg $bg]
    .c create line -4000 0     4000 0    -fill $axiscolor
    .c create line 0     -4000 0    4000 -fill $axiscolor
    pack .f -side top -fill x
    pack .c -side top -fill both -expand 1

 }
 proc symdoodle w {
    bind $w <1>         {symdoodle'start %W %x %y}
    bind $w <B1-Motion> {symdoodle'move  %W %x %y}
    bind $w <3>         {%W delete current}
    bind $w <Configure> {symdoodle'center %W %h %w}
 }
 proc symdoodle'start {w x y} {
    global g
    set x [$w canvasx $x]
    set y [$w canvasy $y]
    readCheckbuttons
    set g(ids) {}
    foreach {xf yf} $g(todo) {
        set x1 [expr {$x*$xf}]
        set y1 [expr {$y*$yf}]
        lappend g(ids) [
           $w create line $x1 $y1 $x1 $y1 -fill $g(color) -tag line -width $g(w)
        ]
    }
 }
 proc symdoodle'move {w x y} {
    global g
    set x [$w canvasx $x]
    set y [$w canvasy $y]
    foreach {xf yf} $g(todo) id $g(ids) {
        set x1 [expr {$x*$xf}]
        set y1 [expr {$y*$yf}]
        eval $w coords $id [concat [$w coords $id] $x1 $y1]
    }
 }
 proc readCheckbuttons {} {
    global g
    set g(todo) [list 1 1]
    if {$g(hori)} {lappend g(todo) 1 -1}
    if {$g(vert)} {
        foreach {xf yf} $g(todo) {
            lappend g(todo) [expr {-$xf}] $yf
        }
    }
 }
 proc symdoodle'center {W h w} {
    set h [expr {$h / 2.0}]
    set w [expr {$w / 2.0}]
    $W config -scrollregion [list -$w -$h $w $h]
 }

 main

GPS I love this code! It was fun to modify. I added the ability to choose a new color for a slot (via double click, see the balloon help), balloon help, and dashed pattern drawing in the code below. My brother even coded a bit, and he's a newbie. The next step will be writing the canvas to a PNG or something like that.

Enjoy!

 proc main {} {
    set size      400 ;# canvas height and width
    set axiscolor grey
    set bg        white
    global g

    frame .f -relief sunken -borderwidth 2
    checkbutton .f.hori -text -- -variable g(hori)
    symdoodle'balloon .f.hori {Mirror drawing to the left or right areas}

    set g(hori) 1
    checkbutton .f.vert -text | -variable g(vert)
    checkbutton .f.dash -text Dash -variable g(dash)
    symdoodle'balloon .f.dash {Draw lines using a dashed pattern}
    symdoodle'balloon .f.vert {Mirror drawing to the lower or upper areas}
    set g(vert) 1
    set colorHelpStr {Right click to set the background color.  Double click to choose a new color}
    foreach color {purple red orange yellow green blue white black} {
        radiobutton .f.b$color -width 1 -padx 0 -pady 0 -bg $color \
            -variable g(color) -value $color -activebackground $color
        bind .f.b$color <3> {.c config -bg [%W cget -bg]}
        bind .f.b$color <Double-ButtonPress-1> {symdoodle'changeColor %W}
        symdoodle'balloon .f.b$color $colorHelpStr
    }
    set g(color) black
    button .f.c -text C -width 3 -command {.c delete line}
    symdoodle'balloon .f.c {Clear the canvas}
    frame .f.f -bd 2 -relief raised
    label .f.f.lbl -text {Pen Size} -bd 0
    tk_optionMenu .f.f.w g(w) 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20
    .f.f.w config -highlightthickness 0 -bd 0
    #I like using a scale, but my brother doesn't like it.
    #scale .f.f.w -variable g(w) -from 1 -to 20 -orient horizontal

    label .f.f.dashTypeLbl -text {Dash Type} -bd 0
    tk_optionMenu .f.f.dtype g(dashType) {1 1} {2 4} {-.} {-.-}
    .f.f.dtype config -highlightthickness 0 -bd 0

    set g(dashType) {1 1}
    set g(w) 3
    eval pack [winfo children .f] -side left -fill y
    eval pack [winfo children .f.f] -side left -fill y
    symdoodle [canvas .c -height $size -width $size -bg $bg]
    .c create line -4000 0     4000 0    -fill $axiscolor
    .c create line 0     -4000 0    4000 -fill $axiscolor
    pack .f -side top -fill x
    pack .c -side top -fill both -expand 1

 }

 proc symdoodle w {
    bind $w <1>         {symdoodle'start %W %x %y}
    bind $w <B1-Motion> {symdoodle'move  %W %x %y}
    bind $w <3>         {%W delete current}
    bind $w <Configure> {symdoodle'center %W %h %w}
 }

 proc symdoodle'balloon {win txt} {
    #We don't want % in a line being substituted
    set modTxt [string map {"%" "%%"} $txt]
    bind $win <Enter> [list symdoodle'balloon'show $win $txt]
    bind $win <Leave> {destroy %W._balloon}
 }

 proc symdoodle'balloon'show {win txt} {
    toplevel $win._balloon
    wm overrideredirect $win._balloon 1
    pack [message $win._balloon.msg -text $txt -aspect 400]

    set x [winfo rootx $win]
    set y [expr {[winfo rooty $win] + [winfo height $win] + 2}]
    wm geometry $win._balloon +$x+$y
 }

 proc symdoodle'changeColor {win} {
    set color [tk_chooseColor]
    if {$color == ""} {
        return
    }
    $win config -bg $color -value $color -activebackground $color
    set theVar [$win cget -variable]
    uplevel #0 set $theVar $color
 }

 proc symdoodle'start {w x y} {
    global g
    set x [$w canvasx $x]
    set y [$w canvasy $y]
    readCheckbuttons
    set g(ids) {}
    foreach {xf yf} $g(todo) {
        set x1 [expr {$x*$xf}]
        set y1 [expr {$y*$yf}]
        set cmd [list $w create line $x1 $y1 $x1 $y1 -fill $g(color) -tag line -width $g(w)]

        if {$g(dash)} {
            set cmd [concat $cmd -dash [list $g(dashType)]]
        }
        lappend g(ids) [eval $cmd]
    }
 }
 proc symdoodle'move {w x y} {
    global g
    set x [$w canvasx $x]
    set y [$w canvasy $y]
    foreach {xf yf} $g(todo) id $g(ids) {
        set x1 [expr {$x*$xf}]
        set y1 [expr {$y*$yf}]
        eval $w coords $id [concat [$w coords $id] $x1 $y1]
    }
 }
 proc readCheckbuttons {} {
    global g
    set g(todo) [list 1 1]
    if {$g(hori)} {lappend g(todo) 1 -1}
    if {$g(vert)} {
        foreach {xf yf} $g(todo) {
            lappend g(todo) [expr {-$xf}] $yf
        }
    }
 }
 proc symdoodle'center {W h w} {
    set h [expr {$h / 2.0}]
    set w [expr {$w / 2.0}]
    $W config -scrollregion [list -$w -$h $w $h]
 }

 main

Arts and crafts of Tcl-Tk programming - Category Games - Category Graphics - Category Application