wangdequan/linuxcncAllWasm
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Import LinuxCNC source tree

Browse Source
This commit is contained in:
Wang Dequan
2026-08-20 06:17:39 +08:00
commit 2c814634c3
9429 changed files with 10556013 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

294
tcl/bin/cbutton.tcl Normal file
View File

@@ -0,0 +1,294 @@
# ----------------------------------------------------------------------
#
# cbutton.tcl --
#
# Example of how to provide button-like behavior on canvas
# items. (Posted on comp.lang.tcl by Kevin Kenny)
#
# source: https://wiki.tcl-lang.org/page/Canvas+Buttons
set ::RCSID([info script]) \
{$Id: 1383,v 1.3 2006-09-24 06:00:06 jcw Exp $}
package provide canvasbutton 1.0
namespace eval canvasbutton {
# nexttag - Next unique tag number for a "button" being
# created
variable nexttag 0
# command - command(tag#) contains the command to execute when
# a "button" is selected.
variable command
# cursor - cursor(pathName) contains the (saved) cursor
# symbol of the widget when the pointer is in
# a "button"
variable cursor
# enteredButton - contains the tag number of the button
# containing the pointer.
variable enteredButton {}
# pressedButton - contains the tag number of the "button"
# in which the mouse button was pressed
variable pressedButton {}
namespace export canvasbutton
}
# ----------------------------------------------------------------------
#
# canvasbutton::canvasbutton --
#
# Create a button-like object on a canvas.
#
# Parameters:
# w Path name of the canvas
# x0 Canvas X coordinate of left edge
# y0 Canvas Y coordinate of top edge
# x1 Canvas X coordinate of right edge
# y1 Canvas Y coordinate of bottom edge
# text Text to display in the button
# cmd Command to execute when the button is selected.
#
# Results:
# Unique canvas tag assigned to the items that make
# up the button.
#
# Side effects:
# A rectangle and a text item are created in the canvas,
# and bindings are established to give them button-like
# behavior.
#
#----------------------------------------------------------------------
proc canvasbutton::canvasbutton {w x0 y0 wd h text cmd state} {
variable nexttag
variable command
set btag [list canvasb# [incr nexttag]]
set command($btag) $cmd
set x [expr { $x0 + ($wd / 2) }]
set y [expr { $y0 + ($h / 2) + 1}]
if {$state} {
$w create rectangle $x0 $y0 [expr {$x0 + $wd}] [expr {$y0 + $h}] \
-fill lightgray -outline black -width 1 \
-tags [list canvasb $btag [linsert $btag end frame]]
$w create text $x $y -anchor center -justify center \
-text $text \
-tags [list canvasb $btag [linsert $btag end text]]
$w bind canvasb <Enter> [list [namespace current]::enter %W]
$w bind canvasb <Leave> [list [namespace current]::leave %W]
$w bind canvasb <ButtonPress-1> \
[list [namespace current]::press %W]
$w bind canvasb <ButtonRelease-1> \
[list [namespace current]::release %W]
} else {
$w create rectangle $x0 $y0 [expr {$x0 + $wd}] [expr {$y0 + $h}] \
-fill lightgray -outline grey65 -width 1
$w create text $x $y -anchor center -justify center \
-text $text -fill grey65
}
return $btag
}
# ----------------------------------------------------------------------
#
# canvasbutton::enter --
#
# Process the <Enter> event on a canvas-button.
#
# Parameters:
# w Path name of the canvas
#
# Results:
# None.
#
# Side effects:
# When the mouse pointer is in a button, the button is
# highlighted with a broad outline and the cursor
# symbol changes to an arrow. When the active button
# is pressed, it is highlighted in green.
#
# ----------------------------------------------------------------------
proc canvasbutton::enter {w} {
variable enteredButton
variable pressedButton
variable cursor
set enteredButton [findBtag $w]
set frame [linsert $enteredButton end frame]
set cursor($w) [$w cget -cursor]
$w configure -cursor arrow
#$w itemconfigure $frame -width 3
$w itemconfigure $frame -fill grey93
if {![string compare $enteredButton $pressedButton]} {
$w itemconfigure $frame -fill grey60
}
}
# ----------------------------------------------------------------------
#
# canvasbutton::leave --
#
# Process the <Leave> event on a canvas-button.
#
# Parameters:
# w Path name of the canvas
#
# Results:
# None.
#
# Side effects:
# Reverts the cursor symbol, the border width
# if needed, the highlight color of the button.
#
# ----------------------------------------------------------------------
proc canvasbutton::leave {w} {
variable enteredButton
variable pressedButton
variable cursor
if {[string compare $enteredButton {}]} {
set btag [findBtag $w]
set frame [linsert $btag end frame]
#$w itemconfigure $frame -width 1
$w itemconfigure $frame -fill lightgray
$w configure -cursor $cursor($w)
unset cursor($w)
if {![string compare $btag $pressedButton]} {
$w itemconfigure $frame -fill white
}
set enteredButton {}
}
return
}
# ----------------------------------------------------------------------
#
# canvasbutton::press --
#
# Process the <ButtonPress-1> event on a canvas-button.
#
# Parameters:
# w Path name of the canvas
#
# Results:
# None.
#
# Side effects:
# Highlights the selected button in green.
#
# ----------------------------------------------------------------------
proc canvasbutton::press {w} {
variable pressedButton
set pressedButton [findBtag $w]
$w itemconfigure [linsert $pressedButton end frame] \
-fill grey60
return
}
# ----------------------------------------------------------------------
#
# canvasbutton::release --
#
# Process the <ButtonRelease-1> event on a canvas-button.
#
# Parameters:
# w Path name of the canvas
#
# Results:
# None.
#
# Side effects:
# Reverts the highlight color on the button. If the
# mouse has not left the button, invokes the button's
# command.
#
# ----------------------------------------------------------------------
proc canvasbutton::release {w} {
variable enteredButton
variable pressedButton
variable command
set pressedButtonWas $pressedButton
set pressedButton {}
$w itemconfigure [linsert $pressedButtonWas end frame] \
-fill grey93
if {![string compare $enteredButton $pressedButtonWas]} {
uplevel #0 $command($pressedButtonWas)
}
return
}
# ----------------------------------------------------------------------
#
# canvasbutton::btag --
#
# Locate the unique tag of a canvas-button
#
# Parameters:
# w Path name of the canvas
#
# Results:
# Button tag, or the null string if the current
# item is not a canvas-button
#
# Side effects:
# Searches the tag list of the current canvas item
# for a tag that begins with the string, `canvasb#',
# and returns the first two elements of the tag
# interpreted as a Tcl list.
#
# ----------------------------------------------------------------------
proc canvasbutton::findBtag {w} {
foreach tag [$w itemcget current -tags] {
if {[regexp {^canvasb#} [lindex $tag 0]]} {
return [lrange $tag 0 1]
}
}
return {}
}
if {![string compare $argv0 [info script]]} {
grid [canvas .c -width 300 -height 200 -cursor crosshair]
namespace import canvasbutton::*
.c create text 150 150 -anchor n -tags label \
-font {Helvetica 10 bold}
canvasbutton .c 10 60 90 140 "First\nButton" {
.c itemconfigure label -text One
}
canvasbutton .c 110 60 190 140 "Second\nButton" {
.c itemconfigure label -text Two
}
canvasbutton .c 210 60 290 140 "Third\nButton" {
.c itemconfigure label -text Three
}
canvasbutton .c 240 160 290 190 "Quit" exit
}

568
tcl/bin/emccalib.tcl Executable file
View File

@@ -0,0 +1,568 @@
#!/bin/sh
# the next line restarts using emcsh \
exec $LINUXCNC_EMCSH "$0" "$@"
###############################################################
# Description: emccalib.tcl
# A Tcl/Tk script that interfaces with LinuxCNC
# through GUIs. It configures ini tuning variables
# on the fly and saves if desired.
#
# Author: Ray Henry
# License: GPL Version 2
#
# Copyright (c) 2003-2009 All rights reserved.
###############################################################
# EMC parameter setting application
# Needs emcsh to run
# Saves changes to ini file if requested
###############################################################
# FIXME allow multiple reads of ini var.
# this is a one way system. It finds ini referenced variable in hal files
# and builds widgets to display and manipulate their values
# it does not and will not sort on hal components.
source [file join [file dirname [info script]] .. linuxcnc.tcl]
eval emc_init $argv
source [file join $::env(HALLIB_DIR) hal_procs_lib.tcl]
package require BWidget
# add a few default characteristics to the display
foreach class { Button Checkbutton Entry Label Listbox Menu Menubutton \
Message Radiobutton Scale } {
option add *$class.borderWidth 1 100
}
set ::EC(numjoints) [emc_ini "JOINTS" "KINS"]
set ::EC(numspindles) 10 ;# currently 8 spindles allowed (0..7)
;# but legacy configs may have [SPINDLE_9]
;# so allow up to 10 (0..9)
#--------------------------------------------------------------
# Tuning stanzas
set ::EC(stanzas) [list TUNE JOINT_ AXIS_ SPINDLE_]
# Specify a stanza for tuning with:
# ::EC(stanza_name,howmany) == number of allowed names
# ::EC(stanza_name,suffixes) == list of allowed suffixes
#
# Special case: howmany==1 and items=="", no allowed suffixes
#
# Examples:
# item==JOINT_ specifies name/value pairs like:
# [JOINT_n]name=value
# where n is a suffix in {0 1 ...}
#
# item==TUNE using howmany==1 and items=="" specifies
# name/value pairs with no suffix like:
# [TUNE]name=value
set ::EC(TUNE,howmany) 1
set ::EC(TUNE,suffixes) ""
set ::EC(JOINT_,howmany) $::EC(numjoints)
for {set i 0} {$i < $::EC(JOINT_,howmany)} {incr i} {
lappend ::EC(JOINT_,suffixes) $i
}
set ::EC(SPINDLE_,howmany) $::EC(numspindles)
for {set i 0} {$i < $::EC(SPINDLE_,howmany)} {incr i} {
lappend ::EC(SPINDLE_,suffixes) $i
}
set ::EC(AXIS_,suffixes) {X Y Z A B C U V W}
set ::EC(AXIS_,howmany) [llength $::EC(AXIS_,suffixes)]
#--------------------------------------------------------------
# Find the name of the ini file used for this run.
set ::EC(thisinifile) "$::EMC_INIFILE"
set ::EC(thisconfigdir) [file dirname $::EC(thisinifile)]
#----------start toplevel----------
#
# trap mouse click on window manager delete
# might add a test for up to date ini before closing
wm protocol . WM_DELETE_WINDOW askKill
proc askKill {} {
destroy .
exit
}
wm title . [msgcat::mc "LinuxCNC Calibration"]
set ::EC(main) [frame .main ]
set ::EC(nbook) [NoteBook .main.top]
pack $::EC(main) -side left -expand yes -fill both \
-padx 18 -pady 18 -anchor n
pack $::EC(nbook) -side top -fill both -expand yes
set terminate [frame $::EC(main).bot]
pack $terminate -side top -fill x
button $terminate.save -text [msgcat::mc "Save To File"] -command {saveIni tune}
button $terminate.quit -text [msgcat::mc "Quit"] -command {saveIni quit}
pack $terminate.save $terminate.quit \
-pady 4 -side left -fill both -expand yes
# remove slider
# slider process is used for several widgets
proc sSlide {f a b} {
$f.sc set $a $b
}
# Build menu
# fixme clean up the underlines so they are unique under each set
set menubar [menu $::EC(nbook).menubar -tearoff 0]
#. configure -menu $menubar
set filemenu [menu $menubar.file -tearoff 0]
$menubar add cascade -label [msgcat::mc "File"] \
-menu $filemenu
$filemenu add command -label [msgcat::mc "Refresh"] \
-command {refreshHAL}
$filemenu add command -label [msgcat::mc "Save"] \
-command {saveHAL save}
# Make a text widget to hold the ini file
set ::EC(initext) [text $::EC(nbook).initext]
set ::EC(haltext) [text $::EC(nbook).haltext]
$::EC(initext) config -state normal
$::EC(initext) delete 1.0 end
set programin [open $::EC(thisinifile)]
$::EC(initext) insert end [read $programin]
close $programin
# setup array with section names and line numbers
set ::EC(sectionlist) {}
scan [$::EC(initext) index end] %d nl
set inilastline $nl
for {set i 1} {$i < $nl} {incr i} {
if { [$::EC(initext) get $i.0] == "\[" } {
set inisectionname [$::EC(initext) get $i.1 $i.end]
set tab " "
set spc " "
set inisectionname [string trimright $inisectionname "$spc$tab]" ]
set ::EC(sectionline,$inisectionname) $i
lappend ::EC(sectionlist) $inisectionname
}
}
set ::EC(sectionline,END_OF_INI_FILE) [expr $nl-1]
lappend ::EC(sectionlist) END_OF_INI_FILE
# Find the HALFILE names between HAL and the next section
set startline $::EC(sectionline,HAL)
set endline $::EC(sectionline,[lindex $::EC(sectionlist) \
[expr [lsearch -exact $::EC(sectionlist) HAL] + 1 ]])
set ::EC(halfilelist) ""
for {set i $startline} {$i < $endline} {incr i} {
set thisstring [string trim [$::EC(initext) get $i.0 $i.end]]
if { ([string first "HALFILE" "$thisstring"] == 0)
|| ([string first "POSTGUI_HALFILE" "$thisstring"] == 0)
} {
set arglist [lindex [split $thisstring =] 1]
set thishalname [lindex $arglist 0]
lappend ::EC(halfilelist) [find_file_in_hallib_path $thishalname $::EC(thisinifile)]
}
}
proc find_ini_refs {stanza} {
# find the ini references in this hal and build widgets
scan [$::EC(haltext) index end] %d nl
for {set i 1} { $i < $nl } {incr i} {
set tmpstring [string trim [$::EC(haltext) get $i.0 $i.end]]
if {[string match *${stanza}* $tmpstring] && ![string match *#* $tmpstring]} {
set halcommand [split $tmpstring " \t"]
if { [lindex $halcommand 0] == "setp" || [lindex $halcommand 1] == "\=" } {
if { [lindex $halcommand 1] == "\=" } {
set tmpstring "setp [lindex $halcommand 0] [lindex $halcommand 2]"
}
# tunable item is the setp value (3rd token); ignore ini refs
# that only appear inside the pin name (issue #4165)
set valuestring [lindex $tmpstring 2]
for {set sfx 0} {$sfx < $::EC($stanza,howmany)} {incr sfx} {
set tabno $::EC($stanza,$sfx,tabno)
set itag [lindex $::EC($stanza,suffixes) $sfx]
if {[string match *${stanza}${itag}* $valuestring]} {
# this is a hal file search ordered loop
set thisininame [lindex [split $valuestring "\]" ] end ]
set thisininame [string map {( "" ) ""} $thisininame]
set lowername "[string tolower $thisininame]"
set thishalcommand [lindex $tmpstring 1]
set tmpval [string trim [hal getp [halcmdSubstitute $thishalcommand]]]
set ::EC(value,$tabno,$lowername) $tmpval
set ::EC(value,$tabno,$lowername,next) $tmpval
if { [catch { set thisname [label $::EC(tab,$tabno).label-$itag-$lowername \
-text "$thisininame: " -width 20 -anchor e] } msg ] } {
#puts msg=$msg
} else {
set thisval [label $::EC(tab,$tabno).entry-$lowername -width 8 \
-textvariable ::EC(value,$tabno,$lowername) -anchor e -foreg firebrick4 ]
set thisentry [entry $::EC(tab,$tabno).next-$lowername -width 8 \
-width 12 -textvariable ::EC(value,$tabno,$lowername,next) ]
grid $thisname $thisval x $thisentry
}
lappend ::EC(ininamearray,$tabno) $lowername
lappend ::EC(commandarray,$tabno) $thishalcommand
break
}
}
}
}
}
} ;# find_ini_refs
proc makeIniTune {} {
set tabno 0
foreach stanza $::EC(stanzas) {
for {set sfx 0} {$sfx < $::EC($stanza,howmany)} {incr sfx} {
set ::EC($stanza,$sfx,tabno) $tabno
set ::EC($tabno,stanza) $stanza ;# cross reference tabno-->stanza
set itag [lindex $::EC($stanza,suffixes) $sfx]
if {($::EC($stanza,howmany) == 1) && ($::EC($stanza,suffixes)=="")} {
set tablabel ${stanza}
} else {
set tablabel ${stanza}$itag
}
set ::EC(tab,$tabno) [$::EC(nbook) insert [expr $tabno+3] page$tabno \
-text $tablabel -raisecmd "selectTab $tabno" ]
set col0 [label $::EC(tab,$tabno).collabel0 -text [msgcat::mc "INI Name"]]
set col1 [label $::EC(tab,$tabno).collabel1 -text [msgcat::mc "HAL's Value"]]
set col2 [label $::EC(tab,$tabno).space -text " "]
set col3 [label $::EC(tab,$tabno).collabel3 -text [msgcat::mc "Next Value"]]
grid $col0 $col1 $col2 $col3 -ipady 5
grid rowconfigure $::EC(tab,$tabno) 9999 -weight 1
incr tabno
}
}
foreach fname $::EC(halfilelist) {
$::EC(haltext) config -state normal
$::EC(haltext) delete 1.0 end
if {[catch {open $fname} programin]} {
continue
} else {
$::EC(haltext) insert end [read $programin]
catch {close $programin}
}
foreach stanza $::EC(stanzas) {
find_ini_refs $stanza
}
}
if {[array names ::EC ininamearray,*] == ""} {
incompatible_ini_file
return
}
# build the buttons to control variables.
foreach stanza $::EC(stanzas) {
for {set sfx 0} {$sfx < $::EC($stanza,howmany)} {incr sfx} {
set itag [lindex $::EC($stanza,suffixes) $sfx]
set tabno $::EC($stanza,$sfx,tabno)
if ![info exists ::EC(startpagenum)] {
set ::EC(startpagenum) $tabno
}
if ![info exists ::EC(ininamearray,$tabno)] {
$::EC(nbook) delete page$tabno
if {$tabno == $::EC(startpagenum)} {
unset ::EC(startpagenum)
}
continue
}
set bframe [frame $::EC(tab,$tabno).buttons]
grid configure $bframe -columnspan 4 -sticky nsew
set tmptest [button $bframe.test -text [msgcat::mc "Test"] \
-command {iniTuneButtonpress test}]
set tmpok [button $bframe.ok -text [msgcat::mc "OK"] \
-command {iniTuneButtonpress ok} -state disabled ]
set tmpcancel [button $bframe.cancel -text [msgcat::mc "Cancel"] \
-command {iniTuneButtonpress cancel} -state disabled ]
set tmprefresh [button $bframe.refresh -text [msgcat::mc "Refresh"] \
-command {iniTuneButtonpress refresh}]
pack $tmpok $tmptest $tmpcancel $tmprefresh -side left -fill both -expand yes -pady 5
}
}
} ;# makeIniTune
proc incompatible_ini_file {} {
set progname [file tail $::argv0]
set fname [file tail $::EMC_INIFILE]
set answer [tk_messageBox \
-title "Ini file not compatible with $progname" \
-message [msgcat::mc "\
No Tuneable items in ini file:\n\
$fname\n\n\
Sections supported are:\n\
\[JOINT_N\]name=value\n\
\[AXIS_L\]name=value\n\
\[SPINDLE_S\]name=value\n\
\[TUNE\]name=value\n\n\
N is a joint number\n\
L is an axis letter\n\
S is a spindle number\n\n\
A Halfile must include a setp\n\
for a supported section item\n\n\
Inifile example:\n\
\[JOINT_0\]\n\
PGAIN=1\n\
...\n\
\[TUNE\]\n\
SPEED=100\n\
...\n\n\
Halfile example:\n\
setp pid.0.Pgain \[JOINT_0\]PGAIN\n\
setp mux2.0.in1 \[TUNE\]SPEED\n\
...\n\n\
\n\
" ] \
-type ok \
-icon info]
exit 1
} ;# incompatible_ini_file
proc selectTab {which} {
set ::curtab $which ;# current tab number
}
proc iniTuneButtonpress {which} {
set labelname ".main.top.fpage$::curtab.next"
set basename ".main.top.fpage$::curtab.buttons"
# which can be (test, ok, cancel)
switch -- $which {
test {
$basename.test configure -state disabled
$basename.ok configure -state normal
$basename.cancel configure -state normal
set entrystate "disabled"
}
cancel {
$basename.test configure -state normal
$basename.ok configure -state disabled
$basename.cancel configure -state disabled
set entrystate "normal"
}
ok {
$basename.test configure -state normal
$basename.ok configure -state disabled
$basename.cancel configure -state disabled
set entrystate "normal"
}
refresh {
$basename.test configure -state normal
$basename.ok configure -state disabled
$basename.cancel configure -state disabled
set entrystate "normal"
}
default {
}
}
foreach name $::EC(ininamearray,$::curtab) {
$labelname-$name configure -state $entrystate
}
changeIni $which $::EC($::curtab,stanza)
} ;# iniTuneButtonpress
proc changeIni {how stanza} {
switch -- $how {
cancel {-}
test {
set varnames $::EC(ininamearray,$::curtab)
set varcommands $::EC(commandarray,$::curtab)
set maxvarnum [llength $varnames]
set swapvars $varnames
# handle each variable and values inside loop
for {set listnum 0} {$listnum < $maxvarnum} {incr listnum} {
set vname [lindex $varnames $listnum]
set var ::EC(value,$::curtab,$vname)
set varnext ::EC(value,$::curtab,$vname,next)
# remove this item from the "to be swapped" list
set thisvar [lindex $swapvars 0]
set swapvars [lrange $swapvars 1 end]
# get the values
set oldval [set $var]
set newval [set $varnext]
# get the parameter name string
set tmpcmd [lindex $varcommands $listnum]
# set new parameter value in hal
set thisret [hal setp [halcmdSubstitute $tmpcmd] $newval]
# see if we need to swap the new and old control values
if {[lsearch -exact $swapvars $thisvar] < 0} {
# set the current value for display
set $var $newval
# set the tmp value as next in display
set $varnext $oldval
}
}
}
ok {
set varnames $::EC(ininamearray,$::curtab)
set varcommands $::EC(commandarray,$::curtab)
set maxvarnum [llength $varnames]
# handle each variable and values inside loop
for {set listnum 0} {$listnum < $maxvarnum} {incr listnum} {
set vname [lindex $varnames $listnum]
set var ::EC(value,$::curtab,$vname)
set varnext ::EC(value,$::curtab,$vname,next)
# get the values
set oldval [set $var]
# set the tmp value as next in display
set $varnext $oldval
}
}
refresh {
set varnames $::EC(ininamearray,$::curtab)
set varcommands $::EC(commandarray,$::curtab)
set maxvarnum [llength $varnames]
# handle each variable and values inside loop
for {set listnum 0} {$listnum < $maxvarnum} {incr listnum} {
set vname [lindex $varnames $listnum]
set var ::EC(value,$::curtab,$vname)
set varnext ::EC(value,$::curtab,$vname,next)
# get the parameter name string
set tmpcmd [lindex $varcommands $listnum]
# get parameter value from hal
set val [string trim [hal getp [halcmdSubstitute $tmpcmd]]]
set $var $val
set $varnext $val
}
}
quit {
puts stderr "Unexpected changeIni quit"
# was never called, removed deadcode here
}
default {}
}
} ;# changeIni
proc saveIni {which} {
if {![file writable $::EC(thisinifile)]} {
tk_messageBox -type ok -message [msgcat::mc "Not permitted to save here.\n\n \
You need to copy a configuration to your home directory and work there."]
}
switch -- $which {
tune {
update_initext $::EC($::curtab,stanza)
saveFile $::EC(thisinifile) $::EC(initext)
}
quit {destroy .; exit}
}
} ;# saveIni
proc update_initext {stanza} {
set anames [array names ::EC ininamearray,*]
foreach stanza $::EC(stanzas) {
for {set sfx 0} {$sfx < $::EC($stanza,howmany)} {incr sfx} {
set itag [lindex $::EC($stanza,suffixes) $sfx]
set tabno $::EC($stanza,$sfx,tabno)
if {[lsearch $anames ininamearray,$tabno] < 0} continue
set varnames $::EC(ininamearray,$tabno)
set upvarnames [string toupper $varnames]
set varcommands $::EC(commandarray,$tabno)
set maxvarnum [llength $varnames]
set sectname "${stanza}$itag"
# get the name of the next ini section
set endsect [lindex $::EC(sectionlist) \
[expr [lsearch -exact $::EC(sectionlist) $sectname] + 1 ]]
set sectnum "[set ::EC(sectionline,$sectname)]"
set nextsectnum "[set ::EC(sectionline,$endsect)]"
$::EC(initext) configure -state normal
for {set ind $sectnum} {$ind < $nextsectnum} {incr ind} {
switch -- [$::EC(initext) get $ind.0] {
"#" {}
default {
set tmpstr [$::EC(initext) get $ind.0 $ind.end]
set tmpvar [lindex [split $tmpstr "="] 0]
set tmpvar [string toupper [string trim $tmpvar]]
set tmpindx [lsearch $upvarnames $tmpvar]
if {$tmpindx != -1} {
set cmd [lindex $varcommands $tmpindx]
$::EC(initext) mark set insert $ind.0
set newval [string trim [hal getp [halcmdSubstitute $cmd]]]
set tmptest [string first "e" $newval]
if {[string first "e" $newval] > 1} {
set newval [format %f $newval]
}
regsub {(^.*=[ \t]*)[^ \t]*(.*)} $tmpstr "\\1$newval\\2" newvar
$::EC(initext) delete insert "insert lineend"
$::EC(initext) insert insert $newvar
}
}
}
}
$::EC(initext) configure -state disabled
}
}
} ;# update_initext
proc halcmdSubstitute {s} {
set pat {\[([^]]+)\](\([^)]+\)|[^() \r\n\t]+)}
set pos 0
set result {}
while {$pos < [string length $s]
&& [regexp -start $pos -indices $pat $s indx]} {
set start [lindex $indx 0]
set end [lindex $indx 1]
append result [string range $s $pos [expr $start-1]]
set query [string range $s $start $end]
regexp $pat $query - section var
set var [regsub {\((.*)\)} $var {\1}]
append result [emc_ini $var $section]
set pos [expr $end+1]
}
append result [string range $s $pos end]
return $result
} ;# halcmdSubstitute
proc saveFile {filename contents} {
catch {file copy -force $filename $filename.bak}
if { [catch {open $filename w} fileout] } {
puts stdout [msgcat::mc "can't save %s" $halconfFilename($name)]
return
}
if {-1 != [string first ".ini.expanded" $filename]} {
set fname [file tail $filename]
set answer [tk_messageBox \
-title "Expanded File" \
-message [msgcat::mc "\
Save to: <$fname>\n\n\
Expanded file for \#INCLUDEs\n\n\
\#INCLUDE files (*.inc)\n\
must be edited separately\n\
\n\
" ] \
-type ok \
-icon info]
}
switch -- [string index $contents 0] {
"/" {
# a filename
puts "I got a filename"
}
"." {
# "." means this is a widget name so get contents
set lines [$contents count -lines 1.0 end]
# was: puts $fileout [$contents get 1.0 end]
# avoid writing empty lines at end of file:
incr lines -1
set last ${lines}.end
puts $fileout [$contents get 1.0 $last]
catch {close $fileout}
}
default {
# assumes that contents is plain text so stuff it away
puts $fileout $contents
catch {close $fileout}
}
}
} ;# saveFile
makeIniTune
$::EC(nbook) raise page$::EC(startpagenum)

211
tcl/bin/emcdebug.tcl Executable file
View File

@@ -0,0 +1,211 @@
#!/bin/sh
# the next line restarts using emcsh \
exec $LINUXCNC_EMCSH "$0" "$@"
###############################################################
# Description: emcdebug.tcl
# This file sets debug levesl from tkemc.
#
# Derived from a work by Fred Proctor & Will Shackleford
# Author:
# License: GPL Version 2
#
# Copyright (c) 2005-2009 All rights reserved.
###############################################################
#
# Sets value of EMC_DEBUG, so you can turn on/off what you want dumped
# Needs emcsh to run-- this is sourced by tkemc, but it can be run
# standalone. Make sure directory containing emcsh is in your path,
# or edit the exec line above with the path to emcsh.
#
###############################################################
source [file join [file dirname [info script]] .. linuxcnc.tcl]
eval emc_init $argv
# check if any emc commands exist, and quit if not
if {! [string length [info commands emc_plat]]} {
error "emcdebug needs to run from \"emcsh\""
}
proc distributeDebug {} {
global debug_invalid
global debug_config
global debug_defaults
global debug_versions
global debug_task_issue
global debug_io_points
global debug_nml
global debug_motion_time
global debug_interp
global debug_rcs
global debug_traj
global debug_interp_list
# get the debug level from the EMC
set emc_debug_level [emc_debug]
# set the initial check boxes to correspond to current debug settings
set debug_invalid [expr $emc_debug_level % 2]
set emc_debug_level [expr $emc_debug_level >> 1]
set debug_config [expr $emc_debug_level % 2]
set emc_debug_level [expr $emc_debug_level >> 1]
set debug_defaults [expr $emc_debug_level % 2]
set emc_debug_level [expr $emc_debug_level >> 1]
set debug_versions [expr $emc_debug_level % 2]
set emc_debug_level [expr $emc_debug_level >> 1]
set debug_task_issue [expr $emc_debug_level % 2]
set emc_debug_level [expr $emc_debug_level >> 1]
set debug_io_points [expr $emc_debug_level % 2]
set emc_debug_level [expr $emc_debug_level >> 1]
set debug_nml [expr $emc_debug_level % 2]
set emc_debug_level [expr $emc_debug_level >> 1]
set debug_motion_time [expr $emc_debug_level % 2]
set emc_debug_level [expr $emc_debug_level >> 1]
set debug_interp [expr $emc_debug_level % 2]
set emc_debug_level [expr $emc_debug_level >> 1]
set debug_rcs [expr $emc_debug_level % 2]
set emc_debug_level [expr $emc_debug_level >> 1]
set debug_traj [expr $emc_debug_level % 2]
set emc_debug_level [expr $emc_debug_level >> 1]
set debug_interp_list [expr $emc_debug_level % 2]
}
proc collectDebug {} {
global debug_invalid
global debug_config
global debug_defaults
global debug_versions
global debug_task_issue
global debug_io_points
global debug_nml
global debug_motion_time
global debug_interp
global debug_rcs
global debug_traj
global debug_interp_list
set emc_debug_level $debug_interp_list
set emc_debug_level [expr $emc_debug_level << 1]
set emc_debug_level [expr $emc_debug_level + $debug_traj]
set emc_debug_level [expr $emc_debug_level << 1]
set emc_debug_level [expr $emc_debug_level + $debug_rcs]
set emc_debug_level [expr $emc_debug_level << 1]
set emc_debug_level [expr $emc_debug_level + $debug_interp]
set emc_debug_level [expr $emc_debug_level << 1]
set emc_debug_level [expr $emc_debug_level + $debug_motion_time]
set emc_debug_level [expr $emc_debug_level << 1]
set emc_debug_level [expr $emc_debug_level + $debug_nml]
set emc_debug_level [expr $emc_debug_level << 1]
set emc_debug_level [expr $emc_debug_level + $debug_io_points]
set emc_debug_level [expr $emc_debug_level << 1]
set emc_debug_level [expr $emc_debug_level + $debug_task_issue]
set emc_debug_level [expr $emc_debug_level << 1]
set emc_debug_level [expr $emc_debug_level + $debug_versions]
set emc_debug_level [expr $emc_debug_level << 1]
set emc_debug_level [expr $emc_debug_level + $debug_defaults]
set emc_debug_level [expr $emc_debug_level << 1]
set emc_debug_level [expr $emc_debug_level + $debug_config]
set emc_debug_level [expr $emc_debug_level << 1]
set emc_debug_level [expr $emc_debug_level + $debug_invalid]
emc_debug $emc_debug_level
}
proc popdownDebug {w} {
destroy $w
if {$w == "."} {
exit
}
}
proc popupDebug {{w .debugwindow}} {
global debug_invalid
global debug_config
global debug_defaults
global debug_versions
global debug_task_issue
global debug_io_points
global debug_nml
global debug_motion_time
global debug_interp
global debug_rcs
global debug_traj
global debug_interp_list
# trap "." as window name, and erase it, so that widgets
# don't begin with two dots. We'll refer to the passed-in
# name "w" here; in code following this setup we'll use the
# modified name "lw"
if {$w == "."} {
# we're running standalone
set lw ""
wm title $w [msgcat::mc "LinuxCNC Debug"]
} else {
# we were sourced into tkemc, and run as a popup
set lw $w
if {[winfo exists $w]} {
wm deiconify $w
raise $w
focus $w
return
}
toplevel $w
wm title $w [msgcat::mc "LinuxCNC Debug"]
}
# use "lw" as name of top level from now on
# set the debug variables so that they're initially checked properly
distributeDebug
checkbutton $lw.b1 -text [msgcat::mc "Invalid INI file entries"] -variable debug_invalid -relief flat
checkbutton $lw.b2 -text [msgcat::mc "Configuration information"] -variable debug_config -relief flat
checkbutton $lw.b3 -text [msgcat::mc "Use of defaults"] -variable debug_defaults -relief flat
checkbutton $lw.b4 -text [msgcat::mc "Version information"] -variable debug_versions -relief flat
checkbutton $lw.b5 -text [msgcat::mc "Command issuing"] -variable debug_task_issue -relief flat
checkbutton $lw.b6 -text [msgcat::mc "IO points"] -variable debug_io_points -relief flat
checkbutton $lw.b7 -text [msgcat::mc "NML"] -variable debug_nml -relief flat
checkbutton $lw.b8 -text [msgcat::mc "Motion time"] -variable debug_motion_time -relief flat
checkbutton $lw.b9 -text [msgcat::mc "Interpreter"] -variable debug_interp -relief flat
checkbutton $lw.b10 -text [msgcat::mc "RCS"] -variable debug_rcs -relief flat
checkbutton $lw.b11 -text [msgcat::mc "Trajectory level"] -variable debug_traj -relief flat
checkbutton $lw.b12 -text [msgcat::mc "Interpreter list"] -variable debug_interp_list -relief flat
pack $lw.b1 $lw.b2 $lw.b3 $lw.b4 $lw.b5 $lw.b6 $lw.b7 $lw.b8 $lw.b9 $lw.b10 $lw.b11 $lw.b12 -side top -pady 2 -anchor w
frame $lw.buttons
button $lw.buttons.ok -text [msgcat::mc "OK"] -default active -command "collectDebug; popdownDebug $w"
button $lw.buttons.cancel -text [msgcat::mc "Cancel"] -command "popdownDebug $w"
pack $lw.buttons -side bottom -fill x -pady 2m
pack $lw.buttons.ok $lw.buttons.cancel -side left -expand 1
bind $w <Return> "emc_debug [collectDebug] ; popdownDebug $w"
}
# if we're not running inside tkemc, then pop us up in root window
if {! [info exists tkemc]} {
popupDebug .
}

105
tcl/bin/emctesting.tcl Executable file
View File

@@ -0,0 +1,105 @@
#!/bin/sh
# the next line restarts using emcsh \
exec $LINUXCNC_EMCSH "$0" "$@"
source [file join [file dirname [info script]] .. linuxcnc.tcl]
###############################################################
# Description: emctesting.tcl
# EMC performance testing program
#
# Derived from a work by Fred Proctor & Will Shackleford
# License: GPL Version 2
#
# Copyright (c) 2005-2009 All rights reserved.
###############################################################
# emctesting.tcl
# EMC performance testing program
# Needs emcsh to run-- this is sourced by tkemc, but it can be run
# standalone. Make sure directory containing emcsh is in your path,
# or edit the exec line above with the path to emcsh.
eval emc_init $argv
# check if any emc commands exist, and quit if not
if {! [string length [info commands emc_plat]]} {
error "emctesting needs to run from \"emcsh\""
}
if {! [info exists activeAxis]} {
set activeAxis 0
}
proc popdownTesting {w} {
destroy $w
if {$w == "."} {
exit
}
}
proc popupTesting {{w .testingwindow}} {
global axisentry outvolts ampenable
global activeAxis
# trap "." as window name, and erase it, so that widgets
# don't begin with two dots. We'll refer to the passed-in
# name "w" here; in code following this setup we'll use the
# modified name "lw"
if {$w == "."} {
set lw ""
wm title $w "EMC Testing"
} else {
set lw $w
if {[winfo exists $w]} {
wm deiconify $w
raise $w
focus $w
return
}
toplevel $w
wm title $w "EMC Testing"
}
# use "lw" as name of top level from now on
# force the selected axis to be the active axis
set axisentry $activeAxis
# force the button to reflect actual state
set ampenable [emc_axis_enable $activeAxis]
# force the volts to 0, a valid entry
set outvolts 0.0
frame $lw.axis
label $lw.axis.lab -text "Axis:" -width 20 -anchor w
entry $lw.axis.ent -width 10 -textvariable axisentry
pack $lw.axis -side top -fill x
pack $lw.axis.lab -side left
pack $lw.axis.ent -side left
frame $lw.outvolts
label $lw.outvolts.lab -text "Output Voltage:" -width 20 -anchor w
entry $lw.outvolts.ent -width 10 -textvariable outvolts
pack $lw.outvolts -side top -fill x
pack $lw.outvolts.lab -side left
pack $lw.outvolts.ent -side left
frame $lw.amp
checkbutton $lw.amp.chk -text "Amp Enable" -variable ampenable -relief flat
pack $lw.amp -side top -fill x
pack $lw.amp.chk -side left
bind $lw.amp.chk <ButtonRelease-1> "emc_axis_enable \$axisentry \$ampenable"
frame $lw.buttons
button $lw.buttons.set -text Set -command "emc_axis_set_output \$axisentry \$outvolts"
button $lw.buttons.done -default active -text Done -command "popdownTesting $w"
pack $lw.buttons -side bottom -fill x -pady 2m
pack $lw.buttons.set -side left -expand 1
pack $lw.buttons.done -side left -expand 1
bind $w <Return> "popdownTesting $w"
}
# if we're not running inside tkemc, then pop us up in root window
if {! [info exists tkemc]} {
popupTesting .
}

225
tcl/bin/emctuning.tcl Executable file
View File

@@ -0,0 +1,225 @@
#!/bin/sh
# the next line restarts using emcsh \
exec $LINUXCNC_EMCSH "$0" "$@"
# Load the linuxcnc.tcl file, which defines variables for various useful paths
source [file join [file dirname [info script]] .. linuxcnc.tcl]
eval emc_init $argv
###############################################################
# Description: emctuning.tcl
# EMC system identification and autotuning program
#
# Derived from a work by Fred Proctor & Will Shackleford
# License: GPL Version 2
#
# Copyright (c) 2005-2009 All rights reserved.
###############################################################
# emctuning.tcl
# EMC system identification and autotuning program
# Needs emcsh to run-- this is sourced by tkemc, but it can be run
# standalone. Make sure directory containing emcsh is in your path,
# or edit the exec line above with the path to emcsh.
# check if any emc commands exist, and quit if not
if {! [string length [info commands emc_plat]]} {
error "emctuning needs to run from \"emcsh\""
}
# set cycle time for updating, using tkemc's displayCycleTime if
# present or our own if not
if {! [info exists displayCycleTime]} {
set displayCycleTime 100
}
if {! [info exists activeAxis]} {
set activeAxis 0
}
proc goManual {} {
emc_machine off
emc_estop off
emc_mode manual
}
proc setVoltage {} {
global stepvolts
global activeAxis
emc_axis_enable $activeAxis 1
emc_axis_set_output $activeAxis $stepvolts
}
proc logIt {} {
global stepsize
global activeAxis
global stepfilename
global stepssaved
emc_log_open $stepfilename$stepssaved pos_voltage $stepsize 0 $activeAxis
emc_wait done
emc_log_start
}
proc getStep {} {
goManual
logIt
setVoltage
}
proc saveStep {} {
global stepssaved
global filestring
global stepfilename
append filestring "$stepfilename$stepssaved "
set stepssaved [expr $stepssaved + 1]
emc_log_stop
emc_log_close
}
proc doTune {} {
global filestring
global pgain
global igain
global dgain
global lambda
set string "$filestring$lambda"
scan [exec -- /usr/local/nist/emc/system $string] %s%s%s pgain igain dgain
}
# close the tuning window
proc popdownTuning {w} {
destroy $w
if {$w == "."} {
exit
}
}
# pop up the tuning window
proc popupTuning {{w .logwindow}} {
global activeAxis
global ampenable
global stepvolts
global stepsize
global stepssaved
global stepfilename
global filestring
global lambda
global pgain
global igain
global dgain
set pgain 0
set igain 0
set dgain 0
set c .tuning
set stepssaved 0
set filestring ""
# trap "." as window name, and erase it, so that widgets
# don't begin with two dots. We'll refer to the passed-in
# name "w" here; in code following this setup we'll use the
# modified name "lw"
if {$w == "."} {
set lw ""
wm title $w "EMC Tuning"
} else {
set lw $w
if {[winfo exists $w]} {
wm deiconify $w
raise $w
focus $w
return
}
toplevel $w
wm title $w "EMC Tuning"
}
# use "lw" as name of top level from now on
# force the button to reflect actual state
set ampenable [emc_axis_enable $activeAxis]
label $lw.title -text "Tuning Axis $activeAxis" -width 30 -anchor center
frame $lw.outvolts
label $lw.outvolts.lab -text "Step Voltage:" -anchor w
entry $lw.outvolts.ent -width 10 -textvariable stepvolts
frame $lw.size
label $lw.size.lab -text "Number of Samples:" -anchor w
entry $lw.size.ent -width 10 -textvariable stepsize
frame $lw.name
label $lw.name.lab -text "filename:" -anchor w
entry $lw.name.ent -width 10 -textvariable stepfilename
frame $lw.stepssaved
label $lw.stepssaved.lab -text "Number of steps:" -anchor w
label $lw.stepssaved.value -width 2 -textvariable stepssaved
frame $lw.step
button $lw.step.start -text "getStep" -command getStep
button $lw.step.save -text "saveStep" -command saveStep
button $lw.step.jogback -text "jogBack"
bind $lw.step.jogback <ButtonPress-1> {jogNeg $activeAxis}
bind $lw.step.jogback <ButtonRelease-1> {jogStop}
frame $lw.lambda
label $lw.lambda.lab -text "Lambda:" -anchor w
entry $lw.lambda.ent -width 10 -textvariable lambda
button $lw.dotune -text "doTune" -command doTune
frame $lw.p
frame $lw.i
frame $lw.d
label $lw.p.desc -text "P gain"
label $lw.i.desc -text "I gain"
label $lw.d.desc -text "D gain"
label $lw.p.value -textvariable pgain
label $lw.i.value -textvariable igain
label $lw.d.value -textvariable dgain
button $lw.done -text "OK" -default active -command "popdownTuning $w"
pack $lw.title -side top -fill x
pack $lw.outvolts -side top -fill x
pack $lw.outvolts.lab -side left
pack $lw.outvolts.ent -side right
pack $lw.size -side top -fill x
pack $lw.size.lab -side left
pack $lw.size.ent -side right
pack $lw.name -side top -fill x
pack $lw.name.lab -side left
pack $lw.name.ent -side right
pack $lw.stepssaved -side top -fill x
pack $lw.stepssaved.lab -side left
pack $lw.stepssaved.value -side left
pack $lw.step -side top -fill x
pack $lw.step.start -side left
pack $lw.step.save -side left
pack $lw.step.jogback -side left
pack $lw.lambda -side top -fill x
pack $lw.lambda.lab -side left
pack $lw.lambda.ent -side right
pack $lw.dotune -side top
pack $lw.p -side top -fill x
pack $lw.p.desc -side left
pack $lw.p.value -side left
pack $lw.i -side top -fill x
pack $lw.i.desc -side left
pack $lw.i.value -side left
pack $lw.d -side top -fill x
pack $lw.d.desc -side left
pack $lw.d.value -side left
pack $lw.done -side top
bind $w <Return> "popdownTuning $w"
}
# if we're not running inside tkemc, then pop us up in root window
if {! [info exists tkemc]} {
popupTuning .
}

522
tcl/bin/genedit.tcl Executable file
View File

@@ -0,0 +1,522 @@
#!/bin/sh
# the next line restarts using wish \
exec wish "$0" "$@"
###############################################################
# Description: genedit.tcl
# This is a simple TK text editor.
#
# Derived from a work by Fred Proctor & Will Shackleford
# License: GPL Version 2
#
# Copyright (c) 2005-2009 All rights reserved.
###############################################################
# genedit.tcl
#
# geneditStart <name> ?<initial file>? ?<browser types>? runs an editor
# named <name>. Optional parameters are the <initial file> to open,
# default "untitled.txt", and the <browser types>, default
# {{"All files" *} {Text files} {.txt}}
#
# geneditStart creates a top-level window named ".<name>", so if you call
# "geneditStart myeditor", you'll have ".myeditor" as a top-level window.
# You can have as many as you want. Sub-widgets include:
# .<name>.textframe.textwin
# .<name>.textframe.scrolly
# .<name>.menubar.file
# .<name>.menubar.edit
# .<name>.menubar.help
#
# You can pack additional widgets in .<name>, and access the widgets above
# by name to extract things like the insertion point, selected text, etc.
# Mods to fix copy, paste, delete add find and line number by rh 12/1999
# Mods to add line numbering and find and replace by rh 12/1999.
# Mod for a script menu that looks for *.ncw files in $linuxcnc::TCL_SCRIPT_DIR directory.
###############################################################
# Load the linuxcnc.tcl file, which defines variables for various useful paths
source [file join [file dirname [info script]] .. linuxcnc.tcl]
proc geneditStart {name {ifilename "untitled.txt"} {itypes { {"All files" *} {"Text files" {.txt} }}}} {
global geneditFilename geneditTypes textwin TCLSCRIPTS
if {[winfo exists .$name]} {
wm deiconify .$name
raise .$name
focus .$name
return
}
set ed .$name
toplevel $ed
# initialize filename and browser types
set geneditFilename($name) $ifilename
set geneditTypes($name) $itypes
wm title $ed [set geneditFilename($name)]
set textframe $ed.textframe
frame $textframe
set textwin $textframe.textwin
# rh replaced -setgrid true with padx 4 for easier left margin read.
text $textwin -width 80 -height 24 -padx 4 -wrap word -yscrollcommand \
"geneditScrolltext $textframe"
set scrolly $textframe.scrolly
scrollbar $scrolly -orient vert -command "$textwin yview"
pack $scrolly -side right -fill y
pack $textwin -side top -fill both -expand true
pack $textframe -side top
set menubar $ed.menubar
menu $menubar -tearoff 0
set filemenu $menubar.file
menu $filemenu -tearoff 0
$menubar add cascade -label [msgcat::mc "File"] -menu $filemenu -underline 0
$filemenu add command -label [msgcat::mc "New"] -underline 0 \
-command "geneditNewFile $name" -accelerator "Ctrl+N"
$filemenu add command -label [msgcat::mc "Open..."] -underline 0 \
-command "geneditOpenFile $name" -accelerator "Ctrl+O"
$filemenu add command -label [msgcat::mc "Save"] -underline 0 \
-command "geneditSaveFile $name" -accelerator "Ctrl+S"
$filemenu add command -label [msgcat::mc "Save As..."] -underline 5 \
-command "geneditSaveFileAs $name"
$filemenu add separator
$filemenu add command -label [msgcat::mc "Exit"] -command "destroy $ed" -underline 1
set editmenu $menubar.edit
menu $editmenu -tearoff 0
$menubar add cascade -label [msgcat::mc "Edit"] -menu $editmenu -underline 0
$editmenu add command -label [msgcat::mc "Cut"] -underline 2 \
-command "geneditCutIt $textwin" -accelerator "Ctrl+X"
$editmenu add command -label [msgcat::mc "Copy"] -underline 0 \
-command "geneditCopyIt $textwin" -accelerator "Ctrl+C"
$editmenu add command -label [msgcat::mc "Paste"] -underline 0 \
-command "geneditPasteIt $textwin" -accelerator "Ctrl+V"
$editmenu add separator
$editmenu add command -label [msgcat::mc "Select All"] -underline 7 \
-command "focus $textwin; geneditSelectAll $textwin" -accelerator "Ctrl+A"
set helpmenu $menubar.help
menu $helpmenu -tearoff 0
$menubar add cascade -label [msgcat::mc "Help"] -menu $helpmenu -underline 0
$helpmenu add command -label [msgcat::mc "About..."] -underline 0 \
-command "geneditShowAbout $name"
$ed configure -menu $menubar
bind $ed <Control-n> "geneditNewFile $name; break"
bind $ed <Control-o> "geneditOpenFile $name; break"
bind $ed <Control-s> "geneditSaveFile $name; break"
bind $ed <Control-h> "geneditShowAbout $name; break"
bind $textwin <Control-c> "geneditCopyIt $textwin; break"
bind $textwin <Control-v> "geneditPasteIt $textwin; break"
bind $textwin <Control-x> "geneditCutIt $textwin; break"
bind $textwin <Control-a> "geneditSelectAll $textwin; break"
# insert contents of filename, if it exists
if {! [catch {open $geneditFilename($name)} filein]} {
$ed.textframe.textwin delete 1.0 end
$ed.textframe.textwin insert end [read $filein]
catch {close $filein}
}
# Extra menu items for program editor
if {$name == "programEditor"} {
$filemenu add separator
$filemenu add command -label [msgcat::mc "Save and Reload"] -command "geneditSaveFile $name; loadProgramText" -underline 1
$editmenu add separator
$editmenu add command -label [msgcat::mc "Find..."] -underline 0 \
-command "geneditEnterText $textwin"
$editmenu add command -label [msgcat::mc "Renumber File..."] -underline 0 \
-command "geneditNumber"
set settingsmenu $menubar.settings
menu $settingsmenu -tearoff 0
$menubar add cascade -label [msgcat::mc "Settings"] -menu $settingsmenu -underline 0
$settingsmenu add command -label [msgcat::mc "No Numbering"] -underline 0 \
-command "set startnumbering 0"
$settingsmenu add separator
$settingsmenu add command -label [msgcat::mc "Line Numbering..."] -underline 0 \
-command "geneditSetLineNumber"
# adds a script menu that looks for *.ncw files and adds their filename to script menu
set scriptmenu $menubar.script
menu $scriptmenu
$menubar add cascade -label [msgcat::mc "Scripts"] -menu $scriptmenu -underline 1
#replaced scriptdir
#set scriptdir tcl/scripts
set files [exec /bin/ls $linuxcnc::TCL_SCRIPT_DIR]
foreach file $files {
if {[string match *.ncw $file]} {
set geneditfname [file rootname $file]
$scriptmenu add command -label $geneditfname -command "source $linuxcnc::TCL_SCRIPT_DIR/$file"
}
}
}
}
proc geneditScrolltext {tf a b} {
$tf.scrolly set $a $b
}
proc geneditShowAbout {name} {
set ed .$name
if {[winfo exists $ed.about]} {
wm deiconify $ed.about
raise $ed.about
focus $ed.about
return
}
toplevel $ed.about
wm title $ed.about [msgcat::mc "About TkEditor"]
message $ed.about.msg -aspect 1000 -justify center -font {Helvetica 12 bold} \
-text [msgcat::mc "TkEditor\n\nSimple Tcl/Tk Text Editor\n\nGPL Version 2"]
button $ed.about.ok -text [msgcat::mc "OK"] -command "destroy $ed.about"
pack $ed.about.msg $ed.about.ok -side top
bind $ed.about <Return> "destroy $ed.about"
}
proc geneditOpenFile {name} {
global geneditFilename geneditTypes programEntry
set ed .$name
set fname [tk_getOpenFile -initialdir [file dirname $geneditFilename($name)] -filetypes $geneditTypes($name)]
set geneditFileDirectory [file dirname $fname]
set geneditFilename($name) [file dirname $fname]
if {[string length $fname] == 0} {
return
}
$ed.textframe.textwin delete 1.0 end
if {[catch {open $fname} filein]} {
puts stdout [msgcat::mc "can't open %s" $fname]
} else {
$ed.textframe.textwin insert end [read $filein]
catch {close $filein}
set geneditFilename($name) $fname
wm title $ed [set geneditFilename($name)]
}
}
proc geneditSaveFile {name} {
global geneditFilename
set ed .$name
catch {file copy -force $geneditFilename($name) $geneditFilename($name).bak}
if {[catch {open $geneditFilename($name) w} fileout]} {
puts stdout [msgcat::mc "can't save %s" $geneditFilename($name)]
return
}
puts $fileout [$ed.textframe.textwin get 1.0 end]
catch {close $fileout}
}
proc geneditNewFile {name} {
set ed .$name
if {[string length [geneditSaveFileAs $name]]} {
$ed.textframe.textwin delete 1.0 end
}
}
proc geneditSaveFileAs {name} {
global geneditFilename geneditTypes
set ed .$name
set fname [tk_getSaveFile -filetypes $geneditTypes($name) \
-initialfile $geneditFilename($name)]
if {[string length $fname] == 0} {
return
}
set geneditFilename($name) $fname
wm title $ed [set geneditFilename($name)]
geneditSaveFile $name
return $fname
}
proc geneditCutIt {w} {
global selecttext
set selecttext [selection get STRING]
$w delete "insert - [string length $selecttext] chars" insert
}
proc geneditCopyIt {w} {
global selecttext
set selecttext [selection get STRING]
# should drop text tags here
# should disable copy until a paste
}
proc geneditPasteIt {w} {
global selecttext
$w insert insert $selecttext
# should set copy menubutton to normal here
}
proc geneditSelectAll {w} {
event generate $w <Control-slash>
}
# Find text processes - geneditEnterText includes hard location from top right.
proc geneditEnterText {ed} {
global textwin
toplevel $ed.find
grab $ed.find
wm title $ed.find [msgcat::mc "Find"]
wm geometry $ed.find 325x150-50+100
label $ed.find.label1 -text [msgcat::mc "Find:"] -anchor e
place $ed.find.label1 -x 5 -y 5 -width 80 -height 20
entry $ed.find.entry1 -relief sunken -textvariable sword
place $ed.find.entry1 -x 90 -y 5 -width 110 -height 20
label $ed.find.label2 -text [msgcat::mc "Replace:"] -anchor e
place $ed.find.label2 -x 5 -y 30 -width 80 -height 20
entry $ed.find.entry2 -relief sunken -textvariable rword
place $ed.find.entry2 -x 90 -y 30 -width 110 -height 20
button $ed.find.button1 -text [msgcat::mc "Find All"] -command {geneditFindAll $sword}
place $ed.find.button1 -x 5 -y 70 -width 150 -height 30
button $ed.find.button2 -text [msgcat::mc "Replace All"] -command {geneditReplaceAll $sword $rword}
place $ed.find.button2 -x 5 -y 110 -width 150 -height 30
button $ed.find.button3 -text [msgcat::mc "Skip This"] -command {geneditSkipWord $sword}
place $ed.find.button3 -x 170 -y 70 -width 150 -height 30
button $ed.find.button4 -text [msgcat::mc "Replace This"] -command {geneditReplaceWord $sword $rword}
place $ed.find.button4 -x 170 -y 110 -width 150 -height 30
button $ed.find.button5 -text [msgcat::mc "Cancel"] -command "focus -force $textwin; destroy $ed.find"
place $ed.find.button5 -x 220 -y 5 -width 100 -height 30
button $ed.find.button6 -text [msgcat::mc "Clear"] -command {
$textwin tag delete $sword
$textwin tag delete q
}
place $ed.find.button6 -x 220 -y 35 -width 100 -height 30
# set focus to entry widget 1
focus $ed.find.entry1
}
proc geneditFindAll {sword} {
global textwin
set firstplace 1.0
set l1 [string length $sword]
scan [$textwin index end] %d nl
set thisplace [$textwin index insert]
for {set i 1} {$i < $nl} {incr i} {
$textwin mark set last $i.end
set lastplace [$textwin index last]
set thisplace [$textwin search -forwards -nocase $sword $thisplace $lastplace]
if {$thisplace != ""} {
$textwin mark set insert $thisplace
scan [$textwin index "insert + $l1 chars"] %f lastplace
$textwin tag add $sword $thisplace $lastplace
$textwin tag configure $sword -background lightblue
$textwin mark set insert "insert + $l1 chars"
set thisplace $lastplace
} else {
set thisplace $lastplace
}
}
$textwin mark set insert 1.0
geneditNextWord $sword
}
proc geneditNextWord {sword} {
global textwin
set findnext [$textwin tag nextrange $sword insert]
if {$findnext == ""} {
$textwin mark set insert 1.0
$textwin see insert
return
}
set start [lindex $findnext 0]
set last [lindex $findnext end]
catch {$textwin mark set insert $start}
$textwin tag add q $start $last
$textwin tag raise q
$textwin tag configure q -background darkred -foreground white
$textwin see "insert + 5 lines"
}
proc geneditSkipWord {sword} {
global textwin
set l1 [string length $sword]
$textwin tag remove q insert "insert + $l1 chars"
$textwin tag remove $sword insert "insert + $l1 chars"
geneditNextWord $sword
}
proc geneditReplaceWord {sword rword} {
global textwin
set l1 [string length $sword]
set l2 [string length $rword]
$textwin tag remove q insert "insert + $l1 chars"
$textwin tag remove $sword insert "insert + $l1 chars"
$textwin delete insert "insert + $l1 chars"
$textwin insert insert $rword
$textwin mark set insert "insert + $l2 chars"
geneditNextWord $sword
}
proc geneditReplaceAll {sword rword} {
global textwin
set l1 [string length $sword]
set l2 [string length $rword]
scan [$textwin index end] %d nl
set thisplace [$textwin index 1.0]
for {set i 1} {$i < $nl} {incr i} {
$textwin mark set last $i.end
set lastplace [$textwin index last]
set thisplace [$textwin search -forwards -nocase $sword $thisplace $lastplace]
if {$thisplace != ""} {
$textwin mark set insert $thisplace
$textwin delete insert "insert + $l1 chars"
$textwin insert insert $rword
$textwin mark set insert "insert + $l2 chars"
set thisplace [$textwin index insert]
} else {
set thisplace $lastplace
}
}
}
# These are three variables used by the line numbering routine.
# They can be changed for a run by using the settings menu.
# If you want to set a default value different from what comes up change these here.
# Any positive integer can be used for lineincrement.
# Values of 1,2,5,10 show and can be accessed from settings menu radiobuttons.
# A 0 startnumbering value means lines will not be numbered when enter is pressed.
set startnumbering 0
# Space refers to the distance between n words and other text. Tab space is set
# here but could be single or double space. Change what's between the "".
set space " "
# Number refers to the start up value of line numbering.
set number 0
set lineincrement 10
proc geneditLineIncrement {} {
global startnumbering number lineincrement space textwin
if {$startnumbering != 0} {
$textwin insert insert "n$number$space"
incr number $lineincrement
}
}
# geneditSetLineNumber also uses a hard coded popup location from top right.
proc geneditSetLineNumber {} {
global startnumbering number lineincrement textwin
toplevel $textwin.linenumber
wm title $textwin.linenumber [msgcat::mc "Set Line Numbering"]
wm geometry $textwin.linenumber 280x160-50+100
label $textwin.linenumber.label1 -text [msgcat::mc "Increment"]
place $textwin.linenumber.label1 -x 5 -y 5
radiobutton $textwin.linenumber.incr1 -text [msgcat::mc "One"] \
-variable lineincrement -value 1 -anchor w
place $textwin.linenumber.incr1 -x 10 -y 25 -width 80 -height 20
radiobutton $textwin.linenumber.incr2 -text [msgcat::mc "Two"] \
-variable lineincrement -value 2 -anchor w
place $textwin.linenumber.incr2 -x 10 -y 45 -width 80 -height 20
radiobutton $textwin.linenumber.incr5 -text [msgcat::mc "Five"] \
-variable lineincrement -value 5 -anchor w
place $textwin.linenumber.incr5 -x 10 -y 65 -width 80 -height 20
radiobutton $textwin.linenumber.incr10 -text [msgcat::mc "Ten"] \
-variable lineincrement -value 10 -anchor w
place $textwin.linenumber.incr10 -x 10 -y 85 -width 80 -height 20
label $textwin.linenumber.label2 -text [msgcat::mc "Space"]
place $textwin.linenumber.label2 -x 130 -y 5
radiobutton $textwin.linenumber.space1 -text [msgcat::mc "Single Space"] \
-variable space -value { } -anchor w
place $textwin.linenumber.space1 -x 140 -y 25
radiobutton $textwin.linenumber.space2 -text [msgcat::mc "Double Space"] \
-variable space -value { } -anchor w
place $textwin.linenumber.space2 -x 140 -y 45
radiobutton $textwin.linenumber.space3 -text [msgcat::mc "Tab Space"] \
-variable space -value { } -anchor w
place $textwin.linenumber.space3 -x 140 -y 65
button $textwin.linenumber.ok -text [msgcat::mc "OK"] -command "destroy $textwin.linenumber" \
-height 1 -width 9
place $textwin.linenumber.ok -x 180 -y 127
label $textwin.linenumber.label3 -text [msgcat::mc "Next Number:"] -anchor e
place $textwin.linenumber.label3 -x 5 -y 130 -width 95
entry $textwin.linenumber.entry -width 6 -textvariable number
place $textwin.linenumber.entry -x 100 -y 130
tkwait visibility $textwin.linenumber
grab $textwin.linenumber
focus -force $textwin.linenumber.entry
set temp [expr $number - $lineincrement]
if {$temp > 0} {
set number $temp
} else {
set number 0
}
set startnumbering 1
bind $textwin <KeyRelease-Return> {geneditLineIncrement}
}
proc geneditNumber {} {
global textwin
geneditSetLineNumber
button $textwin.linenumber.renumber -text [msgcat::mc "Renumber"] -command geneditReNumber \
-height 1 -width 9
place $textwin.linenumber.renumber -x 160 -y 96
}
# String match with a while loop [0-9 tab space] 1 if true 0 if no match
proc geneditReNumber {} {
global textwin number lineincrement space
scan [$textwin index end] %d nl
for {set i 1} {$i < $nl} {incr i} {
if {$number > 99999} {set number 0}
$textwin insert $i.0 n$number$space
set l1 [string length n$number$space]
$textwin mark set insert "$i.$l1"
set character [$textwin get insert]
if {$character == "/"} {
$textwin insert $i.0 "/"
$textwin delete insert
}
set character [$textwin get insert]
if {$character == "n" || $character == "N"} {
set firstplace [$textwin index insert]
# find the last number in the n word
$textwin mark set insert "insert + 1 chars"
set character [$textwin get insert]
while {[string match {[0-9]} $character] == 1} {
$textwin mark set insert "insert + 1 chars"
set character [$textwin get insert]
}
# find the first character of the next word using space and tab
while {$character == " " || $character == " "} {
$textwin mark set insert "insert + 1 chars"
set character [$textwin get insert]
}
$textwin delete "$firstplace" "insert"
}
incr number $lineincrement
}
set startnumbering 0
}
# if we're not running inside tkemc, then pop us up in root window
if {! [info exists tkemc]} {
geneditStart genEditor
}

1284
tcl/bin/halconfig.tcl Executable file
View File

File diff suppressed because it is too large Load Diff

1513
tcl/bin/halshow.tcl Executable file
View File

File diff suppressed because it is too large Load Diff

943
tcl/bin/pickconfig.tcl Executable file
View File

@@ -0,0 +1,943 @@
#!/bin/sh
# this line restarts using wish \
exec wish "$0" "$@"
###############################################################
# Description: pickconfig.tcl
# This file validates a LinuxCNC configuration
# passed to it, or prompts the user to choose
# one.
#
# Author: John Kasunich
# License: GPL Version 2
#
# Copyright (c) 2005-2009 All rights reserved.
###############################################################
#
# usage:
# pickconfig <config-path>
#
# <config-path> is one or more directories (separated with
# colons) in which pickconfig should search for configs.
# pickconfig will open a GUI window displaying all configs
# that it finds and ask the user to choose one, then print
# the path to the chosen config and exit.
#
###############################################################
# Load the linuxcnc.tcl file, which defines variables for various useful paths
source [file join [file dirname [info script]] .. linuxcnc.tcl]
set logo [linuxcnc::image_search linuxcnc-wizard]
image create photo machinelogo
option add *font [linuxcnc::standard_font]
option add *Text.font [linuxcnc::standard_fixed_font]
option add *Entry*background white
option add *Listbox*background white
option add *Tree*background white
################### MAINTENANCE ITEMS #####################
# flat structure:
# Ini files should always refer to ../../nc_files so
# that hey will work in run-in-place and deb-installed
# systems.
# Config subdirs can be moved with little impact when
# ../../nc_files relative link is used.
#
# hierarchical structure:
# Ini files must refer to appropriate nc_files by
# relative links so that they will work in run-in-place
# and deb-installed systems.
# Ini files must be edited if config subdirs are moved to
# a different depth in the tree to update the relative
# links
#
set ::make_flat_user_dirs 1 ;# 0 ==> hierarchical
# start on this node if no ~/.linuxcncrc:
set ::default_start_node sim/axis/axis.ini
# exclude directories that should never be offered
set ::exclude_list [list common]
# exclude files with special names
set ::exclude_file_list _panelui.ini
# support filenames that are never copied to user:
set ::never_copy_list [list maintainer.txt nodemocopy]
# emphasize sim ini configs that have the most support by reordering
# reorder: priority low to high:
set ::preferred_names [list \
low_graphics \
gmoccapy \
gscreen \
touchy \
ngcgui \
axis \
by_machine \
by_interface \
sim \
]
# support creation of links for newly added _lib dirs in nc_files
set ::always_update_nc_files 1
################### PROCEDURE DEFINITIONS #####################
set desktopdir [exec bash -c {test -f ${XDG_CONFIG_HOME:-~/.config}/user-dirs.dirs && . ${XDG_CONFIG_HOME:-~/.config}/user-dirs.dirs; echo ${XDG_DESKTOP_DIR:-$HOME/Desktop}}]
# use initialize_config for bwidget and .linuxcncrc
proc initialize_config {} {
# need bwidget
set result [catch {package require BWidget 1.7}]
if {$result != 0} {
puts stderr $result
tk_messageBox -icon error -type ok -message [msgcat::mc "Can't find the bwidget 1.7 package. There is a debian bwidget package; install \nit with sudo apt-get install bwidget."]
exit
destroy .
} else {
if {[catch {open $::env(HOME)/.linuxcncrc} programin]} {
return
} else {
set rcstring [read $programin]
catch {close $programin}
set ret [getVal $rcstring PICKCONFIG LAST_CONFIG ]
set ::openmode 1
return $ret
}
}
}
# FIXME add trap for comment on the first of a line.
proc getVal {stringa sect var} {
set varval ""
set x [regexp -indices -- "$sect.*$var *= *" $stringa indexes]
if {$x } {
set startindex [lindex $indexes 1]
set x [regexp -start $startindex -linestop -- ".*" \
$stringa varval ]
set varval [string trim $varval]
}
return $varval
}
proc setVal {stringb sect var newval} {
set x [regexp -indices -- "$sect.*$var *= *" $stringb start ]
if {$x } {
set startindex [expr [lindex $start 1] +1]
set x [regexp -indices -start $startindex -linestop -- ".*" $stringb end ]
set endindex [lindex $end 1]
set newstring [string replace $stringb $startindex $endindex $newval]
return $newstring
}
}
# main button callback, it assigns the button name to '::choice'
proc button_pushed { button_name } {
set ::choice $button_name
}
# slider process is used for several widgets
proc sSlide {f a b} {
$f.sc set $a $b
}
proc title {node} {
if [file isfile $node] {
set txt "CURRENT: [file tail $::selected_node]"
} else {
set txt ""
}
wm title . "[msgcat::mc "LinuxCNC Configuration Selector"] $txt"
}
proc find_usable_nodes {startdir} {
return [exec find -L $startdir -type f \
-name "*.ini" -o -name "*.demo" ]
} ;# find_usable_nodes
proc name_is_usable_nodename {node} {
if { [ regexp {.*\.ini$} $node ] == 1 \
|| [ regexp {.*\.demo$} $node ] == 1 \
} {
if {[lsearch $::exclude_file_list [file tail $node]] >= 0} {
return 0
}
return 1 ;# ok
}
return 0 ;# fail
} ;# name_is_usable_nodename {node}
proc ok_to_copy_config {filename} {
# The following tests determines when to copy files to a user directory:
# 1) If the directory for the selected file is not writable,
# then it is presumed to be a system dir running from an install (by
# a deb install typically) so copy the configuration to user directory.
#
# 2) For non-RIP builds, if the file is not under the user's
# myconfigs_node, force copy regardless of filesystem writability.
# This catches distros where installed sample-configs happen to be
# writable by the running user (e.g. Gentoo system-wide installs to
# a group-writable path).
#
# 3) if the directory is included in ::user_aux_dirs (as
# specified by the environmental variable LINUXCNC_AUX_EXAMPLES),
# then the config is copied to user directory to avoid overwriting
# a developmental source directory.
#
# Otherwise, it is presumed to be a Run-In-Place directory and
# copying to another directory is not wanted.
#
# For convenience in testing pickconfig by itself in rip builds:
# export debug_pickconfig=1
# This forces copying to the user directory so that the copied
# configs can be tested.
set forcecopy 0
if { [info exists ::env(debug_pickconfig)] \
&& [string first $::myconfigs_node $filename]} {
set forcecopy 1
}
set is_rip [expr {[info exists ::linuxcnc::RUN_IN_PLACE]
&& $::linuxcnc::RUN_IN_PLACE eq "yes"}]
if {!$is_rip && [string first $::myconfigs_node $filename] != 0} {
set forcecopy 1
}
if { [info exists ::user_aux_dirs] } {
foreach dir $::user_aux_dirs {
if {[file dirname $filename] == "$dir" } {
set forcecopy 1
}
}
}
if { ![file writable [file dirname $filename]]
|| $forcecopy
} {
set filetype [file extension $filename]
if {$filetype == ".ini"} { return 1 ;# ok }
if {$filetype == ".demo"} {
set nocopyfile [file join [file dirname $filename] nodemocopy]
if {![file exists $nocopyfile]} { return 1 ;# ok }
}
}
return 0 ;# not ok
} ;# ok_to_copy
# Notes on text displayed in detail_box widget:
# if node is usable (an ini file named xxx.ini or xxx.demo), then:
# show xxx.txt if it exists
# else
# show README if it exists in the directory for node
# else
# show "No Details available"
#
# if node is a directory, then:
# show README if it exists in the directory for node
# called when user clicks tree node
proc node_clicked {} {
set node [$::tree selection get]
set ::selected_node $node
title $node
if {$node == ""} return
set node [lindex $node 0]
$::tree selection set $node
$::tree see $node
set readme ""
if [name_is_usable_nodename $node] {
# acceptable name
# enable changes to the details widget
set node [format %s $node]
set dir [ file dirname $node]
set name [ file rootname [file tail $node ] ]
set readme [file join $dir $name.txt]
if { ![ file exists $readme ] } {
set readme [file join [ file dirname $node ] README ]
}
set image [file join $dir $name.gif]
if { ![ file exists $image ] } {
set image [ file join [ file dirname $node ] logo.gif ]
}
if { [ file readable $image ] } {
machinelogo blank
machinelogo read $image
puts stderr "using image $image"
$::detail_box image create end -image machinelogo
$::detail_box insert end "\n"
$::detail_box tag configure centered -justify center
$::detail_box tag add centered 0.0 0.end
}
# save selection
set ::inifile $node
# enable the OK button
$::button_ok configure -state normal
bind . <Return> {button_pushed OK}
bind . <KP_Enter> {button_pushed OK}
} else {
if {[file isdirectory $node]} {
set readme [file join $node README]
# clear selection
set ::inifile ""
# disable the OK button
$::button_ok configure -state disabled
bind . <Return> ""
bind . <KP_Enter> ""
}
}
# remove old text
$::detail_box configure -state normal
$::detail_box delete 1.0 end
if { [ file readable $readme ] } {
# description found, read it
set descr [ read -nonewline [ open $readme ]]
# expect file with unbroken paragraphs
$::detail_box insert end $descr
} else {
if [file isdirectory $node] {
if {"$node" == "$::myconfigs_node"} {
$::detail_box insert end "Your existing configs"
} elseif { "$node" == "$::sampleconfigs_node"} {
$::detail_box insert end "Available configs"
}
# else leave detail_box empty
} else {
# no description, gotta tell the user something
$::detail_box insert end [msgcat::mc "No details available."]
}
}
# lock it again
$::detail_box configure -state disabled
}
################ MAIN PROGRAM STARTS HERE ####################
set ::configs_dir_list $linuxcnc::CONFIG_DIR
set ::myconfigs_node $linuxcnc::USER_CONFIG_DIR
# order convention for items in the linuxcnc::USER_CONFIG_DIR list:
set ::sampleconfigs [lindex $::configs_dir_list end] ;# last item
# check for auxiliary applications example configs installed in
# known directory defined by: linuxcnc::LINUXCNC_AUX_ExAMPLES
set aux_examples $linuxcnc::LINUXCNC_AUX_EXAMPLES
set ::aux_dir_list {}
if [file isdirectory $aux_examples] {
foreach auxdir [glob $aux_examples/*] {
puts stderr "pickconfig: installed aux examples: $auxdir"
lappend ::configs_dir_list $auxdir
lappend ::aux_dir_list $auxdir
}
}
# user may specify auxiliary config directories using the environmental
# variable LINUXCNC_AUX_CONFIGS (a colon (:) separated path)
# This is useful for testing auxiliary apps without using a deb install
if [info exists ::env(LINUXCNC_AUX_CONFIGS)] {
foreach auxdir [split $::env(LINUXCNC_AUX_CONFIGS) :] {
if { [file isdirectory $auxdir] \
&& [file readable $auxdir] } {
set normauxdir [file normalize $auxdir]
puts stderr "pickconfig: user aux examples: $normauxdir"
lappend ::configs_dir_list $normauxdir
lappend ::user_aux_dirs $normauxdir ;# forcecopy
} else {
puts stderr "pickconfig: LINUXCNC_AUX_CONFIGS invalid directory:"
puts stderr " $auxdir"
puts stderr "continuing"
}
}
}
set ::last_ini "none"
set ::last_ini [initialize_config]
set ::openmode 0
if { [file exists [file join $::sampleconfigs $::default_start_node]]
|| "$::last_ini" != ""
} {
set ::openmode 1
}
# set options that are common to all widgets
foreach class { Button Entry Label Listbox Scale Text } {
option add *$class.borderWidth 1 100
}
# make a toplevel and a master frame.
title ""
set logo [label .logo -image $logo]
set top [frame .main -borderwidth 0 -relief flat ]
pack $logo -side left -anchor nw
pack $top -side left -expand yes -fill both
wm geo . 780x480
wm minsize . 780 480
proc SW { args } {
set res [eval ScrolledWindow $args]
$res.vscroll configure -relief flat
::${res}:cmd configure -highlightthickness 1
return $res
}
# a frame for packing the top window
set f1 [ frame $top.f1 ]
set message [msgcat::mc "Welcome to LinuxCNC.\n\nSelect a machine configuration from the list on the left.\nDetails about the selected configuration will appear in the display on the right.\nClick 'OK' to run the selected configuration"]
set lbl [ label $f1.lbl -text $message -justify left -padx 15 -pady 10 -wraplength 600 ]
pack $lbl -anchor w
# a subframe for the tree/detail box
set f2 [ frame $f1.f2 -borderwidth 0 -relief flat -padx 15 ]
# Let the tree scroll
set s1 [ SW $f2.f3 -auto both]
$s1 configure -relief sunken -borderwidth 2
# get the font height to scale the height of the tree rows
set font_linespace [font metrics [linuxcnc::standard_font] -linespace]
# the tree
set ::tree [Tree $s1.tree -highlightthickness 0 \
-width [expr {int($font_linespace * 1.33)}] -relief flat -padx 4 \
-deltay $font_linespace\
]
$s1 setwidget $::tree
pack $s1 -fill y -expand n -side left
# pack the tree into its subframe
bind $::tree <<TreeSelect>> { node_clicked }
$::tree bindText <Double-1> { $f5.ok invoke ;# }
# bwidget 1.7.0 does not generate <<TreeSelect>> events for keyboard navigation.
# These bindings fix that.
bind $::tree.c <KeyPress-Up> [list +event generate $::tree <<TreeSelect>>]
bind $::tree.c <KeyPress-Down> [list +event generate $::tree <<TreeSelect>>]
# Let the text scroll
set f4 [ SW $f2.f4 -scrollbar vertical]
$s1 configure
# a text box to display the details
set tb [ text $f4.tb -width 30 -wrap word -padx 6 -pady 6 \
-takefocus 0 -state disabled \
-relief flat -borderwidth 0 -height 12]
$f4.vscroll configure -takefocus 1
$f4 setwidget $tb
set ::detail_box $tb
# pack the subframe into the main frame
pack $f2 -side top -fill both -expand y
pack $f4 -side left -padx 3 -fill both -expand y
# a subframe for the buttons
set f5 [ frame $f1.f5 ]
button $f5.ok -text [msgcat::mc "OK"] -command "button_pushed OK" -width 8 -default active
set ::button_ok $f5.ok
$::button_ok configure -state disabled
button $f5.cancel -text [msgcat::mc "Cancel"] -command "button_pushed Cancel" -width 8 -default normal
pack $f5.cancel -side right -padx 4 -pady 4
pack $f5.ok -side right -padx 4 -pady 4
pack $f5 -side bottom -anchor e -fill x -expand n -padx 15
pack $f1 -fill both -expand y
set ::config_count 0
proc describe {dir} {
if {"$dir" == "$::myconfigs_node"} {
return [msgcat::mc "My Configurations"]
}
if {"$dir" == "$::sampleconfigs"} {
set ::sampleconfigs_node $dir
return [msgcat::mc "Sample Configurations"]
}
if {[lsearch $::aux_dir_list $dir] >= 0} {
return [file tail $dir]
} else {
return $dir
}
}
proc treeopen {args} {
set beforevisible [$::tree visible $::selected_node]
update
set visible [$::tree visible $::selected_node]
if {!$beforevisible && $visible && [info exists ::restorebox] } {
set state [$::detail_box cget -state]
$::detail_box configure -state normal
$::detail_box insert end $::restorebox
$::detail_box configure -state $state
unset ::restorebox
}
} ;# treeopen
proc treeclose {args} {
set visible [$::tree visible $::selected_node]
if {!$visible && ![info exists ::restorebox] } {
set ::restorebox [$::detail_box get 1.0 end]
set state [$::detail_box cget -state]
$::detail_box configure -state normal
$::detail_box delete 1.0 end
$::detail_box configure -state $state
}
} ;# treeclose
proc walktree {dir} {
if ![info exists ::openmode] {set ::openmode 0}
if ![$::tree exists $dir] {
set ::lvl $dir
$::tree insert end root $dir -text [describe $dir] -open $::openmode
}
set bothlist [lsort [glob -nocomplain $dir/*]]
if { [info exists ::sampleconfigs_node]
&& "$dir" == "$::sampleconfigs_node"} {
set bothlist [rearrange $bothlist]
}
set sortedlist {}
set filelist {}
set dirlist {}
# display files before directories
foreach item $bothlist {
if [file isdirectory $item] {
lappend dirlist $item
} else {
lappend sortedlist $item
}
}
foreach f $dirlist { lappend sortedlist $f }
foreach f $sortedlist {
if [file isdirectory $f] {
if {[lsearch $::exclude_list [file tail $f]] == 0} continue
set foundini [find_usable_nodes $f]
if {"$foundini" == ""} {
verbose "no usable files, skipping directory: $f"
continue
}
set text [file tail $f]
$::tree insert end $::lvl $f -text $text -open $::openmode
set restore $::lvl
set ::lvl $f
walktree $f ;# recursion
set ::lvl $restore
} else {
if [name_is_usable_nodename $f] {
set text [file rootname [file tail $f]]
$::tree insert end $::lvl $f -text $text -open $::openmode
incr ::config_count
continue
} else {
verbose "skipping non-start_node file: $f"
}
}
}
} ;# walktree
proc rearrange l {
set taillist {}
foreach item $l {
lappend taillist [file tail $item]
}
foreach name $::preferred_names {
set idx [lsearch $taillist $name]
if {$idx < 0} continue
set found [lindex $l $idx]
set taillist [lreplace $taillist $idx $idx]
set taillist [linsert $taillist 0 $name]
set l [lreplace $l $idx $idx]
set l [linsert $l 0 $found]
}
return $l
} ;# rearrange
proc verbose {msg} {
if ![info exists ::env(verbose_pickconfig)] return
puts stderr "pickconfig:$msg"
}
proc minimal_tree {node} {
if {"$node" == "root"} return
set p [$::tree parent $node]
foreach c [$::tree nodes $p] {
if {"$c" == "$node"} continue
$::tree closetree $c 1 ;# 1 ==> recurse
}
minimal_tree $p ;#recursion
} ;# minimal_tree
foreach dir $::configs_dir_list {
if {[info exists visited($dir)]} continue
if {![file isdirectory $dir]} {
verbose "pickconfig: skipping <$dir>, not a directory"
continue
}
set visited($dir) {}
walktree $dir
}
if { $::config_count == 0 } {
puts stderr [msgcat::mc "ERROR: no configurations found in path '%s'" $configs_dir_list]
exit 1
}
bind . <Escape> {button_pushed Cancel}
bind . <Return> ""
bind . <KP_Enter> ""
wm protocol . WM_DELETE_WINDOW {button_pushed Cancel}
proc wait_and_see {node {wait 10}} {
set yv [$::tree yview]
if {![winfo viewable $::tree] || [lindex $yv 0] == [lindex $yv 1]} {
after $wait [list wait_and_see $node [expr $wait*2]]
} else {
$::tree see $node
$::tree xview moveto 0.0
minimal_tree $node
node_clicked
}
}
proc get_file_contents {f} {
set fd [open $f]
set contents [read $fd]
close $fd
return $contents
}
proc put_file_contents {f c} {
set fd [open $f w]
puts -nonewline $fd $c
close $fd
}
proc fail_if_linkname_exists {linkname} {
if { [file exists $linkname] \
&& [file type $linkname] != "link"} {
set type [file type $linkname]
tk_messageBox -title "Make link fail" \
-icon error -type ok \
-message "Cannot create link for\n$linkname\n\
because of existing $type with same name\n\n\
Remove (or rename) $linkname"
exit 1
}
}
proc prompt_copy configname {
set res [tk_dialog .d [msgcat::mc "Copy Configuration?"] [msgcat::mc "Would you like to copy the %s configuration to your home directory so you can customize it?" $configname] warning 0 [msgcat::mc "Yes"] [msgcat::mc "Cancel"]]
if {$res == -1 || $res == 1} { return "" }
set chosendir [format %s [file dirname $configname]]
foreach d $::configs_dir_list {
if {"$d" == "$chosendir"} {
# found chosendir at level 0 of a directory in the ::configs_dir_list
set copytodir [format %s [file join $::myconfigs_node [file tail $chosendir]]]
break
}
# if chosendir not found at level 0, try subdirs
# note: expect $d ($::configs_dir_list) in normalized form
if {0 != [string first "$d/" $configname]} {
continue
} else {
# found chosendir as a subdir
set idx [expr 1 + [string length $d]] ;#
set hiername [string range $chosendir $idx end]
if $::make_flat_user_dirs {
# Flat dir structure for copied configs
# create copytodir at one level below ::myconfigs_node
set flatname [string map {/ .} $hiername]
set copytodir [format %s [file join $::myconfigs_node $flatname]]
} else {
# Hierarchical dir structure for copied configs
# create copytodir following hierarchy
set copytodir [format %s [file join $::myconfigs_node $hiername]]
}
break
}
}
set copybase $copytodir
set i 0
# distribution config ini files expect nc_files at same level as configs dir
set ncfiles [file normalize [file join $::myconfigs_node ../nc_files]]
file mkdir [file join $::myconfigs_node]
set obsoletedir [file normalize [file join $::env(HOME) emc2]]
if [file isdir $obsoletedir] {
tk_messageBox -title "Copy Configuration Notice" \
-message "A directory named:\n \
$obsoletedir\n \
exists \n\n \
You may want to copy items to the new directory:\n \
[file normalize [file join $::myconfigs_node ..]]" \
-type ok
}
if {$::always_update_nc_files || ![file exists $ncfiles]} {
file mkdir $ncfiles ;# tcl: ok if it exists
set refname $linuxcnc::NCFILES_DIR
set linkname [file join $ncfiles examples]
fail_if_linkname_exists $linkname
# tcl wont overwrite any existing link, so remove
catch {file delete $linkname}
file link -symbolic $linkname $refname
# liblist: libs used in inifiles for [RS274NGC]SUBROUTINE_PATH
# example: ngcgui uses lib named ngcgui_lib
set _libs [glob [file join $linuxcnc::NCFILES_DIR *_lib]]
foreach lib $_libs {
if ![file isdir $lib] continue
lappend liblist $lib
}
foreach lib $liblist {
set refname [file join $linuxcnc::NCFILES_DIR $lib]
set linkname [file join $ncfiles [file tail $lib]]
fail_if_linkname_exists $linkname
if {[file exists $linkname]} {
# tcl wont overwrite any existing link, so remove
file delete $linkname
}
# avoid error if no target
if [file exists $refname] {
file link -symbolic $linkname $refname
}
}
set dir [file tail $ncfiles]
set date [clock format [clock seconds] -format "%d%b%Y %T"]
set fd [open [file join $ncfiles readme.ngc] w]
puts $fd "(info: readme.ngc)"
set msg "(debug, readme.ngc autogenerated by:)\n"
set msg "${msg}(debug, $::argv0)\n"
set msg "${msg}(debug, $date)\n"
set msg "${msg}(debug, LinuxCNC vmajor=#<_vmajor> vminor=#<_vminor>)\n"
set msg "${msg}(debug, User writable directory: $dir)\n"
set msg "${msg}(debug, Example files: $dir/examples)\n"
foreach lib $liblist {
set msg "${msg}(debug, $lib subroutines: $dir/${lib}_lib)\n"
}
puts $fd $msg
# make readme.ngc compatible with ngcgui:
# (repeat the debug prints within the subroutine)
puts $fd "o<readme> sub"
puts $fd $msg
puts $fd " #<parm1> = #1 (=123 pvalue)"
puts $fd " (debug, readme.ngc: pvalue = #<parm1>)"
puts $fd "o<readme> endsub"
# include m2 to preclude message:
# "File ended with no percent sign or program end"
puts $fd "m2"
close $fd
}
while {1} {
if [file exists $copytodir] {
incr i
set copytodir "$copybase-$i" ;# user may have protected directory, so bump name
# limit attempts to avoid infinite loop for hard error
if {$i > 1000} {
puts stderr "$::argv0:$msg"
tk_messageBox -icon error -type ok \
-message [msgcat::mc "Failed to mkdir for $copytodir\n<$msg>"]
destroy .
exit
}
continue ;# try again
} else {
# note: file mkdir will make parents as required
if [catch { file mkdir $copytodir } msg] {
continue ;# try again
}
}
# A hierarchy of directories is allowed.
# User selects an offered ini file.
# All files in same directory are copied.
# The target of a linked file is copied
foreach f [glob -directory $chosendir *] {
# nc_files (as a symlink) may be present for rip testing
# nc_files (as a symlink) not copied here (handled elsewhere)
if { [file tail $f] == "nc_files"
&& [file type $f] == "link" } {
verbose "pickconfig: not copying link: $f"
continue
}
if {[lsearch $::never_copy_list [file tail $f]] >= 0} continue
# is_special: subdir is to be copied
set is_special 0
if { "" == [find_usable_nodes $f] } {
# ok: no usable child files so the directory can be copied
set is_special 1
}
switch [file type $f] {
link {
if {$is_special} {
# since is link, require:
# -r recursive, -L dereference
exec cp -rL [file join $chosendir $f] $copytodir
} else {
# to follow sym links correctly, use system cp:
exec cp [file join $chosendir $f] $copytodir
}
}
file {file copy "$f" $copytodir}
directory { # recursive copy of subdirs
if {$is_special } {
# -r recursive
exec cp -r [file join $chosendir $f] $copytodir
}
}
default {puts stderr \
"prompt_copy:unsupported type=[file type $f] for $f"}
}
}
foreach f [glob -directory $copytodir *] {
file attributes $f -permissions u+w
if {[file extension $f] == ".ini"} {
set c [get_file_contents $f]
# note: the following regsub _typically_ forces:
# PROGRAM_PREFIX=/home/username/linuxcnc/nc_files
regsub {(?n)^(PROGRAM_PREFIX\s*=\s*).*$} $c "\\1$ncfiles" c
put_file_contents $f $c
}
if {$::tcl_platform(platform) == "unix"} {
file attributes $f -permissions u+w
}
}
# make convenience link to HALLIB_DIR:
file link -symbolic [file join $copytodir hallib] $::env(HALLIB_DIR)
break
}
tk_dialog .d [msgcat::mc "Configuration Copied"] [msgcat::mc "The configuration file has been copied to %s. Next time, choose this location when starting LinuxCNC." $copytodir] info 0 [msgcat::mc "OK"]
return $copytodir/[file tail $configname]
}
# add the selection set if a ::last_ini has been found in ~/.linuxcncrc
if { $::last_ini != -1
&& [file exists $::last_ini]
&& ![catch {$::tree index $::last_ini}]} {
set start_node $::last_ini
} else {
set start_node ${::sampleconfigs}/$::default_start_node
}
if [catch {
$::tree selection set $start_node
wait_and_see $start_node
}] {
set ::openmode 0
puts stderr "pickconfig: cannot find expected start_node <$start_node>, continuing"
}
# update and enable commands after initial setup of tree
update
set ::selected_node [$::tree selection get]
title $::selected_node
$::tree configure \
-closecmd {after cancel treeclose; after idle treeclose} \
-opencmd {after cancel treeopen; after idle treeopen}
proc make_shortcut {inifile} {
if {[catch {open $inifile} inifd]} { return }
set inistring [read $inifd]
close $inifd
switch [file extension $inifile] {
".ini" {set name [getVal $inistring EMC MACHINE]}
".demo" {set name [lindex [split [file tail $inifile] "."] 0]
}
default {set name linuxcnc-other}
}
if {"$name" == ""} {set name LinuxCNC-other}
set filename0 [file join $::desktopdir [file rootname [file tail $inifile]]]
set filename ${filename0}.desktop
set i 0
while {[file exists $filename]} {
incr i
set filename $filename0${i}.desktop
}
exec linuxcncmkdesktop $inifile $name > $filename
file attributes $filename -permissions +x
tk_dialog .d [msgcat::mc "Shortcut Created"] [msgcat::mc "A shortcut to this configuration file has been created on your desktop. You can use it to automatically launch this configuration."] info 0 [msgcat::mc "OK"]
}
set make_shortcut 0
if {[file isdir $::desktopdir]} {
checkbutton $f5.c -variable make_shortcut \
-text [msgcat::mc "Create Desktop Shortcut"] \
-state normal
pack $f5.c -side left -expand 1 -anchor w
}
while {1} {
focus $::tree
vwait ::choice
if { $::choice == "OK" } {
if [ok_to_copy_config $::inifile] {
set copied_inifile [prompt_copy $::inifile]
if {$copied_inifile == ""} {
continue ;# user canceled
} else {
set ::inifile $copied_inifile
}
}
if {$make_shortcut} { make_shortcut $::inifile }
puts $::inifile ;# this is the result for this script (to stdout)
# test for ~/.linuxcncrc file and modify if needed.
# or make this file and add the var.
if {[file exists $::env(HOME)/.linuxcncrc]} {
if {$::inifile == $::last_ini} {
exit
} else {
if {[catch {open $::env(HOME)/.linuxcncrc} programin]} {
return
} else {
set rcstring [read $programin]
catch {close $programin}
}
set ret [setVal $rcstring PICKCONFIG LAST_CONFIG $::inifile ]
catch {file copy -force $name $name.bak}
if {[catch {open $::env(HOME)/.linuxcncrc w} fileout]} {
puts stdout [msgcat::mc "can't save %s" $::env(HOME)/.linuxcncrc ]
exit
}
puts $fileout $ret
catch {close $fileout}
exit
}
}
set newfilestring "# .linuxcncrc is a startup configuration file for LinuxCNC. \n# format is INI like. \n# \[SECTION_NAME\] \n# VARNAME = varvalue \n# where section name is the name of the system writing to this file \n\n# written by pickconfig.tcl \n\[PICKCONFIG\]\nLAST_CONFIG = $::inifile\n"
if {[catch {open $::env(HOME)/.linuxcncrc w+} fileout]} {
puts stderr [msgcat::mc "can't save %s" $::env(HOME)/.linuxcncrc ]
exit
}
puts $fileout $newfilestring
catch {close $fileout}
}
break
}
exit

82
tcl/bin/popimage Executable file
View File

@@ -0,0 +1,82 @@
#!/bin/sh
# the next line restarts using wish \
exec ${LINUXCNC_EMCSH-wish} "$0" "$@"
###############################################################
# Description: popimage
# A Tcl/Tk script that displays the image listed
# in the relevant ini file for the time listed in
# that file.
#
# Derived from a work by Fred Proctor & Will Shackleford
# Author:
# License: GPL Version 2
#
# Copyright (c) 2005 All rights reserved.
#
# Last change:
###############################################################
# INI variables include
# [DISPLAY]
# Introductory graphic
# INTRO_GRAPHIC = emc2.gif
# INTRO_TIME = 5
# If time is set to zero no image is used
###############################################################
if {$argc < 1} {
puts stderr "syntax: popimage <image file>"
exit
}
load [file join [file dirname [info script]] .. linuxcnc.so]
. configure -borderwidth 0 -highlightthickness 0
set img [lindex $argv 0]
set imgtime 5
if {$argc > 1} {
set imgtime [lindex $argv 1]
}
if {$imgtime <= 0} {
set imgtime 5
}
# now convert imgtime to milliseconds
set imgtime [expr {int($imgtime * 1000)}]
if {! [file exists $img]} {
puts stderr "can't find file $img"
exit
}
if {[catch {image create photo -file $img} image]} {
puts stderr "bad image file $img"
exit
}
set w [image width $image]
set h [image height $image]
canvas .c -width $w -height $h -borderwidth 0 -highlightthickness 0
.c create image 0 0 -anchor nw -image $image
.c create text 4 [expr $h-4] -anchor sw \
-text $env(LINUXCNCVERSION) -fill white -font {Helvetica 18}
pack .c
# Center popup in screen.
set si [lindex [multihead] 0]
set x0 [lindex $si 0]
set y0 [lindex $si 1]
set x1 [lindex $si 2]
set y1 [lindex $si 3]
set cx [expr {($x0+$x1)/2}]
set cy [expr {($y0+$y1)/2}]
set x [expr {$cx-$w/2}]
set y [expr {$cy-$h/2}]
wm geometry . "+$x+$y"
wm overrideredirect . 1
after $imgtime exit

516
tcl/bin/tkbackplot.tcl Executable file
View File

@@ -0,0 +1,516 @@
#!/bin/sh
# the next line restarts using emcsh \
exec $LINUXCNC_EMCSH "$0" "$@"
###############################################################
# Description: genedit.tcl
# This file dumps info to a logging file from tkmc.
#
# Authors: Ray Henry & Paul Corner
# License: GPL Version 2
#
# Copyright (c) 2009 All rights reserved.
###############################################################
# This is plot processes for tkemc popup under the view menu
# of tkemc. The fixed size of the canvas viewing area is 500x250
# pixels less scrollbars. The full canvas could be much larger.
# Several local variables may be set below to match machines.
###############################################################
# Load the linuxcnc.tcl file, which defines variables for various useful paths
source [file join [file dirname [info script]] .. linuxcnc.tcl]
# These offset plot zero from canvas zero.
set xoffset 0
set yoffset 0
set zoffset 0
# These set the axis directions. +1 one plots like graph
# paper with positive up and to the right. The canvas widgets orient so that
# xy plot is looking down on the work area from the operator position.
# x is left right and y is up down.
# xz plot is looking into the work area along the axis of y
# yz plot is looking into the work area along the axis of x
# to reverse as axis change its value to -1 (don't put other numbers here)
set xdir 1
set ydir 1
set zdir 1
# These set the size of the canvas widget behind the viewing area.
# Set for the size of your machine or larger. They can also be set so that you
# place your machine home about the same location in canvas space that it has on the
# real machine.
# They need not be the same for each axis.
# the value used is pixels so multiply your machine workspace size in inches by 72.
# the default shipped here is for a center zero'd machine with 1000 pixels both left/right
# and 500 pixels both top/bottom in all axis.
# Read variable names (xytopx) as "xy plot topleft x" value etc.
# If your machine were top right homed on xy, you might use
# xy -1900 -100 100 900
# xz -1900 -100 100 900
# yz -100 -100 1900 900
# These set top left and bottom right of xy canvas
set xytopx -1000
set xytopy -500
set xybotx 1000
set xyboty 500
# These set top left and bottom right of xz canvas
set xztopx -1000
set xztopz -500
set xzbotx 1000
set xzbotz 500
# These set top left and bottom right of yz canvas
set yztopy -1000
set yztopz -500
set yzboty 1000
set yzbotz 500
# This variable sets the default size of the plot and can be thought of as number of
# pixels per inch of machine motion. The default (40) will give about .55 screen
# inch per inch moved.
set size 40
#These variables set the default angles used for the 3d plot. in this release,
#only the xyangle is used though the others are also shown on the setup screen
# These three can go.
set xyangle 30
set xangle 30
set yangle 30
set zangle 60
set xycosangle 0
set xysinangle 0
# I used these in the latest edit - Paul.
# pop up the plot window
proc popupPlot {} {
global screen tab
global xytopx xytopy xybotx xyboty
global xztopx xztopz xzbotx xzbotz
global yztopy yztopz yzboty yzbotz
global xycenterx xycentery xzcenterx xzcenterz yzcentery yzcenterz
set d .plot
if {[winfo exists $d]} {
wm deiconify $d
raise $d
focus $d
return
}
toplevel $d
wm title $d [msgcat::mc "TkLinuxCNC BackPlot"]
# use "pw" as name of top level from now on
set pw .plot
set tab [frame $pw.tabs]
button $tab.xy -relief flat -font {Helvetica -10 bold} -anchor n -width 8 \
-text {X - Y} -command {selectPlot xy} -borderwidth 0
button $tab.xz -relief flat -font {Helvetica -10 bold} -anchor n -width 8 \
-text {X - Z} -command {selectPlot xz} -borderwidth 0
button $tab.yz -relief flat -font {Helvetica -10 bold} -anchor n -width 8 \
-text {Y - Z} -command {selectPlot yz} -borderwidth 0
button $tab.3d -relief flat -font {Helvetica -10 bold} -anchor n -width 8 \
-text { 3D } -command {selectPlot 3d} -borderwidth 0
button $tab.config -relief raised -font {Helvetica -10 bold} -anchor n -width 8 \
-text [msgcat::mc "SETUP"] -command {selectPlot config} -borderwidth 1
button $tab.reset -relief raised -font {Helvetica -10 bold} -anchor n -width 8 \
-text [msgcat::mc "RESET"] -command {erasePlot} -borderwidth 1
button $tab.can -relief raised -font {Helvetica -10 bold} -anchor n -width 8 \
-text [msgcat::mc "CANCEL"] -command {destroy .plot} -borderwidth 1
pack $tab.xy $tab.xz $tab.yz $tab.3d $tab.config $tab.reset $tab.can -side left \
-fill both
pack $tab -side top -fill x
set xlast 0
set ylast 0
set zlast 0
set 3dxnext 0
set 3dyrnext 0
set plotcolor black
# Computes (0,0) and attempts to center it in view.
# Computation for xy plot
set xytotalx [expr {abs($xytopx) + abs($xybotx)}]
set xylowerx [expr {abs($xytopx) - 270}]
if {$xylowerx <= 0} {
set xycenterx 0
} else {
set xycenterx [expr {double($xylowerx) / double($xytotalx)} * 1.1 ]
}
set xytotaly [expr {abs($xytopy) + abs($xyboty)}]
set xylowery [expr {abs($xytopy) - 125}]
if {$xylowery <= 0} {
set xycentery 0
} else {
set xycentery [expr {double($xylowery) / double($xytotaly)} * .8 ]
}
# Computation for xz plot
set xztotalx [expr {abs($xztopx) + abs($xzbotx)}]
set xzlowerx [expr {abs($xztopx) - 270}]
if {$xzlowerx <= 0} {
set xzcenterx 0
} else {
set xzcenterx [expr {double($xzlowerx) / double($xztotalx)} * 1.1]
}
set xztotalz [expr {abs($xztopz) + abs($xzbotz)}]
set xzlowerz [expr {abs($xztopz) - 125}]
if {$xzlowerz <= 0} {
set xzcenterz 0
} else {
set xzcenterz [expr {double($xzlowerz) / double($xztotalz)} * .8]
}
# Computation for yz plot
set yztotaly [expr {abs($yztopy) + abs($yzboty)}]
set yzlowery [expr {abs($yztopy) - 270}]
if {$yzlowery <= 0} {
set yzcentery 0
} else {
set yzcentery [expr {double($yzlowery) / double($yztotaly)} * 1.1]
}
set yztotalz [expr {abs($yztopz) + abs($yzbotz)}]
set yzlowerz [expr {abs($yztopz) - 125}]
if {$yzlowerz <= 0} {
set yzcenterz 0
} else {
set yzcenterz [expr {double($yzlowerz) / double($yztotalz)} * .8]
}
set screen [frame $pw.frame -width 500 -height 260 ]
frame $screen.xyplot
canvas $screen.xyplot.canv -borderwidth 0 -scrollregion "$xytopx $xytopy $xybotx $xyboty" \
-relief flat -xscrollcommand "$screen.xyplot.hscroll set" \
-yscrollcommand "$screen.xyplot.vscroll set" \
-xscrollincrement 10 -yscrollincrement 10 -width 500 -height 260
scrollbar $screen.xyplot.hscroll -orient horizontal -command "$screen.xyplot.canv xview"
scrollbar $screen.xyplot.vscroll -orient vertical -command "$screen.xyplot.canv yview"
grid $screen.xyplot.canv -row 0 -column 0 -sticky nsew
grid $screen.xyplot.vscroll -row 0 -column 1 -sticky ns
grid $screen.xyplot.hscroll -row 1 -column 0 -sticky ew
grid rowconfigure $screen.xyplot 0 -weight 1
grid columnconfigure $screen.xyplot 0 -weight 1
frame $screen.xzplot
canvas $screen.xzplot.canv -borderwidth 0 -scrollregion "$xztopx $xztopz $xzbotx $xzbotz" \
-relief flat -xscrollcommand "$screen.xzplot.hscroll set" \
-yscrollcommand "$screen.xzplot.vscroll set" \
-xscrollincrement 10 -yscrollincrement 10 -width 500 -height 260
scrollbar $screen.xzplot.hscroll -orient horizontal -command "$screen.xzplot.canv xview"
scrollbar $screen.xzplot.vscroll -orient vertical -command "$screen.xzplot.canv yview"
grid $screen.xzplot.canv -row 0 -column 0 -sticky nsew
grid $screen.xzplot.vscroll -row 0 -column 1 -sticky ns
grid $screen.xzplot.hscroll -row 1 -column 0 -sticky ew
grid rowconfigure $screen.xzplot 0 -weight 1
grid columnconfigure $screen.xzplot 0 -weight 1
frame $screen.yzplot
canvas $screen.yzplot.canv -borderwidth 0 -scrollregion "$yztopy $yztopz $yzboty $yzbotz" \
-relief flat -xscrollcommand "$screen.yzplot.hscroll set" \
-yscrollcommand "$screen.yzplot.vscroll set" \
-xscrollincrement 10 -yscrollincrement 10 -width 500 -height 260
scrollbar $screen.yzplot.hscroll -orient horizontal -command "$screen.yzplot.canv xview"
scrollbar $screen.yzplot.vscroll -orient vertical -command "$screen.yzplot.canv yview"
grid $screen.yzplot.canv -row 0 -column 0 -sticky nsew
grid $screen.yzplot.vscroll -row 0 -column 1 -sticky ns
grid $screen.yzplot.hscroll -row 1 -column 0 -sticky ew
grid rowconfigure $screen.yzplot 0 -weight 1
grid columnconfigure $screen.yzplot 0 -weight 1
frame $screen.3dplot
canvas $screen.3dplot.canv -borderwidth 0 -scrollregion "$yztopy $yztopz $yzboty $yzbotz" \
-relief flat -xscrollcommand "$screen.3dplot.hscroll set" \
-yscrollcommand "$screen.3dplot.vscroll set" \
-xscrollincrement 10 -yscrollincrement 10 -width 500 -height 260
scrollbar $screen.3dplot.hscroll -orient horizontal -command "$screen.3dplot.canv xview"
scrollbar $screen.3dplot.vscroll -orient vertical -command "$screen.3dplot.canv yview"
grid $screen.3dplot.canv -row 0 -column 0 -sticky nsew
grid $screen.3dplot.vscroll -row 0 -column 1 -sticky ns
grid $screen.3dplot.hscroll -row 1 -column 0 -sticky ew
grid rowconfigure $screen.3dplot 0 -weight 1
grid columnconfigure $screen.3dplot 0 -weight 1
set cft [frame $screen.config ]
label $cft.label1 -text [msgcat::mc "AXIS"] -anchor e
label $cft.label2 -text [msgcat::mc "OFFSET"]
label $cft.label3 -text [msgcat::mc "ANGLE"]
label $cft.label4 -text [msgcat::mc "DIRECTION"]
label $cft.labelx -text "X :" -anchor e
entry $cft.exo -relief sunken -textvariable xoffset -width 8
entry $cft.exa -relief sunken -textvariable xangle -width 8
button $cft.bxd -textvariable xdir -command {changeDirection xdir} -width 10
label $cft.labely -text "Y :" -anchor e
entry $cft.eyo -relief sunken -textvariable yoffset -width 8
entry $cft.eya -relief sunken -textvariable yangle -width 8
button $cft.byd -textvariable ydir -command {changeDirection ydir} -width 10
label $cft.labelz -text "Z :" -anchor e
entry $cft.ezo -relief sunken -textvariable zoffset -width 8
entry $cft.eza -relief sunken -textvariable zangle -width 8
button $cft.bzd -textvariable zdir -command {changeDirection zdir} -width 10
label $cft.elabel -text [msgcat::mc "SIZE :"] -anchor e -width 8
entry $cft.esize -relief sunken -textvariable size -width 8
grid $cft.label1 $cft.label2 $cft.label3 $cft.label4 $cft.elabel -padx 6
grid $cft.labelx $cft.exo $cft.exa $cft.bxd $cft.esize -padx 6 -pady 2
grid $cft.labely $cft.eyo $cft.eya $cft.byd -padx 6 -pady 2
grid $cft.labelz $cft.ezo $cft.eza $cft.bzd -padx 6 -pady 2
pack $cft -side top -pady 10 -fill both -expand yes
pack $screen -side top -fill both -expand yes
erasePlot
selectPlot 3d
}
proc selectPlot {which} {
global screen tab
switch -- $which {
xy {
pack $screen.xyplot -side top -fill both -expand yes
pack forget $screen.xzplot $screen.yzplot $screen.3dplot $screen.config
$tab.xy configure -borderwidth 0 -relief flat
$tab.xz configure -borderwidth 1 -relief sunken
$tab.yz configure -borderwidth 1 -relief sunken
$tab.3d configure -borderwidth 1 -relief sunken
}
xz {
pack $screen.xzplot -side top -fill both -expand yes
pack forget $screen.xyplot $screen.yzplot $screen.3dplot $screen.config
$tab.xy configure -borderwidth 1 -relief sunken
$tab.xz configure -borderwidth 0 -relief flat
$tab.yz configure -borderwidth 1 -relief sunken
$tab.3d configure -borderwidth 1 -relief sunken
}
yz {
pack $screen.yzplot -side top -fill both -expand yes
pack forget $screen.xyplot $screen.xzplot $screen.3dplot $screen.config
$tab.xy configure -borderwidth 1 -relief sunken
$tab.xz configure -borderwidth 1 -relief sunken
$tab.yz configure -borderwidth 0 -relief flat
$tab.3d configure -borderwidth 1 -relief sunken
}
3d {
pack $screen.3dplot -side top -fill both -expand yes
pack forget $screen.xyplot $screen.xzplot $screen.yzplot $screen.config
$tab.xy configure -borderwidth 1 -relief sunken
$tab.xz configure -borderwidth 1 -relief sunken
$tab.yz configure -borderwidth 1 -relief sunken
$tab.3d configure -borderwidth 0 -relief flat
}
config {
pack $screen.config -side top -fill both -expand yes
pack forget $screen.xyplot $screen.xzplot $screen.yzplot $screen.3dplot
$tab.xy configure -borderwidth 1 -relief sunken
$tab.xz configure -borderwidth 1 -relief sunken
$tab.yz configure -borderwidth 1 -relief sunken
$tab.3d configure -borderwidth 1 -relief sunken
}
default {
}
}
}
proc changeDirection {axisvariable} {
global xdir ydir zdir
if {$axisvariable == "xdir"} {
if {$xdir == 1} {
set xdir -1
} else {
set xdir 1
}
} elseif {$axisvariable == "ydir"} {
if {$ydir == 1} {
set ydir -1
} else {
set ydir 1
}
} elseif {$axisvariable == "zdir"} {
if {$zdir == 1} {
set zdir -1
} else {
set zdir 1
}
}
erasePlot
}
set xnext 0; set ynext 0; set znext 0; set yrnext 0; set zrnext 0
set 3dxnext 0; set 3dynext 0; set 3dznext 0; set 3dyrnext 0
set 3dylast 0; set 3dxlast 0; set 3dzlast 0; set 3dyrlast 0
proc backPlot {} {
global screen
global size xoffset yoffset zoffset xdir ydir zdir
global xnext ynext znext yrnext zrnext 3dxnext 3dyrnext
$screen.xyplot.canv create oval [expr $xnext -2] [expr $yrnext -2] \
[expr $xnext + 2] [expr $yrnext +2] -outline red -tags xytool
$screen.xzplot.canv create line $xnext $zrnext $xnext [expr $zrnext - 20] \
-fill red -arrow first -tags xzarrow
$screen.yzplot.canv create line $ynext $zrnext $ynext [expr $zrnext - 20] \
-fill red -arrow first -tags yzarrow
$screen.3dplot.canv create line $3dxnext $3dyrnext [expr $3dxnext + 10] [expr $3dyrnext -15] \
-fill red -arrow first -tags 3darrow
}
proc erasePlot {} {
global screen
$screen.xyplot.canv addtag all all
$screen.xyplot.canv delete all
$screen.xzplot.canv addtag all all
$screen.xzplot.canv delete all
$screen.yzplot.canv addtag all all
$screen.yzplot.canv delete all
$screen.3dplot.canv addtag all all
$screen.3dplot.canv delete all
backPlot
markPlot
}
# Process markPlot shows initial conditions and display for plots
proc markPlot {} {
global xdir ydir zdir xoffset yoffset zoffset 3dxyangle xycosangle xysinangle
global xycenterx xycentery xzcenterx xzcenterz yzcentery yzcenterz xyangle
global xangle yangle zangle
global screen
$screen.xyplot.canv create line 0 0 [expr $xdir * 50] 0 -arrow last -fill blue
$screen.xyplot.canv create text [expr $xdir * (50 + 10)] 2 -text X+ -fill blue
$screen.xyplot.canv create line 0 0 0 [expr $ydir * -50] -arrow last -fill blue
$screen.xyplot.canv create text -2 [expr $ydir * -(50 + 10)] -text Y+ -fill blue
$screen.xyplot.canv xview moveto $xycenterx
$screen.xyplot.canv yview moveto $xycentery
$screen.xzplot.canv create line 0 0 [expr $xdir * 50] 0 -arrow last -fill blue
$screen.xzplot.canv create text [expr $xdir * (50 + 10)] 2 -text X+ -fill blue
$screen.xzplot.canv create line 0 0 0 [expr $zdir * -50] -arrow last -fill blue
$screen.xzplot.canv create text -2 [expr $zdir * -(50 + 10)] -text Z+ -fill blue
$screen.xzplot.canv xview moveto $xzcenterx
$screen.xzplot.canv yview moveto $xzcenterz
$screen.yzplot.canv create line 0 0 [expr $ydir * 50] 0 -arrow last -fill blue
$screen.yzplot.canv create text [expr $ydir * (50 + 10)] 2 -text Y+ -fill blue
$screen.yzplot.canv create line 0 0 0 [expr $zdir * -50] -arrow last -fill blue
$screen.yzplot.canv create text -2 [expr $zdir * -(50 + 10)] -text Z+ -fill blue
$screen.yzplot.canv xview moveto $yzcentery
$screen.yzplot.canv yview moveto $yzcenterz
set xyangle $xangle
set 3dxyangle [expr $xyangle * 0.017453]
set xycosangle [expr cos($3dxyangle)]
set xysinangle [expr sin($3dxyangle)]
$screen.3dplot.canv create line 0 0 [expr $xdir * $xycosangle * 50] \
[expr $xdir * $xysinangle * -50] -arrow last -fill blue
$screen.3dplot.canv create text [expr $xdir * $xycosangle * 60]\
[expr $xdir * $xysinangle * -60] -text X+ -fill blue
$screen.3dplot.canv create line 0 0 [expr $ydir * $xycosangle * -50] \
[expr $ydir * $xysinangle * -50] -arrow last -fill blue
$screen.3dplot.canv create text [expr $ydir * $xycosangle * -60] \
[expr $ydir * $xysinangle * -60] -text Y+ -fill blue
$screen.3dplot.canv create line 0 0 0 [expr $zdir * -50] -arrow last -fill blue
$screen.3dplot.canv create text -2 [expr $zdir * - 60] -text Z+ -fill blue
$screen.3dplot.canv xview moveto $xycenterx
$screen.3dplot.canv yview moveto $xycentery
}
# this process plots the motion of the tool center
# it is commanded by a line [if winfo exists .plot] in updateStatus
set xlast 0
set ylast 0
set zlast 0
set plotcolor brown
proc updatePlot {} {
global size screen unitsetting
global xdir ydir zdir
global xnext ynext znext yrnext zrnext xlast ylast zlast
global xoffset yoffset zoffset xycosangle xysinangle
global programfiletext posdigit0 posdigit1 posdigit2 activeLine plotcolor
global 3dxnext 3dynext 3dznext 3dyrnext 3dylast 3dxlast 3dzlast 3dyrlast
# hack to divide scale for mm plotting
if {$unitsetting == "(mm)" } {
set scaler 25.4
} else {
set scaler 1
}
set posdigitx0 [expr $posdigit0 / $scaler]
set posdigitx1 [expr $posdigit1 / $scaler]
set posdigitx2 [expr $posdigit2 / $scaler]
# Color plot line by setting active line to upcase thisstring
set thisstring [string toupper [$programfiletext get $activeLine.0 $activeLine.end]]
# Search thisstring for g0-3 but make modal with no else
if { [string first G2 $thisstring] != -1 || \
[string first G02 $thisstring] != -1 } {
set plotcolor red
} elseif { [string first G3 $thisstring] != -1 || \
[string first G03 $thisstring] != -1 } {
set plotcolor blue
} elseif { [string first G1 $thisstring] != -1 || \
[string first G01 $thisstring] != -1 } {
set plotcolor black
} elseif { [string first G$screen $thisstring] != -1 } {
continue
} elseif { [string first G0 $thisstring] != -1 } {
set plotcolor lightgreen
}
if {$size < 1} {set size 1} {
set xnext [expr $xoffset + ($posdigitx0 * $size * $xdir)]
set ynext [expr $yoffset + ($posdigitx1 * $size * $ydir)]
set znext [expr $zoffset + ($posdigitx2 * $size * $zdir)]
if {$xlast != $xnext || $ylast != $ynext || $zlast != $znext} {
# these routines reverse y direction, plot xy and move tool
set yrlast [expr -1 * $ylast]
set yrnext [expr -1 * $ynext]
$screen.xyplot.canv create line $xlast $yrlast $xnext $yrnext -fill $plotcolor
$screen.xyplot.canv move xytool [expr $xnext - $xlast] [expr $yrnext - $yrlast]
# these routines reverse z direction plot xz and yz and move arrows
set zrlast [expr -1 * $zlast]
set zrnext [expr -1 * $znext]
$screen.xzplot.canv create line $xlast $zrlast $xnext $zrnext -fill $plotcolor
$screen.xzplot.canv move xzarrow [expr $xnext - $xlast] [expr $zrnext - $zrlast]
$screen.yzplot.canv create line $ylast $zrlast $ynext $zrnext -fill $plotcolor
$screen.yzplot.canv move yzarrow [expr $ynext - $ylast] [expr $zrnext - $zrlast]
# 3D plot calculations
set 3dxnext [expr [expr $xnext * $xycosangle] + [expr $ynext * -1 * $xycosangle]]
set 3dynext [expr [expr $xnext * $xysinangle] + [expr $ynext * $xysinangle] + $znext]
# Plot 3D xy and move tool
set 3dyrlast [expr -1 * $3dylast]
set 3dyrnext [expr -1 * $3dynext]
$screen.3dplot.canv create line $3dxlast $3dyrlast $3dxnext $3dyrnext -fill $plotcolor
$screen.3dplot.canv move 3darrow [expr $3dxnext - $3dxlast] [expr $3dyrnext - $3dyrlast]
set 3dxlast $3dxnext
set 3dylast $3dynext
set 3dzlast $3dznext
set xlast $xnext
set ylast $ynext
set zlast $znext
}
}
}