# Pretty Print version from autoindent and ased editor
    # Random Poetry Chalkboard
    # written on Windows XP on eTCL
    # working under TCL version 8.5.6 and eTCL 1.0.1
    # gold on TCL WIKI , 10Jul2009
    package require Tk    
    # proc ?, suchenworth routine
    proc ? L {
        lindex $L [expr {int(rand()*[llength             

$L])}]
    }
    proc poetry {} {
        set a {
            {red} {sad} {blue} {blue}
            {glad} {glad} {deep} {black}
            {wild } { green } {pale } {bright}
            {rough } {gray } {brown } {long}
            {high } {thin} {brown } {lush}
            {dry } {poor} {lone } {far}
            {flat } {broad} {thick } {hard}
            {flat } {broad} {cool} {hard}
            }
        set b {
            {quince } { peach } {hare } {bird}
            { smoke } { rain} { ice} {snow}
            {cloud} { home} { flower } {sky}
            {rice} { pine} { mist} {door}
            {wind} { cricket} { year } {moon}
            {crane } {grass } {rose} {ink}
            {thaw} { bloom } {lake} { cedar }
            {dusk} { autumn } {stone} { dawn}
            {stream} { tree } {heart} { boat}
            {grief} { tree } {boat} {boat}
            {rock} {town} {tear} {pool}
            {silk} {deer} {song} {barge}
            {moss} {night} {gate} {fence}
            {dove} {dream} {frost} {peace}
            {shade} {ghost} {road} {path}
            {root} {horse} {eve } {sound}
            {sleep} {leaves} {sea } {sail}
            {peak} {stem} {field} {wave}
            {slope} {bark} {crest} {weed}
            {moth} {wasp} {pond} {soil}
            {snail} {worm} {ant} {kelp}
            {cave} {month} {head} {jade}
            {branch} {bone} {head} {smile}
            {pea} {bone} {head} {smile}
            {elm} { morn} {carp} {nest}
            {oak} { bone} {perch} {breeze}
             }
        set c {
            {snow} { burns} {flips} {flys}
            {lies} { walk } {flow } {fall} {fly}
            {know } {come}  {meet } {drift}
            {shine } {soak} { cry } {dance}
            { lost} {cheer} {float} {dance}
            {roost} { move} { fade} {loves}
            {sleeps} {move} {takes} {sail}
            {sits} {leaps} {sits }  {sit}
            {sits} {leaps} {grows } {waits}
            {loses} {hears} {wants} {watch}
        }
        set d {
            {for} {by} {towards} { to } {at}             

{bygone}
            {to} {in} {in } {to }
            {to} {in} {fore } {through}
            }
        return [list [? $a] [? $b] [? $c] [? $d] [? $a] [? 

$b]]
        }  
        proc populateCanvas {canvas cols rows} {
            variable ids ;# links text ids with             

respective rect ids
            variable boxes ;# lists text id and text           

  associated with each rect id
            catch {unset ids boxes}
            # parameters for drawing boxes
            set boxwidth 50
            set boxheight 20
            set padx 3
            set pady 3
            set colors {red orange yellow green blue           

      purple}          
            # draw the boxes             
            for {set row 0} {$row < $rows} {incr row} {
                  set texz [poetry]                          
            for {set col 0} {$col < $cols} {incr col} {
                    # calculate coordinates
       set x1 [expr {$col * ($boxwidth + $padx) +$padx}]
                    set x2 [expr {$x1 + $boxwidth}]
                    set x3 [expr {$x1 + ($boxwidth / 2)}]
                    set y1 [expr {$row * ($boxheight + $pady)  

                       + $pady}]
                    set y2 [expr {$y1 + $boxheight}]
                    set y3 [expr {$y1 + ($boxheight / 2)}]
                    # choose color and text
                    set color [lindex $colors [expr {int       

                 (rand() * [llength $colors])}]]
                    set text [ lindex $texz $col]
                    
                    # create the boxes
                    set boxid [$canvas create rectangle $x1    

                 $y1 $x2 $y2 \
                            -fill $color \
                            -outline black]
                    set textid [$canvas create text $x3 $y3 \
                            -text $text]
                    # remember which text item goes with       

              which box and what the text says
                    set boxes($boxid) [list $textid $text]
                    set ids($textid) $boxid
                    set ids($boxid) $boxid
                }
            }
        }
        proc clearSelection {canvas} {
            # if there is an existing currently selected       

      box, change its border back to
            # black; set variables selectedid and             

selectedtext to empty strings
            variable selectedid
            variable selectedtext
            if {$selectedid ne "" && [$canvas find             

    withtag $selectedid] ne ""} {
                $canvas itemconfigure $selectedid -outline     

            black
            }
            set selectedid ""
            set selectedtext ""
        }
        proc handleSelection {canvas id} {
            # determine the "next step" by comparing the       

      newly selected box id and text
            # to the box id and text of the previously         

    selected box (contained in
            # the variables $selectedid and             

$selectedtext)
            variable ids
            variable boxes
            variable selectedid
            variable selectedtext
            set boxid $ids($id)
            lassign $boxes($boxid) textid text
            if {$boxid eq $selectedid} {
                # user has selected the same box twice;        

         deselect the box
                clearSelection $canvas
                return
            } elseif {$text eq $selectedtext} {
                # user has selected two boxes with the same    

             text; delete both boxes
                $canvas delete $boxid $textid $selectedid      

           [lindex $boxes($selectedid) 0]
                clearSelection $canvas
                return
            } else {
                # user has selected a box when there is no     

            selection, or user has
                # selected a box with different text than      

           the previously selected box;
                # try to deselect the previous box, then       

          select the new box
                
                clearSelection $canvas
                set selectedid $boxid
                set selectedtext $text
                $canvas itemconfigure $boxid -outline white
                return
            }
        }
        proc processClick {canvas x y} {
            # determine whether the user has clicked on        
            #something; if so, call
            # proc handleSelection
            set id [$canvas find overlapping $x $y $x $y]
            if {[llength $id] > 0} {
                handleSelection $canvas [lindex $id 0]
            }
        }
        set win [toplevel .demo]
        wm title $win "Random Poetry Chalkboard"
        set canvas [canvas $win.canvas]
        pack $canvas  -expand 1 -fill both
        bind $canvas <Button-1> [list processClick %W %x %y]
        set state 1
        proc mahjongstyle { state } {
            global coloritem canvas details
            set coloritem darkgreen
            set details {
                Mahjong-style deletion.
                press in succession two tiles                  

   with the same text.
                both tiles should be deleted.
                The Mahjong-style deletion is for
                the right mouse press.}}
        console hide
        mahjongstyle { $state }
        populateCanvas $canvas 6 10
        set selectedid ""
        set selectedtext ""
                    set maxX 320
                    set maxY 240
                    set y      0
                    set x1 120
                    set x2 150
                    set y1  50
                    set y2  80
     canvas  .cv -width $maxX -height $maxY  -bg darkgreen