Mahjong_Style_Deletion

Mahjong_Style_Deletion

This page is under development. Comments are welcome, but please load any comments at the bottom of the page. Thanks, gold


This page uses Tcl8.5 for windows to develop Mahjong_Style_Deletion . (note: file is working in 8.5,but you might try saving in ANSCII, if you get a glyph compiler error ) This original code was provided by aricb on the Wiki Ask page. Probably could start a wiki page, since it is a good baby game engine for Mahjong style games. I added a few buttons at the bottom and tried to keep the clean code separate up top.

In developing a computer program or application, it is helpful to develop analogs for the individual tasks of the application.


Pretty Print Version

        # test indent from ased editor
        # written on Windows XP on eTCL
        # working under TCL version 8.5.6 and eTCL 1.0.1
        # gold on TCL WIKI 
        #!/usr/bin/env wish
        package require Tk
         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}
            set labels {one two three four}
            # draw the boxes
            for {set row 0} {$row < $rows} {incr row} {
                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 $labels [expr {int(rand() * [llength $labels])}]]
                    # 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 "Mahjong-style deletion"
        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 gray
            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.}
   $canvas create window 15 210 -window [button $canvas.r -width 10 -text report \
      -bg $coloritem    -command {tk_messageBox -message $details}]
   $canvas create window 30 230 -window [button $canvas.c -width 10 -height 1 -text exit \
   -bg $coloritem     -command {exit }]    
     }
        mahjongstyle { $state }
        populateCanvas $canvas 4 5
        set selectedid ""
        set selectedtext ""
        console hide

Screenshots

WikiDbImage TCL_wiki_Mahjong_Style_Deletion.PNG

test of offsite image retrieval

Screenshots Section

figure 1.

figure 2.

figure 3.

Comments

Please place any comments here, Thanks.

gold Change:Redundant procedure ? deleted.


References


Appendices

Tables

Auxiliary Programs

mahjong style deletion in tcl,jan20,2009

This question has been pretty well answered and closed out. I have posted the answer etc in a new wiki page. Thanks,gold

 [aricb] 2009-1-23: Does the following code do what you have in mind?

aricb The code doesn't use any special 8.5 features. It sounds like the script got corrupted either while you were pasting it or when you converted it to Unicode. I would copy and save the script one more time (I assume you know to do this with a text editor rather than a word processor). Save it using your default system encoding or UTF-8 (don't use any other Unicode encoding than UTF-8). Look at the saved code, possibly with a different program than the editor you used to save it, to make sure it hasn't been corrupted.

  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}
    set labels {one two three four}
    
    # draw the boxes
    for {set row 0} {$row < $rows} {incr row} {
      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 $labels [expr {int(rand() * [llength $labels])}]]
        
        # 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 "Mahjong-style deletion?"
  set canvas [canvas $win.canvas]
  pack $canvas -expand 1 -fill both
  bind $canvas <Button-1> [list processClick %W %x %y]
  
  populateCanv