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

 # demo5-EEG.tcl - HaJo Gurt - 2005-12-20 - http://wiki.tcl.tk/15146
 #: Demo - Toy-EEG: draw dots on head, colored according to data-values

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

  package require Tk


  proc ReadFile {fn} {
  #: Read + parse datafile
  # Format of data (no tabs!) :
  # "0001  a  b  d  t   0  0  x  y   a  a  b  b   d  d  t  t"
    global Data P0

   #puts "fn: $fn"		;##
    set i 0
    set Comment 0
    set nData 0

    # Read file one line at a time:
    set fp [open $fn r]
    fconfigure $fp -buffering line
    gets $fp Line
    while {$Line != ""} {
      incr i 1
     #puts "$i: $Line"	;##
      set Line [string trim $Line]
      switch  -- [string index $Line 0] {
        #        {incr Comment 1}
        default  { incr nData 1
                   set w 0
                   set D {}
                   foreach Word [split $Line " "] {
                     if { $Word != ""} {
                       if { $w == 0} {
                         set Key $Word
                       } else {
                        #puts "$w '$Word'"	;##
                         set Val grey
                         catch { set Val $::ColorTab($Word) }
                         lappend D $Val
                       }
                       incr w 1
                     }
                   }

                   set Data($nData) $D
                  #puts "#>  $Key: '$D'"	;##
                 }
       } ;#switch

       gets $fp Line
    } ;#while
    close $fp
    puts "#EOF: $nData = [array size Data]"	;##
    return [array size Data]
  }


 #
 # Routines to draw heads and set up their dot-arrangement:
 #

  proc ReadPic {w fn} {
  #: Read imagefile, put image on canvas
    global im1
    set midX [expr { $::maxX / 2 }]
    set midY [expr { $::maxY / 2 }]

    catch {image delete $im1}
    set im1 [image create photo -file $fn]
    $w create image $midX $midY -image $im1 -tags "all img"
  }

  proc DrawDots {w} {
  #: Same arrangement of dots as for head2
    set i 0
    foreach {x1 y1} { 50  70    80  70   110  70   140  70
                      50 100    80 100   110 100   140 100
                      50 130    80 130   110 130   140 130
                      50 160    80 160   110 160   140 160 } {
      incr i 1
      set x2 [expr { $x1 + 15 }]
      set y2 [expr { $y1 + 15 }]
      $w create oval  $x1 $y1  $x2 $y2  -fill white -tags "all Dot$i"
    }
  }

  proc DrawHead1 {w} {
  #: Draw a round head, as viewed from above
    set x1  20
    set y1  40   ;# 120-80=40
    set x2 [expr { $x1 + 160 }]
    set y2 [expr { $y1 + 160 }]
    $w create oval  $x1 $y1  $x2 $y2  -tags "all Head1"
   # Nose up:
    $w create line  [expr { $x1 + 69 }] [expr { $y1 +  1 }] \
                    [expr { $x1 + 80 }] [expr { $y1 - 10 }]  -tags "all Head1"
    $w create line  [expr { $x1 + 80 }] [expr { $y1 - 10 }] \
                    [expr { $x1 + 91 }] [expr { $y1 +  1 }]  -tags "all Head1"
   # Ears:
    $w create rect  [expr { $x1 -  2 }] [expr { $y1 + 70 }] \
                    [expr { $x1 +  2 }] [expr { $y1 + 90 }]  -tags "all Head1"
    $w create rect  [expr { $x1 +158 }] [expr { $y1 + 70 }] \
                    [expr { $x1 +162 }] [expr { $y1 + 90 }]  -tags "all Head1"

   # Only some dots on this head:
    foreach {nr x1 y1} { Dot5  50  70   Dot6  80  70
                         Dot7 110  70   Dot8 140  70 } {
      set x2 [expr { $x1 + 15 }]
      set y2 [expr { $y1 + 15 }]
      $w create oval  $x1 $y1  $x2 $y2  -fill white -tags "all $nr"
    }
  }

  proc DrawHead2 {w} {
  #: Draw oval head, side view
    set x1  20
    set y1  20   ;# 120-100=20
    set x2 [expr { $x1 + 160 }]
    set y2 [expr { $y1 + 200 }]
    $w create oval  $x1 $y1  $x2 $y2  -tags "all Head2"
   # Nose on left:
    $w create line  [expr { $x1 +  4 }] [expr { $y1 + 70 }] \
                    [expr { $x1 - 10 }] [expr { $y1 +120 }]  -tags "all Head2"
    $w create line  [expr { $x1 - 10 }] [expr { $y1 +120 }] \
                    [expr { $x1 +  4 }] [expr { $y1 +121 }]  -tags "all Head2"

  # Create a grid of dots:
    set i 0
    foreach {x1 y1} { 50  70    80  70   110  70   140  70
                      50 100    80 100   110 100   140 100
                      50 130    80 130   110 130   140 130
                      50 160    80 160   110 160   140 160 } {
      incr i 1
      set x2 [expr { $x1 + 15 }]
      set y2 [expr { $y1 + 15 }]
      $w create oval  $x1 $y1  $x2 $y2  -fill white -tags "all Dot$i"
    }
  }

  proc DrawHead3 {w} {
  #: Draw oval head, side view
   #set x1 380
    set x1  20
    set y1  20   ;# 120-100=20
    set x2 [expr { $x1 + 160 }]
    set y2 [expr { $y1 + 200 }]
    $w create oval  $x1 $y1  $x2 $y2  -tags "all Head3"
   # Nose on right:
    $w create line  [expr { $x1 +156 }] [expr { $y1 + 70 }] \
                    [expr { $x1 +170 }] [expr { $y1 +120 }]  -tags "all Head3"
    $w create line  [expr { $x1 +170 }] [expr { $y1 +120 }] \
                    [expr { $x1 +156 }] [expr { $y1 +121 }]  -tags "all Head3"

  # Grid of dots:
    set i 0
    foreach {x1 y1} {140  70   110  70    80  70    50  70
                     140 100   110 100    80 100    50 100
                     140 130   110 130    80 130    50 130
                     140 160   110 160    80 160    50 160 } {
      incr i 1
      set x2 [expr { $x1 + 15 }]
      set y2 [expr { $y1 + 15 }]
      $w create oval  $x1 $y1  $x2 $y2  -fill white -tags "all Dot$i"
    }
  }


 #
 # Routines to change the color of dots:
 #

  proc ClrCanvas {} {
  #: Clear all canvas
    foreach {w} {.cA .cB .cC .cD} { $w delete "all" }
  }

  proc ColorAllDots {c} {
  #: Set all dots to the same color c
    for { set i 1 } { $i <= 16 } { incr i 1 } {
      foreach {w} {.cA .cB .cC .cD} { $w itemconfig Dot$i -fill $c }
    }
  }

  proc ColorDots {Colors} {
  #: Set all dots to the colors in array Colors
    ColorAllDots white
    set i 0
    foreach c $Colors {
      incr i 1
      foreach {w} {.cA .cB .cC .cD} { $w itemconfig Dot$i -fill $c }
    }
  }

  proc NextSample {inc} {
  #: Show next sample from data-array, with range-check
    global Data P0
    set P $P0
    if {[catch {incr P $inc}]} { bell; return }

    set x [array get Data $P]
   #puts "x: $x" ;##
    if {$x ==""} {
      bell
      return 1	;# Error
    } else {	;# ok:
      set P0 $P
      ColorDots $Data($P0)
      return 0
    }
  }

  # Repeating timer:
  proc every {ms body} {eval $body; after $ms [info level 0]}

  proc StartAnimation {} {
  #: Show data from data-array as animation
      every 100 { NextSample +1 }
  # ?? automatic stop at end of data ??
  }

  proc StopAnimation {} {
  #: Reset all 'every' timers
      foreach id [after info] {after cancel $id}
  }

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

  proc Init {} {
  #: Init. values, Build GUI
    global maxX maxY Data P0 ColorTab Color P1 P2

    set maxX  200
    set maxY  240

    array set ColorTab { a red  b yellow  d green  t blue  0 white  x grey }
    set Color blue

    set Data(0) {}
    set P0 NoData

    set P1 {red  yellow blue green  grey
            pink yellow cyan green2 grey25
            red2 yellow blue green4 grey50 orange}
    set P2 {OrangeRed2 red tomato pink salmon
            orange goldenrod bisque yellow
            cyan SteelBlue1 blue green green4
            magenta grey white black}

    frame .f1
    frame .f2
    frame .f3
    frame .f4
    pack .f1 .f2  .f3 .f4

   #canvas .cA -width $maxX -height $maxY  -bg white
    foreach {w} {.cA .cB .cC .cD} { canvas $w -width $maxX -height $maxY  -bg white }
    pack   .cA .cB -in .f1 -side left
    pack   .cC .cD -in .f2 -side left

    button .b1 -text "Clear"     -command { ClrCanvas }
    button .b2 -text "Image"     -command { ReadPic   .cA "stampr1.gif" }
    button .b3 -text "Dots"      -command { DrawDots  .cA }
    button .b4 -text "Heads"     -command { DrawHead1 .cB; DrawHead2 .cC; DrawHead3 .cD }
    label  .-
   #button .b5 -text "Dot1"      -command { .cA itemconfig Dot1 -fill $Color }
    button .b5 -text "AllDots"   -command { ColorAllDots $Color}
    button .b6 -text "Pattern1"  -command { ColorDots $P1}
    button .b7 -text "Pattern2"  -command { ColorDots $P2}
    label  .nr -textvar P0
    button .bF -text "Read File" -command { set P0 [ReadFile "eeg1.txt"] }
    button .b0 -text "Reset"     -command { set P0 0; NextSample 0 }
    button .b- -text " - "       -command { NextSample -1 }
    button .b+ -text " + "       -command { NextSample +1 }
    button .bA -text "Play"      -command { StartAnimation }
    button .bS -text "Stop"      -command { StopAnimation  }
    pack .b1 .b2 .b3 .b4 .-  .b5 .b6 .b7  -in .f3  -side left -padx 2
    pack .bF .b0 .b- .nr .b+ .bA .bS      -in .f4  -side left -padx 2
  }


 #
 #: Main :
 #

  Init
  ReadPic   .cA "stampr1.gif"
  DrawDots  .cA
  DrawHead1 .cB  ;# Nose up
  DrawHead2 .cC  ;# Nose left
  DrawHead3 .cD  ;# Nose right

 ### Debug:
  proc int x  { expr int($x) }
  bind .cD <Motion> {wm title . [int [%W canvasx %x]],[int [%W canvasy %y]]}
  bind .cA <Motion> {wm title . [.cA itemcget current -tag ] }

 #catch {console show}
 #set c a;  puts "$c : $ColorTab($c)"

 #.
----
[Category Toys]