Posted to tcl by auriocus at Mon Jun 20 22:53:18 GMT 2016view raw

  1. set mydir [file dirname [info script]]
  2. lappend auto_path $mydir
  3. package require AsynCA
  4. package require snit
  5. package require ukaz
  6.  
  7. source [file join $mydir ddlparser.tcl]
  8.  
  9. DDLParser ddl [ddl_preprocess /home/cgollwit/Programmieren/Messprogramm3/ddl/kmc-include.ddl]
  10.  
  11. proc getPV {devname attrib} {
  12. string trim [ddl get device $devname attributes $attrib PV]
  13. }
  14.  
  15.  
  16. proc connectPV {devname attrib} {
  17. variable conntrigger
  18. set myPV [getPV $devname $attrib]
  19. if {$myPV eq {}} { return }
  20.  
  21. lassign [AsynCA::connectwait $myPV] pv cmd
  22. return $cmd
  23. }
  24.  
  25. snit::type motor {
  26.  
  27. component gotopv
  28. component actpospv
  29. component stoppv
  30. component offpv
  31. variable actpos
  32. variable movedone
  33. variable myname
  34. component movedonepv
  35.  
  36. # store the moving state of all motors
  37. typevariable movingmotors {}
  38.  
  39. typevariable allmotors {}
  40.  
  41. typemethod movingmotors {} {
  42. dict keys [dict filter $movingmotors value 1]
  43. }
  44.  
  45. typemethod waitforall {} {
  46. # wait until all motors are complete with moving
  47. while {[llength [$type movingmotors]] > 0} {
  48. vwait [mytypevar movingmotors]
  49. }
  50. }
  51.  
  52. typemethod motorpositions {} {
  53. # read all motors and return dict
  54. set result {}
  55. dict for {m cmd} $allmotors {
  56. # lazy serial way. Could be sped up with AsynCA::readmultiple
  57. dict set result $m [$cmd read]
  58. }
  59. return $result
  60. }
  61.  
  62. constructor {name} {
  63. install gotopv using connectPV $name gotoPos
  64. install actpospv using connectPV $name actPos
  65. install stoppv using connectPV $name stop
  66. install offpv using connectPV $name offset
  67.  
  68. #install movedonepv using ddl get device $name attributes moveDone PV
  69.  
  70. set myname $name
  71.  
  72. if {$gotopv eq {}} {
  73. error "Don't know how to move >$name<"
  74. }
  75.  
  76. if {$actpospv eq {}} {
  77. error "Don't know how to read the actPos of >$name<"
  78. }
  79.  
  80. dict set allmotors $name $self
  81.  
  82. }
  83.  
  84. destructor {
  85. catch {$gotopv destroy}
  86. catch {$actpospv destroy}
  87. catch {$stoppv destroy}
  88. }
  89.  
  90. method putcallback {where cmd} {
  91. $gotopv put $where -command $cmd
  92. }
  93.  
  94. method goto {where} {
  95. $gotopv put $where -command [mymethod moveready]
  96. dict set movingmotors $myname 1
  97. }
  98.  
  99. method moveready {args} {
  100. dict set movingmotors $myname 0
  101. }
  102.  
  103. method ismoving {} {
  104. dict get $movingmotors $myname
  105. }
  106.  
  107. method read {} {
  108. $actpospv get -command [mymethod readback]
  109. vwait [myvar actpos]
  110. return $actpos
  111. }
  112.  
  113. method readback {pos meta} {
  114. set actpos $pos
  115. }
  116.  
  117. method wait {} {
  118. while {[$self ismoving]} {
  119. vwait [mytypevar movingmotors]
  120. }
  121. }
  122.  
  123. method stop {} {
  124. if {$stoppv eq {}} {
  125. return -code error "Don't know how to stop"
  126. }
  127. $stoppv put 1
  128. }
  129.  
  130. method define {pos1 {pos2 {}}} {
  131. # move the offset such that currenjt pos1 is equal to pos2
  132. if {$pos2 eq {}} {
  133. set pos2 $pos1
  134. set pos1 [$self read]
  135. }
  136.  
  137. set curroff [AsynCA::read $offpv]
  138. set newoff [expr {$curroff+($pos2-$pos1)}]
  139. AsynCA::putwait $offpv $newoff
  140.  
  141. }
  142.  
  143. delegate method monitor to actpospv
  144. }
  145.  
  146.  
  147.  
  148. snit::type detector {
  149. variable triggerpv
  150. variable scanmodepv
  151.  
  152. constructor {name} {
  153. set triggerpv [connectPV $name trigger]
  154. set scanmodepv [connectPV $name scan]
  155. }
  156.  
  157. destructor {
  158. catch {$scanmodepv delete}
  159. catch {$triggerpv delete}
  160. }
  161.  
  162. method trigger {args} {
  163. if {$triggerpv ne {}} {
  164. puts "Trigger device"
  165. $triggerpv put 1 {*}$args
  166. return 1
  167. } else {
  168. puts "Can't trigger"
  169. return 0
  170. }
  171. }
  172.  
  173. method scanmode {mode args} {
  174. if {$scanmodepv ne {}} {
  175. $scanmodepv put $mode {*}$args
  176. }
  177. }
  178. }
  179.  
  180. snit::type channel {
  181. variable value
  182. variable scanmodepv
  183. variable triggerpv
  184. component valuepv
  185. component mama
  186.  
  187. typevariable detectors {}
  188.  
  189. constructor {name} {
  190. set valuepv [connectPV $name value]
  191. if {$valuepv eq {}} { error "Don't know how to read >$name<" }
  192.  
  193. set triggerpv [connectPV $name trigger]
  194. set scanmodepv [connectPV $name scan]
  195.  
  196. set mamaname [ddl get device $name mama]
  197. puts "$name has $mamaname"
  198.  
  199. if {$mamaname ne {}} {
  200. if {[dict exists $detectors $mamaname]} {
  201. install mama using dict get $detectors $mamaname
  202. } else {
  203. install mama using detector $mamaname $mamaname
  204. dict set detectors $mamaname $mama
  205. }
  206. }
  207.  
  208. }
  209.  
  210. destructor {
  211. catch {$triggerpv delete}
  212. catch {$scanmodepv delete}
  213. catch {$valuepv delete}
  214. }
  215.  
  216. method trigger {args} {
  217. if {$triggerpv eq {}} {
  218. if {$mama eq {}} {
  219. puts "Trigger ignored (can't trigger)"
  220. return 0
  221. } else {
  222. puts "Trigger mama $mama"
  223. return [$mama trigger {*}$args]
  224. }
  225. } else {
  226. puts "Trigger me"
  227. $triggerpv put 1 {*}$args
  228. return 1
  229. }
  230. }
  231.  
  232. method scanmode {mode args} {
  233. if {$scanmodepv eq {}} {
  234. if {$mama ne {}} {
  235. $mama scanmode $mode {*}$args
  236. } else {
  237. return -code error "Can't set scanmode"
  238. }
  239. } else {
  240. $scanmodepv put $mode {*}$args
  241. }
  242. }
  243.  
  244. method getcallback {cmd} {
  245. $valuepv get -command $cmd
  246. }
  247.  
  248. method read {} {
  249. $valuepv get -command [mymethod readback]
  250. vwait [myvar value]
  251. return $value
  252. }
  253.  
  254. method readback {val meta} {
  255. set value $val
  256. }
  257.  
  258. method getmama {} {
  259. return $mama
  260. }
  261.  
  262. delegate method monitor to valuepv
  263.  
  264. typevariable pending {}
  265. typevariable abort
  266. typevariable results
  267. typevariable resultvar
  268.  
  269.  
  270. typemethod readall {timeout args} {
  271. # trigger all detectors, wait for the result
  272. # should detect if the same mama is to be triggered
  273. set resultvar {}
  274.  
  275. foreach c $args {
  276. # might be easier with coroutines ?
  277. if {![$c trigger -command [mytypemethod triggerready $c]]} {
  278. # if the channel can't be triggered, start an asynchronous get immediately
  279. $c getcallback [mytypemethod valueready $c]
  280. }
  281. dict set pending $c 1
  282. dict set resultvar $c {}
  283. }
  284.  
  285. set abort false
  286. set timeoutid [after $timeout [mytypemethod cancelreading]]
  287.  
  288. while {([llength [$type pendingchannels]]>0) && !$abort} {
  289. vwait [mytypevar pending]
  290. }
  291.  
  292. if {!$abort} {
  293. after cancel $timeoutid
  294. }
  295.  
  296. return [dict values $resultvar]
  297. }
  298.  
  299. typemethod cancelreading {} {
  300. # signal the loop to break
  301. puts "Timeout fired"
  302. set pending $pending
  303. set abort true
  304. }
  305.  
  306. typemethod triggerready {c val meta} {
  307. puts "$c updated, $pending"
  308. if {[dict get $pending $c]==1} {
  309. #puts "$c marked done"
  310. $c getcallback [mytypemethod valueready $c]
  311. }
  312. }
  313.  
  314. typemethod valueready {c val meta} {
  315. puts "Got update $c $val"
  316. dict set pending $c 0
  317. dict set resultvar $c $val
  318. }
  319.  
  320. typemethod pendingchannels {} {
  321. dict keys [dict filter $pending value 1]
  322. }
  323.  
  324.  
  325. }
  326.  
  327. # service routines for typical scanning procedures
  328. proc setup_protocol {template} {
  329. variable ftemplate $template
  330. variable lastfnr 0
  331. }
  332.  
  333. proc newprotofile {args} {
  334. set opts {Comment {} Motor {} Detector Value}
  335. set opts [dict merge $opts $args]
  336.  
  337. variable protofd
  338. closeprotofile
  339.  
  340. variable ftemplate
  341. variable lastfnr
  342.  
  343. incr lastfnr
  344.  
  345. while {true} {
  346. set fname [format $ftemplate $lastfnr]
  347. if {![file exists $fname]} { break }
  348. incr lastfnr
  349. }
  350.  
  351. set protofd [open $fname w]
  352. fconfigure $protofd -buffering line
  353.  
  354. dict with opts {
  355. if {$Comment ne {}} {
  356. puts $protofd "# Comment = $Comment"
  357. }
  358. if {$Motor ne {}} {
  359. puts $protofd "# Plot:"
  360. puts $protofd "# Motor = $Motor"
  361. puts $protofd "# Detector = $Detector"
  362. }
  363. }
  364.  
  365. puts $protofd "# MotorPositions:"
  366. dict for {m v} [motor motorpositions] {
  367. puts $protofd "# $m = $v"
  368. }
  369.  
  370. return $protofd
  371. }
  372.  
  373. proc closeprotofile {} {
  374. variable protofd
  375. if {[info exists protofd]} {
  376. catch {close $protofd}
  377. unset protofd
  378. }
  379. }
  380.  
  381.  
  382. proc read_signal {detspec} {
  383. set detectors [split $detspec /]
  384. set result [channel readall 5000 {*}$detectors]
  385. puts "$detectors, [llength $detectors]"
  386. switch [llength $detectors] {
  387. 1 { return [lindex $result 0] }
  388. 2 {
  389. lassign $result nom denom
  390. if { $denom != 0.0 } {
  391. return [expr {$nom/$denom}]
  392. } else {
  393. return NaN
  394. }
  395. }
  396. }
  397. error "Wrong detspec"
  398. }
  399.  
  400.  
  401. set flcounter 0
  402. proc flyscan {motor to detspec} {
  403. set top [toplevel .fl[incr ::flcounter]]
  404. set graph [ukaz::graph $top.g]
  405. pack $graph -expand yes -fill both
  406. $graph set xlabel $motor
  407. $graph set ylabel $detspec
  408.  
  409. set data {}
  410. set plotid [$graph plot $data with linespoints]
  411. $motor goto $to
  412. while {[$motor ismoving]} {
  413. set value [read_signal $detspec]
  414. puts $value
  415. lappend data [$motor read] $value
  416. $graph update $plotid data $data
  417. }
  418. }
  419.  
  420. proc xrangeN {a b steps} {
  421. set result [list $a]
  422. for {set i 1} {$i<$steps} {incr i} {
  423. lappend result [expr {$a+($b-$a)/double($steps-1.0)*$i}]
  424. }
  425. return $result
  426. }
  427.  
  428.  
  429. proc xrange {a b step} {
  430. if {$step == 0.0} {
  431. return -code error "Zero stepsize"
  432. }
  433.  
  434. if {($a < $b)} {
  435. set step [expr {abs($step)}]
  436. set sign 1.0
  437. } else {
  438. set step [expr {-abs($step)}]
  439. set sign -1.0
  440. }
  441.  
  442. set epsilon 1e-10
  443.  
  444. set i 1
  445. set x $a
  446. set result {}
  447. while {$x*$sign < $b*$sign*(1+$epsilon) } {
  448. lappend result $x
  449. set x [expr {$a+$i*$step}]
  450. incr i
  451. }
  452. return $result
  453. }
  454.  
  455. proc pause {ms} {
  456. after $ms {set _ 1}
  457. vwait ::_
  458. }
  459.  
  460. proc stepscanN {motor detspec a b N args} {
  461. stepscan_list $motor $detspec [xrangeN $a $b $N] {*}$args
  462. }
  463.  
  464. proc stepscan {motor detspec a b step} {
  465. stepscan_list $motor $detspec [xrange $a $b $step] {*}$args
  466. }
  467.  
  468. proc stepscan_list {motor detspec list args} {
  469. # parse extra args
  470. set stdopt {-wait 0}
  471. set opts [dict merge $stdopt $args]
  472.  
  473. if {[dict size $opts] != [dict size $stdopt]} {
  474. set wrongopt [dict filter $args script {k v} {expr ![dict exists $stdopt $k]}]
  475. return -code error "Wrong options $wrongopt"
  476. }
  477.  
  478. set wtime [dict get $opts -wait]
  479.  
  480. set top [toplevel .gr[incr ::grcounter]]
  481. set graph [ukaz::graph $top.g]
  482. pack $graph -expand yes -fill both
  483. $graph set xlabel $motor
  484. $graph set ylabel $detspec
  485.  
  486. set data {}
  487. set plotid [$graph plot $data with linespoints]
  488.  
  489. # skip first point
  490. $motor goto [lindex $list 0]
  491. $motor wait
  492.  
  493. if {$wtime != 0} { pause $wtime }
  494.  
  495. read_signal $detspec
  496.  
  497. set fd [newprotofile Motor $motor Detector $detspec]
  498. puts $fd "# $motor $detspec Time"
  499.  
  500. set t0 [clock microseconds]
  501. foreach pos $list {
  502. $motor goto $pos
  503. $motor wait
  504. if {$wtime != 0} { pause $wtime }
  505.  
  506. set value [read_signal $detspec]
  507. set rbv [$motor read]
  508. set time [expr {([clock microseconds]-$t0)/1e6}]
  509. lappend data $rbv $value
  510. $graph update $plotid data $data
  511. puts $fd "$rbv $value $time"
  512. }
  513.  
  514. closeprotofile
  515. return $data
  516. }
  517.  
  518.  
  519. proc FindCenter {fdata {thresh 0.5}} {
  520.  
  521. # compute min/max position
  522. set maxx 0; set maxy -Inf; set miny +Inf; set ind 0
  523. foreach {x y} $fdata {
  524. if {$y > $maxy} {
  525. set maxy $y
  526. set maxx $x
  527. set maxi $ind
  528. }
  529. if {$y < $miny} {
  530. set miny $y
  531. }
  532. incr ind
  533. }
  534.  
  535. set indmax $ind
  536.  
  537. # go from max position to the left and right
  538. # until we hit the threshold
  539. set rightx {}
  540. set leftx {}
  541. set ythresh [expr {$miny*$thresh + $maxy*(1.0-$thresh)}]
  542. set xold $maxx; set yold $maxy
  543.  
  544. for {set ind $maxi} {$ind < $indmax} {incr ind 1} {
  545. set xcur [lindex $fdata [expr {2*$ind}]]
  546. set ycur [lindex $fdata [expr {2*$ind+1}]]
  547. if {$ycur < $ythresh} {
  548. # interpolate for position
  549. set rightx [expr {$xold + ($xcur-$xold)*double($ythresh-$yold)/double($ycur-$yold)}]
  550. break
  551. }
  552. set xold $xcur
  553. set yold $ycur
  554. }
  555.  
  556. set emergencyx1 $xcur
  557.  
  558. set xold $maxx; set yold $maxy
  559. for {set ind $maxi} {$ind >= 0} {incr ind -1} {
  560. set xcur [lindex $fdata [expr {2*$ind}]]
  561. set ycur [lindex $fdata [expr {2*$ind+1}]]
  562. if {$ycur < $ythresh} {
  563. # interpolate for position
  564. set leftx [expr {$xold + ($xcur-$xold)*double($ythresh-$yold)/double($ycur-$yold)}]
  565. break
  566. }
  567. set xold $xcur
  568. set yold $ycur
  569. }
  570.  
  571. set emergencyx2 $xcur
  572.  
  573. set cx [expr {($emergencyx1+$emergencyx2)/2}]
  574.  
  575. if {$leftx != {} && $rightx != {}} {
  576. set width [expr {$rightx-$leftx}]
  577. set cx [expr {($leftx+$rightx)/2}]
  578. } else {
  579. puts stderr "Warning: No center found - faking it"
  580. }
  581.  
  582. puts "Center: $cx"
  583. return $cx
  584.  
  585. }
  586.  
  587. proc derive {fdata {sign 1.0}} {
  588. set fdata [lsort -real -stride 2 -unique $fdata]
  589. set result {}
  590. set rest [lassign $fdata oldx oldy]
  591. foreach {x y} $rest {
  592. set dx [expr {$oldx-$x}]
  593. set dy [expr {$oldy-$y}]
  594. lappend result [expr {($x+$oldx)/2.0}] [expr {(double($dy)/$dx)*$sign}]
  595. set oldx $x
  596. set oldy $y
  597. }
  598.  
  599. return $result
  600. }
  601.