plot.tcl

来自「speech signal process tools」· TCL 代码 · 共 810 行 · 第 1/2 页

# This material contains unpublished, proprietary software of 
# Entropic Research Laboratory, Inc. Any reproduction, distribution, 
# or publication of this work must be authorized in writing by Entropic 
# Research Laboratory, Inc., and must bear the notice: 
#
#    "Copyright (c) 1997 Entropic Research Laboratory, Inc. 
#                   All rights reserved"
#
# The copyright notice above does not evidence any actual or intended 
# publication of this source code.     
#
# @(#)plot.tcl	1.4	7/24/98	ERL
# 
# Written by:  Alan Parker
# Checked by:
# Revised by: David Burton (as result of code review)
# 
# Brief description:
# 
# This script implements a plot program for the old "Stanford" plotting
# used by ESPS.   The tcl script is actually called from an interpreter
# linked with the ESPS plot C programs, plotsd, plotspec, aplot, and
# scatplot.
#
############################################################################
#
# The following globals are used:
#
# # These are used by the text entry panel
# canvas_text_var - contains text
# canvas_text_x   - bottom left corner
# canvas_text_y   - bottom left corner
#
# # This is set to indicate that the next data is text in the stream
# text_command - boolean to help parse plot stream
#
# # Initial values, can be reset by commands in the stream
# current_color Black - plot color
# current_width 1.0   - plot width
#
# # These are set by the PostScript panel
# ps_name file   - current file to hold postscript
# ps_command     - current command to accept postscript
# ps_rot         - orientation: landscape or portrait
# ps_color_mode  - color, grey scale, or B/W
# ps_dest        - current output state: file or printer command
# # These are used to restore previous values after a cancel
# ps_color_hold 
# ps_rot_hold 
# ps_name_hold 
# ps_dest_hold 
# ps_command_hold 
#
# # These indicate the current line class, and whether that class is
#   enabled or not. These control the elements visible on the plot canvas.
# line_class - holds identifier for tic marks, vertical axis, box, etc.
# data_on   - boolean
# box_on    - boolean
# hgrid_on  - boolean
# vgrid_on  - boolean
# text_on   - boolean
# ticks_on  - boolean
# orig_text - boolean
#
# # Fonts and annotation text
# normal_font -Adobe-Helvetica-Bold-R-Normal--*
# small_font -Adobe-Helvetica-Bold-R-Normal--*
# text_line(0)
#
#
############################################################################
# The following procedures interpret the plot commands in the input stream
# These are the so-called Stanford plot stream commands.
#
# The input data stream is put into an array (input_data) by the main C
# program before this script is started.  These functions are called to
# evaluate each line of input from the script.
#

#
# Add to auto_path for plot programs; include erltcl library - we need XtxtTool
# The default auto_path has the ESPS_BASE/{tcl,tk,tix} script libraries.

lappend auto_path $env(ESPS_BASE)/lib/erltcl

# set current color
proc c {arg} {
	global current_color
	set current_color [lindex {Black Red Blue Green Red Grey} [expr $arg-1]]
	return $arg
}

# unknown function; not really used, but it does appear at times
proc f {arg} {return}

# move current position (like moving the pen on a plotter)
proc m {y x} {
	global current_x current_y
	global xscale yscale
	set current_x  [expr $xscale*$x]
	set current_y  [expr $yscale*$y]
	return
}

# set the class of the line to draw.  This is used to allow us to
# disable certain lines classes, such as box, vertical axis, horiz axis,
# tick marks, etc.
proc set_class {class} {
	global line_class
	set line_class $class
	return
}

# draw line from current position to position specified
# reset current position to end point
proc d {y x} {
	global current_x current_y current_color current_width line_class
	global xscale yscale
	set new_x   [expr $xscale*$x]
	set new_y   [expr $yscale*$y]
	set new [.c create line $current_x $current_y $new_x $new_y \
		-fill $current_color -width $current_width -tags $line_class]
	set current_x $new_x
	set current_y $new_y
	return
}

# draw line between two points. reset current position to y2 x2
proc l {y1 x1 y2 x2} {
	global current_x current_y current_color current_width line_class
	global xscale yscale
	set y1   [expr $yscale*$y1]
	set x1   [expr $xscale*$x1]
	set y2   [expr $yscale*$y2]
	set x2   [expr $xscale*$x2]
	set new [.c create line $x1 $y1 $x2 $y2 \
		-fill $current_color -width $current_width  -tags $line_class]
	set current_x $x2
	set current_y $y2
	return
}

# text command, next input is text.
proc t {size dummy} {
	global text_command font small_font normal_font
        #
        # The plot language support a variety of font sizes, but here we just
        # support large and small.  Less than 5 is small. 
        #
        if {$size < 5} {
		set font $small_font
	} else {
		set font $normal_font
	}

	#
	# setting this global causes the next input to be interpreted as text
	#
	set text_command 1
	return
}

# set line width
proc s {width} {
	global current_width
	set current_width $width
	return
}


############ The remaining procs are used by the rest of this script #####

# update the scale globals.  The 5500 and 3500 are artifacts of the 
# ESPS plot coordinate universe (which are actually artifacts of the old
# Masscomp plot programs!)   The width and height are scaled down by .9
# to keep the plot off the edges.
#
# Note that xscale and yscale are checked where computed, not where used.

proc update_scales {height width} {
	global xscale yscale
	set xscale [expr $width*.9/5500.0]
	set yscale [expr $height*.9/3500.0]
        if [ expr [expr $xscale <= 0] || [expr $yscale <= 0] ] {
	    tk_dialog .badScale "Invalid Scale Parameters" \
		    "Invalid X and/or Y scale value(s) - exiting" \
		    error 0 OK
	    exit (1)
	}
	return
}

# redraw the original data, even items that have been deleted.  Text
# added is lost.
proc redraw_orig {} {
	global data_on box_on hgrid_on vgrid_on text_on ticks_on
	global temp text_command xscale yscale
	global line_num  input_data
	global text_line orig_text

	.c delete all
        #
        # clear all added text
        #
	foreach i [array names text_line] {
		unset text_line($i)
	}
	set i 0
	set orig_text 1

	#
	# process the array of input data
	#
	while {$i < $line_num} {
		  if {$text_command > 0} {
			do_text $input_data($i)
		  } else {
			eval $input_data($i)
		  }
	incr i 1
	}
	set orig_text 0
	if {$data_on == 0} {.c delete data}
	if {$box_on == 0} {.c delete box}
	if {$hgrid_on == 0} {.c delete h_grid}
	if {$vgrid_on == 0} {.c delete v_grid}
	if {$ticks_on == 0} {.c delete ticks}
	if {$text_on == 0} {.c delete text}
}

# called when the window changes size
proc rescale {} {
	global old_w old_h
	set h [winfo height .c]
	set w [winfo width .c]
        if [ expr [expr $old_w <= 0] || [expr $old_h <= 0] ] {
	    tk_dialog .badGeometry "Invalid Geometry"\
		    "Invalid height or width value sent to \
		    rescale() - exiting" \
		    error 0 OK
	    exit (1)
	}
	set xscale [expr $w/double($old_w)]
	set yscale [expr $h/double($old_h)]
        if [ expr [expr $xscale <= 0] || [expr $yscale <= 0] ] {
	    tk_dialog .badScale "Invalid Scale Parameters"\
		    "Invalid X and/or Y scale value(s) - exiting" \
		    error 0 OK
	    exit (1)
	}
	set old_w $w
	set old_h $h
	.c scale all 0 0 $xscale $yscale
	update_scales $h $w
}

# main drawing function
#
# This function interprets the data in the array input_data
proc redraw {} {
	global text_command xscale yscale
	global line_num  input_data  orig_text font
	global data_on box_on hgrid_on vgrid_on text_on ticks_on
	global text_line text_x text_y text_color current_color text_font
	set i 0
	
	.c delete all
        #
        # process the array of input data
        # 
	while {$i < $line_num} {
		  if {$text_command} {
			do_text $input_data($i) 
		  } else {
			eval $input_data($i)
		  }
	incr i 1
	}

	.c delete text
	#
	# now process all added text
	#
	if {$text_on == 1} {
	    foreach i [array names text_line] {

		set new_x  [expr $xscale*$text_x($i)]
		set new_y  [expr $yscale*$text_y($i)]
		set new [.c create text $new_x $new_y -text $text_line($i)\
			 -font $text_font($i) \
			 -anchor sw -fill $text_color($i) -tags text]
		set text_line($new) $text_line($i)
		set text_x($new) $text_x($i)
		set text_y($new) $text_y($i)
		set text_color($new) $text_color($i)
	        set text_font($new) $text_font($i)
		unset text_line($i) 
	    }
	}
	if {$data_on == 0} {.c delete data}
	if {$box_on == 0} {.c delete box}
	if {$hgrid_on == 0} {.c delete h_grid}
	if {$vgrid_on == 0} {.c delete v_grid}
	if {$ticks_on == 0} {.c delete ticks}
	set orig_text 0
	return
}

# called on input following the "t" command
proc do_text {line} {
	global current_x current_y current_color text_command
	global text_line text_x text_y input_data text_color text_font
	global xscale yscale orig_text font

	if {$orig_text} {
		set new [.c create text $current_x $current_y -text $line \
		-anchor sw -fill $current_color -tags text -font $font]
		set text_line($new) $line
		set text_x($new) [expr $current_x/$xscale]
		set text_y($new) [expr $current_y/$yscale]
		set text_color($new) $current_color
		set text_font($new) $font
	}
	set text_command 0
}

# called to create a dialog box for PostScript output
proc ps_out {} {
	global ps_color_mode ps_rot ps_name ps_dest ps_command
	global ps_color_hold ps_rot_hold ps_name_hold ps_dest_hold 
	global ps_command_hold filename program_name

	set ps_color_hold $ps_color_mode
	set ps_rot_hold $ps_rot
	set ps_name_hold $ps_name
	set ps_dest_hold $ps_dest
	set ps_command_hold $ps_command

        # If the postscript dialog box exists, pop it to the top and return
	if [winfo exists .d] {
	    if {[wm state .d] == "normal"} {
		wm withdraw .d
	    }
	    wm deiconify .d
	    return
	}

	# Create dialog box
	toplevel .d 
	wm transient .d .
	wm title .d \
		"PostScript Dialog (Program: $program_name; File: $filename)"
	set ypos [winfo y .] 
	set xpos [expr [winfo x .] + 70]
	wm geom .d +$xpos+$ypos
	frame .d.cm -relief raised -bd 1 
	pack .d.cm -fill both
	wm resizable .d 0 0
	label .d.cm.color_label -text "Color mode:" 
	radiobutton .d.cm.cm_full -text Color -variable ps_color_mode \
		-value color -anchor w 
	radiobutton .d.cm.cm_gray -text "Gray Scale" -variable ps_color_mode \
		-value gray -anchor w 
	radiobutton .d.cm.cm_bw -text Monochrome -variable ps_color_mode \
		-value mono -anchor w 
	pack   .d.cm.color_label \
		.d.cm.cm_full .d.cm.cm_gray .d.cm.cm_bw -fill both -side left \
		-padx 1m -pady 2m
	frame .d.rot -relief raised -bd 1 
	pack .d.rot -fill both
	label .d.rot.label -text "Orientation:" 
	radiobutton .d.rot.pos_land -text Landscape -variable ps_rot \
		-value 1 -anchor w 
	radiobutton .d.rot.pos_port -text Portrait -variable ps_rot \
		-value 0 -anchor w 
	pack .d.rot.label .d.rot.pos_land .d.rot.pos_port -fill both \
		-side left -padx 1m -pady 2m
	frame .d.panel -relief raised -bd 1 
	pack .d.panel -fill both
	if {$ps_dest == "file"} {
		set label_text "File name:"
		set text_var ps_name
	} else {
		set label_text "Command:"
		set text_var ps_command
	}
	label .d.panel.name_label -text $label_text
	entry .d.panel.entry -relief sunken -bd 2 -textvariable $text_var \
		 -width 30
	pack .d.panel.name_label .d.panel.entry -side left -padx 1m -pady 2m
	frame .d.file_cmd -relief raised -bd 1 
	pack .d.file_cmd -fill both
	label .d.file_cmd.label -text "Output to:" 
	radiobutton .d.file_cmd.file -text File -variable ps_dest \
		-value file -anchor w  \
		-command {
			.d.panel.name_label configure -text "File:"
			.d.panel.entry configure -textvariable ps_name
		}
	radiobutton .d.file_cmd.cmd -text Command -variable ps_dest \
		-value command -anchor w  \
		-command {
			.d.panel.name_label configure -text "Command:"
			.d.panel.entry configure -textvariable ps_command
		}