Updated 2005-12-26 11:39:07

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

 # demo7-EEG.tcl - HaJo Gurt - 2005-12-26 - 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!) :
  #  #### Fz Cz Pz  FP1 FP2  F7 F3 F4 F8  T3 C3 C4 T4  T5 P3 P4 T6  O1 O2 A1 A2
  # "0001  a  a  a    x x    b  b  b  b    d  d  d  d   t  t  t  t   x x   0 0"
    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 "#> $nData $Key: '$D'"	;##
                 }
       } ;#switch

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

 #
 #: 2D-Graphics Operations : affine transforms on a canvas
 #

  set ::pi [expr {atan(1)*4}]
  proc translation {dx dy} {list  1 0 0      1 $dx $dy}
  proc reflect-y   {}      {list  1 0 0     -1 0 0}  ;# ?
  proc reflect-x   {}      {list -1 0 0      1 0 0}  ;# ?
  proc shear       {sx sy} {list  1 $sx $sy  1 0 0}

  proc rotation {angle {units radians}} {
     global pi
     switch -- $units {
        d - de - deg - degr - degre - degree - degrees {
            set angle [expr {double($angle)/180*$pi}]
        }
        g - gr - gra - grad - gradi - gradie - gradien -
        gradient - gradients { # I think I've spelt this one right...
            set angle [expr {double($angle)/200*$pi}]
        }
        r - ra - rad - radi - radia - radian - radians {
           # Do nothing
        }
        default {
           return -code error "unknown angle unit \"$units\": \
                   must be one of degrees, gradients or radians"
        }
     }
     list [expr { cos($angle)}] [expr {sin($angle)}] \
          [expr {-sin($angle)}] [expr {cos($angle)}] 0 0
  }

  proc apply_affine {transform args} {
     if {[llength $args]==1} {set args [lindex $args 0]}
     set result [list]
     foreach {a b c d e f} $transform {break}
     foreach {x y} $args {
        lappend result [expr {$a*$x+$b*$y+$e}] [expr {$c*$x+$d*$y+$f}]
     }
     return $result
  }

  proc combine_affine {transform args} {
     foreach {a b c d e f} $transform {break}
     foreach xform $args {
        foreach {i j k l m n} $xform {break}
        # Next line does simultaneous assignment...
        foreach {a b c d e f} [list \
               [expr {$a*$i+$c*$j}]    [expr {$b*$i+$d*$j}] \
               [expr {$a*$k+$c*$l}]    [expr {$b*$k+$d*$l}] \
               [expr {$e*$i+$f*$j+$m}] [expr {$e*$k+$f*$l+$n}]] {break}
     }
     list $a $b $c $d $e $f
  }

 #
 # 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} { 90  80   120  80   150  80   180  80
                      90 110   120 110   150 110   180 110
                      90 140   120 140   150 140   180 140
                      90 170   120 170   150 170   180 170
                      90 200   120 200   150 200   180 200  210 200} {
      set nr [lindex {Fz Cz Pz   FP1 FP2   F7 F3  F4 F8 T3 C3  C4 T4 \
                      T5 P3 P4 T6   O1 O2  A1 A2} $i]
      set xx [expr { $x1 + 15 }]
      set yy [expr { $y1 + 15 }]
      $w create oval  $x1 $y1  $xx $yy  -fill white -tags "all $nr"
      incr i 1
    }
  }

  proc DrawHead1 {w} {
  #: Draw a round head, as viewed from above
    set x1  32
    set y1  40   ;# 120-80=40
    set x2 [expr { $x1 + 220 }]
    set y2 [expr { $y1 + 220 }]
    $w create oval  $x1 $y1  $x2 $y2 -fill $::Fill -tags "all Head1"
   # Nose up:
    $w create poly  [expr { $x1 + 94 }] [expr { $y1 +  1 }] \
                    [expr { $x1 +111 }] [expr { $y1 - 13 }] \
                    [expr { $x1 +111 }] [expr { $y1 - 13 }] \
                    [expr { $x1 +125 }] [expr { $y1 +  1 }] -fill $::Fill -tags "all Head1"
    $w create line  [expr { $x1 + 94 }] [expr { $y1 +  1 }] \
                    [expr { $x1 +111 }] [expr { $y1 - 13 }]  -tags "all Head1"
    $w create line  [expr { $x1 +111 }] [expr { $y1 - 13 }] \
                    [expr { $x1 +125 }] [expr { $y1 +  1 }]  -tags "all Head1"
   # Ears:
    $w create rect  [expr { $x1 -  4 }] [expr { $y1 + 90 }] \
                    [expr { $x1 +  2 }] [expr { $y1 +122 }] -fill $::Fill -tags "all Head1"
    $w create rect  [expr { $x1 +219 }] [expr { $y1 + 90 }] \
                    [expr { $x1 +225 }] [expr { $y1 +122 }] -fill $::Fill -tags "all Head1"

   # Arrangement of dots according to 1020-system:
    foreach {nr x1 y1} {Fz  135  95   Cz  135 142   Pz 135 192
                        FP1 106  60   FP2 166  60
                        F7   66  90   F3  100 100
                        F4  170 100   F8  206  90
                        T3   50 140   C3   90 140
                        C4  185 140   T4  225 140
                        T5   66 195   P3   95 185
                        P4  175 185   T6  205 195
                        O1  108 225   O2  165 225
                        A1   10 130   A2  260 130} {
      set x2 [expr { $x1 + 15 }]
      set y2 [expr { $y1 + 15 }]
      $w create oval  $x1 $y1  $x2 $y2  -fill white -tags "all $nr Head1"

      set xT [expr { $x1 +  8 }]
      set yT [expr { $y1 + 21 }]
      $w create text  $xT $yT  -text $nr -tags "all Head1"
    }
  }

  proc HeadPoints {} {
  #: Create polygon for a head in profile
    lappend H    63 251   65 235   66 220   62 207   50 192 \
                 44 180   35 158   33 139   38 124   48  96 \
                 77  62  106  52  149  47  186  58  205  70 \
                223  93  231 134  226 146  256 180  258 186 \
                240 197  241 214  229 218  243 222  239 228 \
                234 247  213 257  202 262  195 266  190 274
    return $H
  }

  proc DrawHead2 {w} {
  #: Draw oval head, side view
    set x [expr { $::maxX / 2 }]
    set y [expr { $::maxY / 2 }]
    set HeadCoords1 [HeadPoints]
 # puts "HeadCoords1: $HeadCoords1"
   #set xform [reflect-x]
    set xform [combine_affine [translation -$x -$y] [reflect-x] [translation $x $y] ]
     set HeadCoords2 [apply_affine $xform $HeadCoords1]
 # puts "HeadCoords2: $HeadCoords2"
   $w create poly $HeadCoords2 -outline red -fill $::Fill -tags "all Head2" ;# -smooth true

   # Selected dots of 1020-system, as viewed from side:
    foreach {nr x1 y1} {Fz  100  50   Cz  170  45   Pz  230  85
                        FP1  66 106
                        C3  160  80   T3  146 140
                        F3  108  85   F7   98 126
                        P3  208 103   T5  202 150
                        O1  233 145
                        A1  135 200} {
      set x2 [expr { $x1 + 15 }]
      set y2 [expr { $y1 + 15 }]
      $w create oval  $x1 $y1  $x2 $y2  -fill white -tags "all $nr Head2"

      set xT [expr { $x1 +  8 }]
      set yT [expr { $y1 + 20 }]
      $w create text  $xT $yT  -text $nr -tags "all Head2"
    }
  }

  proc DrawHead3 {w} {
  #: Draw oval head, side view
    $w create poly [HeadPoints] -outline black -fill $::Fill -tags "all Head3" ;# -smooth true

    # selected dots of 1020-system, as viewed from side:
    foreach {nr x1 y1} {Fz  180  50   Cz  100  45   Pz  43  88
                        FP2 208 108
                        C4  115  85   T4  130 138
                        P4   66 106   F8  180 120
                        F4  170  85   T6   77 146
                        O2   45 150
                        A2  140 200} {
      set x2 [expr { $x1 + 15 }]
      set y2 [expr { $y1 + 15 }]
      $w create oval  $x1 $y1  $x2 $y2  -fill white -tags "all $nr Head3"

      set xT [expr { $x1 +  8 }]
      set yT [expr { $y1 + 20 }]
      $w create text  $xT $yT  -text $nr -tags "all Head3"
    }
  }

 #########1#########2#########3#########4#########5#########6#########7#####
 #
 # 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
    foreach {nr} {Fz  Cz  Pz
                  FP1 FP2
                  F7  F3  F4  F8
                  T3  C3  C4  T4
                  T5  P3
                  P4  T6
                  O1  O2
                  A1  A2} {
      foreach {w} {.cA .cB .cC .cD} { $w itemconfig $nr -fill $c }
    }
  }

  proc ColorDots {Colors} {
  #: Set all dots to the colors in array Colors
    ColorAllDots white
    set i 0
    foreach {nr} {Fz Cz Pz   FP1 FP2   F7 F3 F4 F8
                  T3 C3 C4 T4   T5 P3 P4 T6   O1 O2 A1 A2} {
      set c [lindex $Colors $i]
      if {$c==""} {set c white}
     #puts "$i $nr: $c" 	;##
      foreach {w} {.cA .cB .cC .cD} { $w itemconfig $nr -fill $c }
      incr i 1
    }
  }

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

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

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

  proc StartAnimation {} {
  #: Show data from data-array as animation
      every 100 { NextSample +1 }
  }

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

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

  proc Init {} {
  #: Initialize values, build GUI
    global maxX maxY Data P0 ColorTab Fill Color P1 P2

    set maxX  290
    set maxY  290

    array set ColorTab { a red  b yellow  d green  t blue  0 white  x grey }
    set Fill  "light yellow" ;# yellow / bisque / bisque2 / wheat1 / tan / gold2
    set Color blue

    set Data(0) {}
    set P0 NoData

    # Fz Cz Pz / FP1 FP2 / F7 F3  F4 F8 /
    # T3 C3  C4 T4 / T5 P3 P4 T6 / O1 O2 / A1 A2
    set P1 {yellow gold goldenrod
            blue                    green4
            cyan SteelBlue1         green2 green
            SteelBlue2 SteelBlue3   aquamarine SeaGreen1
            DodgerBlue3 SteelBlue4  "lime green" "medium sea green"
            magenta                 PaleGreen3
            gray44 gray88
            orange}
    set P2 {OrangeRed2 red tomato
            green4                        blue
            "medium sea green" PaleGreen3 cyan        SteelBlue1
            "lime green" green2           SteelBlue2  SteelBlue3
            aquamarine   SeaGreen1        DodgerBlue3 SteelBlue4
            green                         magenta
            grey 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
   # Alternative Layout:
   #pack   .cB .cD -in .f1 -side left
   #pack   .cA .cC -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 "eeg2.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

    bind . <Key-a>           { ColorAllDots $Color }
    bind . <Key-1>           { ColorDots $P1 }
    bind . <Key-2>           { ColorDots $P2 }
    bind . <Key-r>           { set P0 [ReadFile "eeg2.txt"] }
    bind . <Key-0>           { set P0 0; NextSample 0 }

    bind . <Key-minus>       { NextSample -1  }
    bind . <Key-KP_Subtract> { NextSample -1  }
    bind . <Key-plus>        { NextSample +1  }
    bind . <Key-KP_Add>      { NextSample +1  }
    bind . <Return>          { StartAnimation }
    bind . <Key-space>       { StopAnimation  }

    wm title . "Toy EEG"
    focus -force .
  }

 #
 #: Main :
 #

  Init
  ReadPic   .cA "stampr1.gif"
  DrawDots  .cA
 #ReadPic   .cB "1020top.gif"
 #ReadPic   .cC "1020left.gif"
 #ReadPic   .cD "1020right.gif"

  DrawHead1 .cB  ;# Nose up
  DrawHead2 .cC  ;# Nose left
  DrawHead3 .cD  ;# Nose right

 ### Debug:
  bind .  <F1> { console show }
  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)"
 #puts "P1: $P1"

 #.

Category Toys