sics/hakle.tcl

#----------------------------------------------------------------------------
#                            H A K L E
#
# Driver for the Haake water bath thermostat in the SINQ setup. This driver
# is realised in Tcl and uses the tclev interface for talking to SICS.
#
# copyright: see copyright.h
#
# Mark Koennecke, February 1998
#----------------------------------------------------------------------------
set HakleNUM 0

proc HakleSend args {
     upvar #0 [lindex $args 0] ar
     set command [lrange $args 1 end]
     set ret [catch {$ar(socket) $command} msg]
     if {$ret != 0} {
        ClientPut $msg
        error -701
     } 
     return $msg
}
#--------------------------------------------------------------------------
# HakleCheck tests a answer from the Hake for validity. Valid answers
# contain a $. Errors no $ and and F as first character. 
proc HakleCheck {text } {
     if { [string match *\$ $text]} {
       return 1
     }
     if { [string match F* $text] } {
      error -703
     }
}
#---------------------------------------------------------------------------
proc HakleCommand args { 
     upvar #0 [lindex $args 0] ar
     set ret [catch {eval HakleSend $args} msg]
     if {$ret != 0} {
        error $msg
     } 
     set ret [catch {HakleCheck $msg} msg2]
     if {$ret != 0} {
        error $msg2
     }
     return $msg
}
#----------------------------------------------------------------------------
proc HakleInit {Hakle} {
     upvar $Hakle ar
     global HakleNUM 
#------ open a connection
     set nam hakle$HakleNUM
     set ret [catch {serialport $nam $ar(computer) $ar(port) \
             $ar(channel) 1} msg]
     if {$ret != 0 } {
        ClientPut $msg
        error -700
     } 
     set ar(socket) $nam
     incr HakleNUM
     set ar(intern) 1
     set ar(pending) 0
     set ar(lastread) 20.00
#----- configure
     $nam -replyterm "1\r"
     $nam -tmo 1800
#----- block local
     set ret [catch {HakleCommand $Hakle OUT MODE 3 0} msg ]
     if {$ret != 0 } {
        error -$msg
     } 
    return 1
}
#---------------------------------------------------------------------------
proc HakleClose {Hakle} {
     upvar #0 $Hakle ar
     set ret [catch {HakleCommand $Hakle OUT MODE 3 1} msg]
     if {$ret != 0} {
        ClientPut "Error resettting Haake Thermostat"
     }
     rename $ar(socket) ""
     return 1
}
#----------------------------------------------------------------------------
proc HakleWrapper args {
     upvar #0 [lindex $args 0] ar
     if { [llength $args] < 2 } {
        error "Insufficient number of commands"
     }
     set key [lindex $args 1]
     switch -exact $key {
        sensor {
          if { [llength $args] > 2 } {
             set val [lindex $args 2]
#------- switch to intern
             if { [string compare $val intern] == 0 } {
               set ret [catch {HakleCommand [lindex $args 0] OUT MODE 2 0} msg]
               if {$ret != 0 } {
                   error $msg
                } else {
                  set ar(intern) 1
             }
#-------- switch to extern
             } elseif { [string compare $val extern] == 0 } {
               set ret [catch {HakleCommand [lindex $args 0] OUT MODE 2 1} msg]
               if {$ret != 0 } {
                   error $msg
               } else {
                  set ar(intern) 0
               }
             } else {
               error -705
             }
          } else {
            if { $ar(intern) == 1 } {
               ClientPut [format "%s.sensor intern" $ar(MyName)]
               return 1
            } else {
               ClientPut [format "%s.sensor extern" $ar(MyName)]
               return 1
            } 
          }
        }
        list {
            if { $ar(intern) == 1 } {
               ClientPut [format "%s.sensor intern" $ar(MyName)]
               error -700
            } else {
               ClientPut [format "%s.sensor extern" $ar(MyName)]
               error -700
            } 

        }
        default {
                error -700
        }
     }
}
#----------------------------------------------------------------------------
proc HakleSet {Hakle val} {
     upvar #0 $Hakle ar
#     ClientPut "HakleSet"
     set ret [catch {$ar(socket) [format "OUT SP 1   %f" $val]} msg]
     if {$ret != 0} {
        ClientPut $msg
        error -701
     } 
     set ret [catch {HakleCheck $msg} msg2]
     if {$ret != 0} {
        error $msg2
     }
     set ar(pending) 0
     return $msg
}
#----------------------------------------------------------------------------
proc HakleGet {Hakle} {
     upvar #0 $Hakle ar
     if {$ar(intern) == 1} {
        set ret [catch {eval HakleCommand $Hakle IN PV 1} msg]
        if {$ret != 0 } {
          error $msg
         }
     } else {
        set ret [catch {HakleCommand IN PV 2} msg]
        if {$ret != 0 } {
          error $msg
         }
     }
     set ans  [string trim $msg \$]
     set ans2 [string trim $ans]
     set ans3 [string trim $ans2 C]
#------ fix some pecularities of the Haake, sometimes it gives empty
#       messages or double +
     if { [string length $ans3] < 3 } {
        return $ar(lastread)
     } 
     if { [string first "++" $ans3] >= 0 } {
       set ans3 [string range $ans3 1 end]
     }
     set ar(lastread) $ans3
     return $ans3   
}
#----------------------------------------------------------------------------
proc HakleGet2 {Hakle} {
     upvar #0 $Hakle ar
#     ClientPut "HakleGet"
     if {$ar(pending) == 0} {
       if {$ar(intern) == 1} {
          set ret [catch {$ar(socket) -put IN PV 1} msg]
          if {$ret != 0 } {
             ClientPut $msg
             error -701
          }
       } else {
           set ret [catch {$ar(socket) -put IN PV 2} msg]
           if {$ret != 0 } {
              ClientPut $msg
              error -701
           }
       }
       set ar(pending) 1
       return $ar(lastread)
     } else {
         if {[$ar(socket) -readable] == 1 } {
            set ar(pending) 0
            set ret [catch {$ar(socket) -get} msg]
            if {$ret != 0 } { 
               ClientPut $msg
               error -701
            }
            set ans  [string trim $msg \$]
            set ans2 [string trim $ans]
            set ans3 [string trim $ans2 C]
            set ar(lastread) $ans3
            return $ans3
         } else {
            return $ar(lastread)
         }
     }   
}
#-----------------------------------------------------------------------------
proc HakleError {Hakle val} {
     upvar #0 $Hakle ar
     switch -exact -- $val {
        -700 {
           return "Cannot open socket"
        }
        -701 {
           return "Error sending command"
        }
        -703 {
           return "Invalid command sent"
        }
        default {
           return "Unknown error code"
        }
     } 
}
#-----------------------------------------------------------------------------
proc HakleFix {Hakle val} {
     upvar #0 $Hakle ar
     switch -exact -- $val {
        -700 {
           return DEVFAIL
        }
        -701 {
             return DEVREDO
         }
        -703 {
           return DEVREDO
        }
        default {
           return DEVFAIL
        }
     } 
}
#----------------------------------------------------------------------------
proc inihaakearray {ar comp port chan} {
     upvar #0 $ar Hakle
     set Hakle(Init) HakleInit
     set Hakle(Close) HakleClose
     set Hakle(Send)  HakleSend
     set Hakle(SetValue) HakleSet
     set Hakle(GetValue) HakleGet
     set Hakle(GetError) HakleError
     set Hakle(TryFixIt) HakleFix
     set Hakle(Wrapper) HakleWrapper
     set Hakle(computer) $comp
     set Hakle(port)     $port
     set Hakle(channel)  $chan
     set Hakle(num)      0
     set Hakle(lastread) 20.00
}