ADDED   dcommon.scm
Index: dcommon.scm
==================================================================
--- /dev/null
+++ dcommon.scm
@@ -0,0 +1,187 @@
+;;======================================================================
+;; Copyright 2006-2013, Matthew Welland.
+;; 
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;; 
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+;;======================================================================
+
+(use format)
+(require-library iup)
+(import (prefix iup iup:))
+(use canvas-draw)
+
+(declare (unit dcommon))
+
+(declare (uses megatest-version))
+(declare (uses gutils))
+(declare (uses db))
+(declare (uses synchash))
+
+(include "common_records.scm")
+(include "db_records.scm")
+(include "key_records.scm")
+
+;;======================================================================
+;; D A T A   T A B L E S
+;;======================================================================
+
+;; Table of keys
+(define (dcommon:keys-matrix rawconfig)
+  (let* ((curr-row-num 1)
+	 (key-vals     (configf:section-vars rawconfig "fields"))
+	 (keys-matrix  (iup:matrix
+			#:alignment1 "ALEFT"
+			#:expand "HORIZONTAL" ;; "VERTICAL"
+			;; #:scrollbar "YES"
+			#:numcol 1
+			#:numlin (length key-vals)
+			#:numcol-visible 1
+			#:numlin-visible 5
+			#:click-cb (lambda (obj lin col status)
+				     (print "obj: " obj " lin: " lin " col: " col " status: " status)))))
+    (iup:attribute-set! keys-matrix "0:0" "Run Keys")
+    (iup:attribute-set! keys-matrix "0:1" "Key Name")
+    (iup:attribute-set! keys-matrix "WIDTH1" "100")
+    ;; fill in keys
+    (for-each 
+     (lambda (var)
+       ;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num))
+       (iup:attribute-set! keys-matrix (conc curr-row-num ":0") curr-row-num)
+       (iup:attribute-set! keys-matrix (conc curr-row-num ":1") var)
+       (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var)))
+     key-vals)
+    keys-matrix))
+
+;; Section to table
+(define (dcommon:section-matrix rawconfig sectionname varcolname valcolname #!key (title #f))
+  (let* ((curr-row-num    1)
+	 (key-vals        (configf:section-vars rawconfig sectionname))
+	 (section-matrix  (iup:matrix
+			   #:alignment1 "ALEFT"
+			   #:expand "HORIZONTAL" ;; "YES"
+			   #:numcol 1
+			   #:numlin (length key-vals)
+			   #:numcol-visible 1
+			   #:numlin-visible 5
+			   #:scrollbar "YES")))
+    (iup:attribute-set! section-matrix "0:0" varcolname)
+    (iup:attribute-set! section-matrix "0:1" valcolname)
+    (iup:attribute-set! section-matrix "WIDTH1" "300")
+    ;; fill in keys
+    (for-each 
+     (lambda (var)
+       ;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num))
+       (iup:attribute-set! section-matrix (conc curr-row-num ":0") var)
+       (iup:attribute-set! section-matrix (conc curr-row-num ":1") (configf:lookup rawconfig sectionname var))
+       (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var)))
+     key-vals)
+    (iup:vbox
+     (iup:label (if title title (conc "Settings from [" sectionname "]"))  
+		#:size   "5x"
+		#:expand "HORIZONTAL")
+     section-matrix)))
+    
+;; General data
+;;
+(define (dcommon:general-info)
+  (let ((general-matrix (iup:matrix
+			 #:alignment1 "ALEFT"
+			 #:expand "HORIZONTAL" ;; "YES"
+			 #:numcol 1
+			 #:numlin 3
+			 #:numcol-visible 1
+			 #:numlin-visible 3)))
+    (iup:attribute-set! general-matrix "WIDTH1" "300")
+    (iup:attribute-set! general-matrix "0:1" "About this Megatest area") 
+    ;; User (this is not always obvious - it is common to run as a different user
+    (iup:attribute-set! general-matrix "1:0" "User")
+    (iup:attribute-set! general-matrix "1:1" (current-user-name))
+    ;; Megatest area
+    (iup:attribute-set! general-matrix "2:0" "Megatest area")
+    (iup:attribute-set! general-matrix "2:1" *toppath*)
+    ;; Megatest version
+    (iup:attribute-set! general-matrix "3:0" "Megatest version")
+    (iup:attribute-set! general-matrix "3:1" megatest-version)
+    general-matrix))
+
+(define (dcommon:run-stats)
+  (let* ((run-stats    (mt:get-run-stats))
+	 (indices      (common:sparse-list-generate-index run-stats)) ;;  proc: set-cell))
+	 (max-row      (apply max (map cadr (car indices))))
+	 (max-col      (apply max (map cadr (cadr indices))))
+	 (stats-matrix (iup:matrix
+			#:alignment1 "ALEFT"
+			#:expand "HORIZONTAL"
+			#:numcol max-col 
+			#:numlin (if (< max-row 20) 20 max-row) ;; min of 20
+			#:numcol-visible max-col
+			#:numlin-visible (if (> max-row 20) 20 max-row)))
+	 (numrows      1)
+	 (numcols      1)
+	 (set-cell     (lambda (rnum cnum rname cname v) ;; rownum colnum value
+			 (print "proc called: " rnum " " cnum " " rname " " cname " " v)
+			 (if (> rnum numrows)
+			     (begin 
+			       ;; add rows numrows to r
+			       (debug:print 0 "Extending matrix from " numrows " to " rnum)
+			       (iup:attribute-set! stats-matrix  "ADDLIN" (conc numrows "-" (- rnum numrows)))
+			       (set! numrows rnum)))
+			 (if (> cnum numcols)
+			     (begin 
+			       ;; add rows numrows to r
+			       (debug:print 0 "Extending matrix from " numcols " to " cnum)
+			       (iup:attribute-set! stats-matrix  "ADDLIN" (conc numcols "-" (- rnum numcols)))
+			       (set! numcols cnum)))
+			 (debug:print 0 "Setting row " rnum ", col " cnum " to " v)
+			 (iup:attribute-set! stats-matrix (conc rnum ":" cnum) v)))
+	 (row-indices  (car indices))
+	 (col-indices  (cadr indices)))
+    ;; Row labels
+    (for-each (lambda (ind)
+		(let ((name (car ind))
+		      (num  (cadr ind)))
+		  (iup:attribute-set! stats-matrix (conc num ":0") name)))
+	      row-indices)
+    ;; Col labels
+    (for-each (lambda (ind)
+		(let ((name (car ind))
+		      (num  (cadr ind)))
+		  (iup:attribute-set! stats-matrix (conc "0:" num) name)))
+	      col-indices)
+    ;; Cell contents
+    (for-each (lambda (entry)
+		(let* ((row-name (car entry))
+		       (col-name (cadr entry))
+		       (value    (caddr entry))
+		       (row-num  (cadr (assoc row-name row-indices)))
+		       (col-num  (cadr (assoc col-name col-indices))))
+		  (iup:attribute-set! stats-matrix (conc row-num ":" col-num) value)))
+	      run-stats)
+    (iup:vbox
+     (iup:label "Run statistics" #:expand "HORIZONTAL")
+     stats-matrix)))
+
+;; The main menu
+(define (dcommon:main-menu)
+  (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top)
+   (iup:menu-item "Files" (iup:menu   ;; Note that you can use either #:action or action: for options
+		       (iup:menu-item "Open"  action: (lambda (obj)
+							(iup:show (iup:file-dialog))
+							(print "File->open " obj)))
+		       (iup:menu-item "Save"  #:action (lambda (obj)(print "File->save " obj)))
+		       (iup:menu-item "Exit"  #:action (lambda (obj)(exit)))))
+   (iup:menu-item "Tools" (iup:menu
+		       (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah")))
+		       ;; (iup:menu-item "Show dialog"     #:action (lambda (obj)
+		       ;;  					   (show message-window
+		       ;;  					     #:modal? #t
+		       ;;  					     ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current
+		       ;;  					     ;; #:x 'mouse
+		       ;;  					     ;; #:y 'mouse
+		       ;;  )					     
+		       ))))
+