sim_pin

#!/usr/bin/wish

if [catch {package require Hal} msg] {
  puts "\nProblem: $msg"
  puts "Is linuxcnc installed?"
  puts "If using Run-In-Place build, source scripts/rip-environment first"
  exit 1
}

proc usage {} {
  puts "
  Usage:
         $::SP(progname) name1 \[name2 ...\] &

  Note:  LinuxCNC (or a standalone Hal application) must be running
         A named item can specify a pin, param, or signal
         The item must be writable, e.g.:
            pin:    IN or I/O (and not connected to a signal)
            param:  RW
            signal: connected to a writable pin

         Hal item types bit,s32,u32,float are supported

         When a bit item is specifed, a pushbutton is created
         to manage the item in one of three manners specified
         by radio buttons:
             toggle: Toggle value when button pressed
             pulse:  Pulse item to 1 once when button pressed
             hold:   Set to 1 while button pressed
         The bit pushbutton mode can be specifed on the command
         line by formatting the item name:
             namei/mode=\[toggle | pulse | hold\]
"
  exit 1
} ;# usage

proc add_item_to_gui {id itemname} {
  set l [split $itemname /]
  set itemname [lindex $l 0]
  set itemargs [lindex $l 1]
  if { [string first "mode=" "$itemargs"] == 0} {
    set ::SP($id,mode) [string tolower [lindex [split $itemargs =] 1]]
  } else {
    set ::SP($id,mode) "default"
  }

  set ::SP($id,itemname) $itemname
  if ![item_info $itemname $id] {
    puts "$::SP(message)"
    return 0
  } else {
    puts "$::SP(message)"
  }

  if {   ![info exists ::SP(vframe)] \
      || ($::SP(vframe,ct) >= $::SP(vframe,vct)) } {
    set ::SP(vframe,ct) 0
    incr ::SP(vframe,column)
    set ::SP(vframe) [frame .vf-$::SP(vframe,column)]
    pack $::SP(vframe) -side left -fill both -expand 1
  }
  incr ::SP(vframe,ct)

  set vf $::SP(vframe)
  set f [frame ${vf}.f$id -borderwidth 3 -relief ridge]
  pack [label $f.hdr -bg lightgray -fg blue \
       -borderwidth 0 -relief raised \
       -text "$::SP($id,itemname)"] \
       -fill x -expand 1

  switch $::SP($id,itemtype) {
    bit   {add_bit_item_to_gui $f $id}
    s32 -
    u32   {add_number_item_to_gui $f $id 1}
    float {add_number_item_to_gui $f $id 0}
    default {return -code error \
        "add_item_to_gui: unexpected itemtype <$::SP($id,itemtype)>"
    }
  }
  return 1
} ;# add_item_to_gui

proc add_bit_item_to_gui {f id} {
  switch $::SP($id,mode) {
    pulse   -
    hold    -
    toggle  {}
    default {
      if {"$::SP($id,mode)" != "default"} {
        puts "$::SP($id,itemname): unknown </mode=$::SP($id,mode)>,\
              using /mode=$::SP(bit,mode,default)"
      }
      set ::SP($id,mode) $::SP(bit,mode,default)
    }
  }
  set value [get_item $id]
  set color lightgray
  if $value {set color magenta}
  pack [label $f.b \
       -text "$::SP($::SP($id,mode),text)" \
       -borderwidth 4 -relief raised ] \
       -fill x -expand 1
  set ::SP($id,button) $f.b
  bind $::SP($id,button) <ButtonRelease-1> [list b_release $id]
  bind $::SP($id,button) <ButtonPress-1>   [list b_press   $id]

  set ::SP($id,ivalue) "$value"
  pack [label $f.l -bg $color -fg black \
       -text "$::SP(iprefix)$::SP($id,ivalue) $::SP(prefix)$value"] \
       -fill x -expand 1
  set ::SP($id,label) $f.l

  pack [radiobutton $f.p -text OnePulse \
       -anchor w \
       -value "pulse" \
       -command [list bit_mode $id] \
       -variable ::SP($id,mode)] \
       -fill x -expand 0
  pack [radiobutton $f.t -text ToggleValue \
       -anchor w \
       -value "toggle" \
       -command [list bit_mode $id] \
       -variable ::SP($id,mode)] \
       -fill x -expand 0
  pack [radiobutton $f.h -text "1 WhilePressed" \
       -anchor w \
       -value "hold" \
       -command [list bit_mode $id] \
       -variable ::SP($id,mode)] \
       -fill x -expand 0
   pack $f -side top -fill x -expand 0
} ;# add_bit_item_to_gui

proc add_number_item_to_gui {f id enable_plusminus} {
  set value [get_item $id]
  set color lightgray
  pack [frame $f.one] -fill x -expand 1
  pack [button $f.one.b  -bg $color -fg black \
       -text "Set    " \
       -relief raised -bd 3 \
       -command [list b_press $id] ]\
       -side left -fill x -expand 1

  if $enable_plusminus {
    pack [button $f.one.p  -bg $color -fg black \
       -text "+" \
       -relief raised -bd 3 \
       -command [list plus_number_item $id] ]\
       -side left -fill x -expand 1

    pack [button $f.one.m  -bg $color -fg black \
       -text "-" \
       -relief raised -bd 3 \
       -command [list minus_number_item $id] ]\
       -side left -fill x -expand 1
  }

  pack [button $f.one.r  -bg $color -fg black \
       -text "Reset" \
       -relief raised -bd 3 \
       -command [list reset_number_item $id] ]\
       -side left -fill x -expand 1
  set e [entry $f.e \
       -justify right \
       -textvariable ::SP($id,entry)]
  pack $e -fill x -expand 0
  bind $e <Return> [list b_press $id]

  set ::SP($id,ivalue) "$value"
  pack [label $f.l -bg $color -fg black \
       -anchor w \
       -text "$::SP(iprefix)$::SP($id,ivalue) $::SP(prefix)$value"] \
       -fill x -expand 1
  set ::SP($id,label) $f.l
  pack $f -side top -fill x -expand 0
} ;# add_number_item_to_gui

proc exact_name {name line} {
  set idx [string first $name $line]
  if {$idx < 0} {return 0}
  if {0 == [string compare $name [string range $line $idx end]]} {
    return 1
  }
  return 0
} ;# exact_name

proc connected_to {name line} {
  # check if an input pin is already connected to a signal
  # since it does not necessarily have a writer
  set idx [string first $name $line]
  if {$idx < 0} {return ""}
  # check if pin is an input
  if {-1 != [string first "$name <==" [string range $line $idx end]]} {
    set idx [string first "<==" $line]
    set signame [string range $line [expr 4 + $idx] end]
    return  "$signame"
  }
  return ""
} ;# connected_to

proc item_info {itemname id} {
  set fmt "sim_pin: %-30s %5s %3s %s"
  set theitem "-----"
  set dir "---"
  set found 0

  # try pin:
  set answer [hal show pin "$itemname"]
  set lines [split $answer \n]
  set lines [lreplace $lines 0 1] ;# discard header lines
  # look for exact match (hal show will present all matching leading part)
  foreach line $lines {
    if {"$line" == ""} continue
    if [exact_name $itemname $line] {
      set found 1
      set theitem "PIN"
      break
    }
    set signame [connected_to $itemname $line]
    if {"" !=  "$signame"} {
      puts "pin <$itemname> is already connected, trying signal:<$signame>"
      set itemname $signame
      set ::SP($id,itemname) $itemname
    }
  }
  if !$found {
    # try param:
    set answer [hal show param "$itemname"]
    set lines [split $answer \n]
    set lines [lreplace $lines 0 1] ;# discard header lines
    # look for exact match (hal show will present all matching leading part)
    foreach line $lines {
      if {"$line" == ""} continue
      if [exact_name $itemname $line] {
        set found 1
        set theitem "PARAM"
        break
      }
    }
  }
  if !$found {
    # try signal:
    set answer [hal show signal "$itemname"]
    set lines [split $answer \n]
    set lines [lreplace $lines 0 1] ;# discard header lines
    # look for exact match (hal show will present all matching leading part)
    foreach line $lines {
      if {"$line" == ""} continue
      if [exact_name $itemname $line] {
        set found 1
        scan $line "%s %s" sigtype other
        switch $sigtype {
          bit -
          u32 -
          s32 -
          float {set theitem SIG}
          default {
            set ::SP(message) \
                "Unknown type for signal item <$id $::SP($id,itemname) $sigtype>"
            return 0
          }
        }
        break
      }
    }
  }
  if !$found {
    set ::SP(message) "Unknown item: $::SP($id,itemname)"
    return 0
  }
  switch $theitem {
    PIN -
    PARAM {
      scan $line "%d %s %s %s %s %s %s" owner type dir value name arrows signalname
      if {    ("$dir" == "IN") || ("$dir" == "I/O") || "$dir" == "RW"} {
        if [info exists arrows] {
          set ::SP(message) [format $fmt \
              $itemname $theitem $dir "not writable (connected to signal)"]
          return 0
        } else {
          #puts "OK <$dir> $line"
        }
      } else {
        set ::SP(message) [format $fmt \
            $itemname $theitem $dir "not writable"]
        return 0
      }
    }
    SIG {
      set sig_header_ct 0
      foreach line $lines {
        if {   ([string first "<==" $line] < 0) \
            && ([string first "==>" $line] < 0) \
        } {
          incr sig_header_ct
        }
        if {[string first "<==" $line] >= 0} {
           set has_writer 1
        }
      }
      if {$sig_header_ct > 4} {
        # wild cards not supported:
        set ::SP(message) "Unknown item: $::SP($id,itemname)"
        return 0
      }
      if [info exists has_writer] {
        set ::SP(message) [format $fmt \
            $itemname $theitem $dir "signal has writer"]
        return 0
      } else {
        set theitem "SIG"
        set is_signal 1
      }
    }
  }

  if [info exists is_signal] {
    set ::SP($id,itemtype) $sigtype
    set ::SP($id,set_cmd) sets
    set ::SP($id,get_cmd) gets
  } else {
    set ::SP($id,itemtype) [hal ptype $itemname]
    set ::SP($id,set_cmd) setp
    set ::SP($id,get_cmd) getp
  }
  set ::SP(message) [format $fmt $itemname $theitem $dir ""]
  return 1 ;# ok
} ;# item_info

proc bit_mode {id} {
  switch $::SP($id,mode) {
    pulse   {$::SP($id,button) config -text Pulse}
    hold    {$::SP($id,button) config -text "1 while pressed"}
    toggle  -
    default {$::SP($id,button) config -text Toggle}
  }
} ;# bit_mode

proc item_set {id {new_value 0}} {
  if [catch {
    switch $::SP($id,itemtype) {
      bit {hal $::SP($id,set_cmd) $::SP($id,itemname) 1}
      s32 -
      u32 -
      float {hal $::SP($id,set_cmd) $::SP($id,itemname) $new_value}
    }
  } msg ] {
    popup $msg
    return
  }
  item_show $id
} ;# item_set

proc item_unset {id} {
  if [catch {hal $::SP($id,set_cmd) $::SP($id,itemname) 0} msg] {
    popup $msg
  }
  set value [get_item $id]
  set color lightgray
  if $value {set color magenta}
  $::SP($id,label) configure -bg $color -fg black \
       -text "$::SP(iprefix)$::SP($id,ivalue) $::SP(prefix)$value"
} ;# item_unset

proc item_show {id} {
  set value [get_item $id]
  set color lightgray
  if {$value != $::SP($id,ivalue)}  {set color magenta}
  switch $::SP($id,itemtype) {
    bit {
          $::SP($id,label) configure -bg $color \
       -text "$::SP(iprefix)$::SP($id,ivalue) $::SP(prefix)$value"
    }
    s32 - \
    u32 - \
    float {$::SP($id,label) configure -bg $color -fg black \
       -text "$::SP(iprefix)$::SP($id,ivalue) $::SP(prefix)$value"
    }
  }
} ;# item_show

proc b_press {id} {
  set value [get_item $id]
  switch $::SP($id,itemtype) {
    bit {switch $::SP($id,mode) {
          "hold"   {item_set $id}
          "toggle" {   if $value {
                         item_unset $id
                       } else {
                         item_set $id
                       }
                   }
          "pulse"  {item_set $id; after $::SP(pulse,ms) [list b_release $id]}
          }
        }
    s32 - \
    u32 - \
    float {
      set e $::SP($id,entry)
      if ![isnumber $e] {
        popup "Number required (not <$e>)"
        set ::SP($id,entry) ""
        return
      }

      # Note: halcmd rejects numbers formatted 'nEmm' for s32, u32

      if {   (($::SP($id,itemtype) == "s32") || ($::SP($id,itemtype) == "u32")) \
          && ![isinteger $e]} {
        popup "Integer required for u32,s32 entry (not <$e>)"
        return
      }
      if {   ($::SP($id,itemtype) == "u32") \
          && [isnegative $e]} {
        popup "Nonnegative Integer required for u32 entry (not <$e>)"
        return
      }
      item_set $id $e
    }
    default {return -code error \
        "b_press: unknown pin type <$::SP($id,itemtype)> for $::SP($id,itemname)"
    }
  }
} ;# b_press

proc b_release {id} {
  switch $::SP($id,mode) {
    "hold"   {item_unset $id}
    "toggle" {}
    "pulse"  {item_unset $id}
  }
} ;# b_release

proc reset_number_item {id} {
  item_set $id $::SP($id,ivalue)
} ;# reset_number_item

proc plus_number_item {id} {
  item_set $id [expr 1 + [get_item $id]]
} ;# plus_number_item

proc minus_number_item {id} {
  item_set $id [expr -1 + [get_item $id]]
} ;# minus_number_item

proc get_item {id} {
  set value [hal $::SP($id,get_cmd) $::SP($id,itemname)]
  switch $::SP($id,itemtype) {
    bit {
      switch $value {
        FALSE {return 0}
        TRUE  {return 1}
      }
    }
    s32 -
    u32 -
    float   {return $value}
    default {return -code error \
        "get_item: unknown item type <$::SP($id,itemtype)> for $::SP($id,itemname)"
    }
  }
} ;# get_item

proc update_current_values {} {
  for {set id 0} {$id < $::SP(id)} {incr id} {
     item_show $id
  }
  after $::SP(update,ms) update_current_values
} ;# update_current_values

proc isinteger {v} {
  if ![isnumber $v]            {return 0}
  if {[string first . $v] >=0} {return 0}
  if {[string first e [string tolower $v]] >= 0} {return 0}
  return 1
} ;# isinteger

proc isnumber {v} {
  if [catch {format %f $v}] {
    return 0
  } else {
    return 1
  }
} ;# isnumber

proc isnegative {v} {
  # Note:check with isnumber before this
  if {[format %f $v] < 0} {return 1}
  return 0
} ;# isnegative

proc popup msg {
  tk_messageBox \
    -type ok \
    -title "$::SP(progname): Problem" \
    -message $msg
} ;# popup

if [catch {
  if {[info exists ::argv0] && [info script] == $::argv0} {
    set ::SP(progname) [file tail $::argv0]
    set ::SP(update,ms) 300
    if {$::argv == ""} {usage}

    set ::SP(bit,mode,default) toggle
    # button text for bit item modes:
    set ::SP(pulse,text)  "Pulse"
    set ::SP(hold,text)   "1 while Pressed"
    set ::SP(toggle,text) "Toggle"

    set ::SP(id) 0
    set ::SP(vframe,column) 0
    set ::SP(vframe,vct) 4         ;# howmany items in a column
    set ::SP(iprefix) "Initial="   ;# initial value prefix
    set ::SP(prefix) "Current="    ;# current value prefix
    set ::SP(pulse,ms) 200         ;# pulse duration
    wm title . $::SP(progname)

    foreach itemname $::argv {
      if [add_item_to_gui $::SP(id) $itemname] {
        incr ::SP(id)
      }
    }
    if {$::SP(id) < 1} usage
    update_current_values
  }
} msg] {
  puts "\nError: $msg"
  usage
}