gwave 20090213-4 / usr / share / guile / app / gwave / cmds.scm

;
; module providing some simple gwave commands
;

(define-module (app gwave cmds)
  :use-module (oop goops)
  :use-module (gnome-2)
  :use-module (gnome gtk)
  :use-module (ice-9 optargs)
  :use-module (app gwave gtk-helpers)
)
(read-set! keywords 'prefix)

; print list
(define-public (print . l)
  (for-each (lambda (e) (display e (current-output-port))) l))

(define-public (append-hook! hook proc)
  "Add PROC to HOOK at the end of the list."
  (add-hook! hook proc #t))

; x-axis zoom in/zoom out zoom by this ammount
(define x-zoom-fraction 2)

;; Zoom the x axis to show the entire independent-variable
;; range used by all displayed waveforms.
(define-public (x-zoom-full!)
  (x-zoom! (wtable-min-xval) (wtable-max-xval)))

;; Prompt the user to select a range along the x axis with the mouse,
;; and then zoom in so that the selected range fills the entire displayed
;; X axis.
(define-public (x-zoom-area!)
  (select-range-x 
   (lambda (wp x1 x2)
;     (display "in x-zoom-area callback ")
;     (display wp) (display " ")
;     (display x1) (display " ")
;     (display x2) (newline)
     (x-zoom! (wavepanel-x2val wp x1) (wavepanel-x2val wp x2)))))

;; Prompt the user to select with the mouse a range along the Y axis of
;; a particular wavepanel, and then vertically zoom that wavepanel
;; so that the selected range fills its entire displayed Y axis.
(define-public (y-zoom-range!)
  (select-range-y 
   (lambda (wp y1 y2)
;     (print "y-zoom-range callback(" wp ") ")
;     (print y1 " -> " (wavepanel-y2val wp y1) ", ")
;     (print y2 " -> " (wavepanel-y2val wp y2) "\n")
     (wavepanel-y-zoom! wp (wavepanel-y2val wp y1) (wavepanel-y2val wp y2))
)))

 
;; Restore a WavePanel to display the full range of Y values,
;; and to automaticly rescale as VisibleWaves are added and deleted.
(define-public (y-zoom-fullauto! wp) (wavepanel-y-zoom! wp #f #f))

;; Prompt the user to select a rectangular region of a WavePanel, and
;; then zoom in both X and Y so that the selected area fills the whole
;; window.
(define-public (xy-zoom-area!)
  (select-range-xy 
   (lambda (wp x1 x2 y1 y2)
;     (display "in xy-zoom-area callback ")
;     (display wp) (display " ")
;     (display x1) (display " ")
;     (display x2) (display " ")
;     (display y1) (display " ")
;     (display y2) (newline)
     (x-zoom! (wavepanel-x2val wp x1) (wavepanel-x2val wp x2))
     (wavepanel-y-zoom! wp (wavepanel-y2val wp y1) (wavepanel-y2val wp y2))
)))

(define (pow base power)
    (exp (* power (log base))))

;; zoom the display's X axis relative to current configuration.
;; if the zoom factor is greater than 1, we zoom in.
;; if the zoom factor is less than 1, we zoom out.
(define-public (x-zoom-relative! zf)
  (let ((sx (wtable-start-xval))
 	(ex   (wtable-end-xval)))
    (if (not (wtable-xlogscale?))
	(let ((center (/ (+ sx ex) 2))
 	      (width (- ex sx)))
 	  (x-zoom! (- center (/ width (* zf 2)))
 		   (+ center (/ width (* zf 2)))))
 	(let ((center (sqrt (* ex sx)))
 	      (width (/ ex sx)))
 	  (x-zoom! (/ center (pow width (/ 0.5 zf)))
 		   (* center (pow width (/ 0.5 zf))))))))

;; zoom X so that edges of displayed are where the vertical cursors are now.
;; If both vertical bar cursors aren't displayed, do nothing.
;;-
; FIXME:tell:
;  pop message somewhere if both cursors not displayed
;  zoom so that cursors are just visible at edges, say 5% in from edge.
(define-public (x-zoom-cursors!)
  (let ((c0 (wtable-vcursor 0))
	(c1 (wtable-vcursor 1)))
    (if (and c0 c1)
	(x-zoom! c0 c1))))

;
; Implement a simple notion of WavePanel "type" that changes
; several of the lower-level options together.   Earlier versions
; had this in C.
; should also let user choose these parameters independently.
;

; instead of multiple lists, these should be a real data structure of some kind
(define-public wavepanel-type-names    (list "Full"  "Slim" "Jumbo"))
(define-public wavepanel-num-types (length wavepanel-type-names))
(define            panel-type-heights  (list 100     20      250))
(define            panel-type-showlabs (list #t      #f      #t))

(define-public (set-wavepanel-type! wp type)
  (set-object-property! wp 'wp-type type)
  (set-wavepanel-minheight! wp (list-ref panel-type-heights type))
  (set-wavepanel-ylabels-visible! wp (list-ref panel-type-showlabs type)))

(define-public (wavepanel-type wp) (object-property wp 'wp-type))

; wrapper around wtable-insert-panel that pays attention to this type business
(define-public (wtable-insert-typed-panel! wp type)
  (wtable-insert-panel! wp
		       (list-ref panel-type-heights type)
		       (list-ref panel-type-showlabs type)))

; Add the panel-type property to a new wavepanel, so the context-sensitive
; menu works properly.
; For the moment, the standard GUI stuff only calls 
; wtable-insert-typed-panel! with the default type, so this comes out OK.
; Really need to pass the type through from wtable-insert-typed-panel
; somehow.  Or else, change the interface.
(add-hook! new-wavepanel-hook 
	   (lambda (wp)
	     (dbprint "in cmds.scm new-wavepanel-hook " wp "\n")
	     (set-object-property! wp 'wp-type default-wavepanel-type)))

; GTK+ helper: make a simple button with a textual label
(define (make-button parent txt func) 
  (let* ((btn (gtk-button-new-with-label txt)))
    (gtk-container-add parent btn)
    (gtk-widget-show btn)
    (if func (gtk-signal-connect btn "clicked" func))
    btn))

;; Create and show a top-level window with the "about" information
(define-public (show-about-window!)
  (let* ((window (make <gtk-window>
				 :type         'toplevel
				 :title        "About Gwave"))
	 (vbox (gtk-vbox-new #f 10)))
    (gtk-container-set-border-width window 10)
    (gtk-widget-show vbox)
    (gtk-container-add window vbox)
    (let ((llab (gtk-label-new 
		 (string-append "Gwave2 version " gwave-version-string))))
      (gtk-widget-show llab)
      (gtk-container-add vbox llab))
    (let ((llab (gtk-label-new "Copyright 1997-2008 Steve Tell")))
      (gtk-widget-show llab)
      (gtk-container-add vbox llab))

    (let ((llab (gtk-label-new "steve@telltronics.org")))
      (gtk-widget-show llab)
      (gtk-container-add vbox llab))

    (let ((llab (gtk-label-new "Gwave comes with ABSOLUTELY NO WARRANTY.")))
      (gtk-widget-show llab)
      (gtk-container-add vbox llab))

    (let ((llab (gtk-label-new "This is Free Software, and you are welcome to distribute")))
      (gtk-widget-show llab)
      (gtk-container-add vbox llab))
    (let ((llab (gtk-label-new "it under the terms of the GNU General Public License.")))
      (gtk-widget-show llab)
      (gtk-container-add vbox llab))

    (make-button vbox "Close" (lambda (x) (gtk-widget-destroy window)))
    (gtk-widget-show window)))

;; Pop up a dialog box to enter new axis limits (zoom setting) for a wavepanel.
(define-public (show-zoom-dialog! wp)
  (let* ((window (make <gtk-window>
				 :type         'toplevel
				 :title        "Gwave axis settings"))
	 (vbox (gtk-vbox-new #f 5))
	 (hbox (gtk-hbox-new #f 5))
	 (frame_x (gtk-frame-new "Global X Axis"))
	 (table_x (gtk-table-new 3 3 #f))
	 (start_x_entry (gtk-entry-new))
	 (end_x_entry (gtk-entry-new))
	 (frame_y (gtk-frame-new "Panel Y Axis"))
	 (table_y (gtk-table-new 3 4 #f))
	 (start_y_entry (gtk-entry-new))
	 (end_y_entry (gtk-entry-new))
	 (man_y_button (gtk-toggle-button-new-with-label "Auto Full-Scale"))
	 (max-rect (wavepanel-max-rect wp))
	 (disp-rect (wavepanel-disp-rect wp))
	 )
    (gtk-container-set-border-width window 5)
    (gtk-table-set-row-spacings table_x 3)
    (gtk-table-set-col-spacings table_x 3)
    (gtk-table-set-row-spacings table_y 3)
    (gtk-table-set-col-spacings table_y 3)
    (gtk-container-add vbox frame_x)
    (gtk-widget-show frame_x)
    (gtk-container-add frame_x table_x)
    (gtk-widget-show table_x)
    (let ((lab (gtk-label-new "min,max:")))
      (gtk-table-attach table_x lab 0 1 0 1)
      (gtk-widget-show lab))
    (let ((lab (gtk-label-new (number->spice (car max-rect))) ))
      (gtk-table-attach table_x lab 1 2 0 1)
      (gtk-widget-show lab))
    (let ((lab (gtk-label-new (number->spice (caddr max-rect))) ))
      (gtk-table-attach table_x lab 2 3 0 1)
      (gtk-widget-show lab))

    (let ((lab (gtk-label-new "Current:")))
      (gtk-table-attach table_x lab 0 1 1 2)
      (gtk-widget-show lab))
    (let ((lab (gtk-label-new (number->spice (car disp-rect))) ))
      (gtk-table-attach table_x lab 1 2 1 2)
      (gtk-widget-show lab))
    (let ((lab (gtk-label-new (number->spice (caddr disp-rect))) ))
      (gtk-table-attach table_x lab 2 3 1 2)
      (gtk-widget-show lab))

    (let ((lab (gtk-label-new "New:")))
      (gtk-table-attach table_x lab 0 1 2 3)
      (gtk-widget-show lab))

    (gtk-table-attach table_x start_x_entry 1 2 2 3)
    (gtk-entry-set-text start_x_entry (number->spice (car disp-rect)))
    (gtk-widget-show start_x_entry)
    (gtk-table-attach table_x end_x_entry 2 3 2 3)
    (gtk-entry-set-text end_x_entry (number->spice (caddr disp-rect)))
    (gtk-widget-show end_x_entry)

	;  second part: Y stuff
   (gtk-container-add vbox frame_y)
    (gtk-widget-show frame_y)
    (gtk-container-add frame_y table_y)
    (gtk-widget-show table_y)
    (let ((lab (gtk-label-new "min,max:")))
      (gtk-table-attach table_y lab 0 1 0 1)
      (gtk-widget-show lab))
    (let ((lab (gtk-label-new (number->spice (cadr max-rect))) ))
      (gtk-table-attach table_y lab 1 2 0 1)
      (gtk-widget-show lab))
    (let ((lab (gtk-label-new (number->spice (cadddr max-rect))) ))
      (gtk-table-attach table_y lab 2 3 0 1)
      (gtk-widget-show lab))

    (let ((lab (gtk-label-new "Current:")))
      (gtk-table-attach table_y lab 0 1 1 2)
      (gtk-widget-show lab))
    (let ((lab (gtk-label-new (number->spice (cadr disp-rect))) ))
      (gtk-table-attach table_y lab 1 2 1 2)
      (gtk-widget-show lab))
    (let ((lab (gtk-label-new (number->spice (cadddr disp-rect))) ))
      (gtk-table-attach table_y lab 2 3 1 2)
      (gtk-widget-show lab))

    (if (wavepanel-y-manual? wp)
	(gtk-toggle-button-set-active man_y_button #f)
	(begin
	  (gtk-toggle-button-set-active man_y_button #t)
	  (gtk-widget-set-sensitive start_y_entry #f)
	  (gtk-widget-set-sensitive end_y_entry #f)))
    (gtk-signal-connect man_y_button "toggled" (lambda ()
			(if (gtk-toggle-button-get-active man_y_button)
			    (begin 
			      (gtk-widget-set-sensitive start_y_entry #f)
			      (gtk-widget-set-sensitive end_y_entry #f))
			    (begin
			      (gtk-widget-set-sensitive start_y_entry #t)
			      (gtk-widget-set-sensitive end_y_entry #t)))))
    (gtk-table-attach table_y man_y_button 0 1 2 3)
    (gtk-widget-show man_y_button)

    (let ((lab (gtk-label-new "New:")))
      (gtk-table-attach table_y lab 0 1 3 4)
      (gtk-widget-show lab))
    (gtk-table-attach table_y start_y_entry 1 2 3 4)
    (gtk-entry-set-text start_y_entry (number->spice (cadr disp-rect)))
    (gtk-widget-show start_y_entry)
    (gtk-table-attach table_y end_y_entry 2 3 3 4)
    (gtk-entry-set-text end_y_entry (number->spice (cadddr disp-rect)))
    (gtk-widget-show end_y_entry)

 ; 3rd part: button row
    (make-button hbox "OK"
	(lambda (b) 
	  (let ((n_sx (spice->number (gtk-entry-get-text start_x_entry)))
		(n_ex (spice->number (gtk-entry-get-text end_x_entry)))
		(n_sy (spice->number (gtk-entry-get-text start_y_entry)))
		(n_ey (spice->number (gtk-entry-get-text end_y_entry)))
		)
	    (x-zoom! n_sx n_ex)
	    (if (gtk-toggle-button-get-active man_y_button)
		(wavepanel-y-zoom! wp #f #f)
		(wavepanel-y-zoom! wp n_sy n_ey))
	    (gtk-widget-destroy window))))
    (make-button hbox "Cancel" (lambda (b) (gtk-widget-destroy window)))
    
    (gtk-widget-show hbox)
    (gtk-container-add vbox hbox)

    (gtk-widget-show vbox)
    (gtk-container-add window vbox)
    (gtk-widget-show window)
))


; Pop up a file-chooser dialog with title S.
; When file seleted, run procedure P, passing it the name of the file.
; Optionaly, a default suggested filename can be specified using
; keyword #:default.
; allows choosing a new file to save to if keyword #:save is set to #t
(define*-public (with-selected-filename title p 
					#:key (exists #f) (default #f))
  (let* ((dialog ( make <gtk-file-chooser-dialog> 
		   #:title title
		   )))
    (format #t "with-selected ~s save=~s defname=~s\n" title exists default)
    (if (not exists)
	(gtk-file-chooser-set-action dialog 'save))
    (gtk-dialog-add-button dialog (gtk-stock-id 'ok) -5)
;    (gtk-dialog-set-default-response -5) ; throws wrong-type error
    (gtk-dialog-add-button dialog (gtk-stock-id 'cancel) -6)

    (if (string? default)
	(gtk-file-chooser-set-filename dialog default))

    (gtk-signal-connect dialog "response" 
			(lambda (d r)
			  (case r
			    ((-6) (destroy dialog))
			    ((-5) (let ((fn (gtk-file-chooser-get-filename dialog)))
				    (format #t "chose file(~a): ~s\n" title fn)
				    (p fn)
				    (destroy dialog)))
			    (else (format #t "chooser(~a) response ~s\n" title r)))))
    
    (gtk-widget-show dialog)
))


;; Call set-visiblewave-measure! on all visiblewaves
;; to set the function for measurement number MNO to MFUNC.
(define-public (set-all-measurements! mno mfunc)
  (for-each (lambda (wp)
	      (for-each (lambda (vw)
			  (set-visiblewave-measure! vw mno mfunc))
			(wavepanel-visiblewaves wp)))
	    (wtable-wavepanels)))



; Add variable to wavepanel, and then do setup of its color, style, etc.
; Mainly for use from scripts that restore a saved configuration.
; TODO: don't add the variable if already present in the specified panel.
(define*-public (wavepanel-add-var-setup df wp signame color #:key (sweep 0))
  (if df
      (let ((var (wavefile-variable df signame sweep)))
	(if var
	    (let ((vw (wavepanel-add-variable! wp var)))
	      (if vw
		  (set-visiblewave-color! vw color)))))))


(define-public (require-n-wavepanels rn)
    (let ((hn (length (wtable-wavepanels))))
;      (if (< hn rn)
;	  (begin
;	    (print "need " (- rn hn) " more wavepanels\n")))
      (do ((i hn
	      (+ i 1)))
	  ((not (< i rn)))
	(wtable-insert-typed-panel! #f default-wavepanel-type))
      ))

(define-public (num-wavepanels)
  (length (wtable-wavepanels)))
  
(define-public (nth-wavepanel n)
  (list-ref (wtable-wavepanels) n))

(define-public (unselect-all-wavepanels!)
  (for-each (lambda (wp)
	      (set-wavepanel-selected! wp #f))
	    (wtable-wavepanels)))

;; Given a filename, return the GWDataFile object associated with
;; the data loaded from that file, or #f it there is no such file loaded.
(define-public (find-wavefile name)
  (call-with-current-continuation
   (lambda (exit)
     (for-each (lambda (df)
		 (if (string=? name (wavefile-file-name df))
		     (exit df)))
              (wavefile-list))
     #f)))

;; locate a already-loaded wavefile by name, and if that fails,
;; try to load it.  If that fails too, return #f.
(define-public (find-or-load-wavefile name)
  (let* ((df (find-wavefile name)))
    (if (not df)
	(load-wavefile! name)
	df)))

;; Write out a guile script that when executed by a future gwave,
;; will restore the configuration of waves displayed from 
;; one particular datafile.
(define-public (write-filerestore-script df fname)
  (let ((p (open fname (logior O_WRONLY O_CREAT O_TRUNC) #o0777)))
    (with-output-to-port p 
      (lambda () 
	(write-script-header)
	(write-wfr-script df #t)
	(write-script-trailer)
	))
    (close-port p)))

;; Write out a guile script that when executed by a future gwave,
;; will restore the configuration of all currently-displayed waves.
(define-public (write-allrestore-script sname)
  (let ((p (open sname (logior O_WRONLY O_CREAT O_TRUNC) #o0777))
	(mfs (eqv? 1 (length (wavefile-list)) )))
    (with-output-to-port p 
      (lambda () 
	(write-script-header)
	(for-each (lambda (df) (write-wfr-script df mfs))
		  (wavefile-list))
	(write-script-trailer)
	))
    (close-port p)))

; write header part of configuration-restoring script, 
; specifying "/path/to/gwave -s" as its interpreter.
(define (write-script-header)
  (print "#!" gwave-bin-gwave-path " -s\n!#\n")
  (print "; gwave script\n")
  (print "(require-n-wavepanels " (length (wtable-wavepanels)) ")\n")
  (print "(set! default-measure1-function " default-measure1-function ")\n")
)

; write trailer part of config-restore script, which restores
; panel and global display parameters, and global preferences.
; BUG: tooltips, wavepanel-tpe, and X-logscale are restored,
; but the radio-buttons in the Options menu are not affected.
;
(define (write-script-trailer)
  (print "(x-zoom! " (wtable-start-xval) " " (wtable-end-xval) ")\n")
  (print "(wtable-set-xlogscale! "(wtable-xlogscale?) ")\n")
  (print "(set! default-wavepanel-type " default-wavepanel-type")\n")
  (if (wtable-vcursor 0)
      (print "(set-wtable-vcursor! 0 " (wtable-vcursor 0) ")\n"))
  (if (wtable-vcursor 1)
      (print "(set-wtable-vcursor! 1 " (wtable-vcursor 1) ")\n"))

  (if (gtk-tooltips-enabled? gwave-tooltips)
      (print "(gtk-tooltips-enable gwave-tooltips)\n")
      (print "(gtk-tooltips-disable gwave-tooltips)\n"))
  (do ((i 0
	  (+ i 1))) 
      ((not (< i (num-wavepanels))))
    (let ((wp (nth-wavepanel i)))
      (print "(let ((wp (nth-wavepanel "i")))\n")
      (print " (set-wavepanel-ylogscale! wp "(wavepanel-ylogscale? wp) ")\n")
      (print " (set-wavepanel-type! wp " (wavepanel-type wp) ")\n")
      (if (wavepanel-y-manual? wp)
	  (let ((dr (wavepanel-disp-rect wp)))
	    (print " (wavepanel-y-zoom! wp " (cadr dr) " " (cadddr dr) ")\n")))
      (print ")\n")
      ))
)

; write portion of script to restore waves for a single wavefile
; If "multi" is #t, multiple file-restoration sections will be written
; to this script.  In this case, we don't provide for the "apply script
; to (already loaded) file" function.
(define (write-wfr-script df multi)
  (if multi
      (begin
	(print "(let ((df (if script-target-datafile\n"
	       "           script-target-datafile\n"
	       "           (find-or-load-wavefile \""
	       (wavefile-file-name df)  "\"))))\n"))
      (print "(let ((df (find-or-load-wavefile \""
	     (wavefile-file-name df) "\")))\n"))
  (let ((panels (wtable-wavepanels)))
    (write-wfrp-lines df panels 0))
  (print ")\n")
  )

; recursive part of writing script for single wavefile.
(define (write-wfrp-lines df panels n)
  (if (not (null? panels))
      (begin
	(for-each 
	 (lambda (vw)
	   (if (eq? df (visiblewave-file vw))
	       (begin
		 (print " (wavepanel-add-var-setup df (nth-wavepanel " n
			") \"" 
			(visiblewave-varname vw) "\" " 
			(visiblewave-color vw) )
		 (if (not (eq? 0 (variable-sweepindex vw)))
		     (print " #:sweep " (variable-sweepindex vw)))
		 (print ")\n"))
	       ))
	 (wavepanel-visiblewaves (car panels)))
	(write-wfrp-lines df (cdr panels) (+ n 1)))))

;; execute a guile script, ignoring any errors.
(define-public (execute-script fname)
  (false-if-exception (load fname))
)

; global to pass target datafile smob to scripts executed
; by apply-script-to-file.
(define-public script-target-datafile #f)

;; execute a a guile script that was saved by a
;; call to write-filerestore-script, 
;; passing it the name of an alternate data file to load in place of the
;; file specified in the script.
(define-public (apply-script-to-file fname dfile)
  (set! script-target-datafile dfile)
  (false-if-exception (load fname))
  (set! script-target-datafile #f)
)