Index: iupexamples/tree.scm ================================================================== --- iupexamples/tree.scm +++ iupexamples/tree.scm @@ -1,32 +1,36 @@ -(use iup test) +(use test) +(require-library iup) +(import (prefix iup iup:)) (define t #f) (define tree-dialog - (dialog + (iup:dialog #:title "Tree Test" - (let ((t1 (treebox + (let ((t1 (iup:treebox #:selection_cb (lambda (obj id state) (print "selection_db with id=" id " state=" state) - (print "SPECIALDATA: " (attribute obj "SPECIALDATA")) + (print "USERDATA: " (iup:attribute obj "USERDATA")) + (print "SPECIALDATA: " (iup:attribute obj "SPECIALDATA")) + (print "Depth: " (iup:attribute obj "DEPTH")) )))) (set! t t1) t1))) -(show tree-dialog) +(iup:show tree-dialog) (map (lambda (elname el) (print "Adding " elname " with value " el) - (attribute-set! t elname el) - (attribute-set! t "SPECIALDATA" el)) + (iup:attribute-set! t elname el) + (iup:attribute-set! t "USERDATA" el)) '("VALUE" "NAME" "ADDLEAF" "ADDBRANCH1" "ADDLEAF2" "VALUE") '("0" "Figures" "Other" "triangle" "equilateral" "4") ) (map (lambda (attr) - (print attr " is " (attribute t attr))) + (print attr " is " (iup:attribute t attr))) '("KIND1" "PARENT2" "STATE1")) (define (tree-find-node obj path) ;; start at the base of the tree (if (null? path) @@ -33,15 +37,14 @@ #f ;; or 0 ???? (let loop ((hed (car path)) (tal (cdr path)) (depth 0) (nodenum 0)) - ;; (debug:print 0 "hed: " hed ", depth: " depth ", nodenum: " nodenum) ;; nodes in iup tree are 100% sequential so iterate over nodenum - (if (attribute obj (conc "DEPTH" nodenum)) ;; end when no more nodes - (let ((node-depth (string->number (attribute obj (conc "DEPTH" nodenum)))) - (node-title (attribute obj (conc "TITLE" nodenum)))) + (if (iup:attribute obj (conc "DEPTH" nodenum)) ;; end when no more nodes + (let ((node-depth (string->number (iup:attribute obj (conc "DEPTH" nodenum)))) + (node-title (iup:attribute obj (conc "TITLE" nodenum)))) ;; (print 0 "hed: " hed ", depth: " depth ", node-depth: " node-depth ", nodenum: " nodenum ", node-title: " node-title) (if (and (equal? depth node-depth) (equal? hed node-title)) ;; yep, this is the one! (if (null? tal) ;; end of the line nodenum @@ -53,15 +56,15 @@ (loop hed tal depth (+ nodenum 1))))) #f)))) ;; top is the top node name zeroeth node VALUE=0 (define (tree-add-node obj top nodelst) - (if (not (attribute obj "TITLE0")) - (attribute-set! obj "ADDBRANCH0" top)) + (if (not (iup:attribute obj "TITLE0")) + (iup:attribute-set! obj "ADDBRANCH0" top)) (cond - ((not (string=? top (attribute obj "TITLE0"))) - (print "ERROR: top name " top " doesn't match " (attribute obj "TITLE0"))) + ((not (string=? top (iup:attribute obj "TITLE0"))) + (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0"))) ((null? nodelst)) (else (let loop ((hed (car nodelst)) (tal (cdr nodelst)) (depth 1) @@ -75,11 +78,11 @@ (nodenum (tree-find-node obj newpath))) ;; (print "newpath: " newpath ", nodenum " nodenum ", hed: " hed ", depth: " depth ", parentnode: " parentnode ", pathl: " pathl) ;; Add the branch under lastnode if not found (if (not nodenum) (begin - (attribute-set! obj (conc "ADDBRANCH" parentnode) hed) + (iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed) (if (null? tal) #t ;; reset to top (loop (car nodelst)(cdr nodelst) 1 (list top)))) (if (null? tal) ;; if null here then this path has already been added @@ -86,10 +89,40 @@ #t ;; (if nodenum (loop (car tal)(cdr tal)(+ depth 1) newpath)))))))) ;; (if nodenum nodenum lastnode))))))) ;; (loop hed tal depth pathl lastnode))))))) +(define (tree-node->path obj nodenum) + ;; (print "\ncurrnode nodenum depth node-depth node-title path") + (let loop ((currnode 0) + (depth 0) + (path '())) + (let ((node-depth (iup:attribute obj (conc "DEPTH" currnode))) + (node-title (iup:attribute obj (conc "TITLE" currnode)))) + ;; (display (conc "\n "currnode " " nodenum " " depth " " node-depth " " node-title " " path)) + (if (> currnode nodenum) + path + (if (not node-depth) ;; #f if we are out of nodes + '() + (let ((ndepth (string->number node-depth))) + (if (eq? ndepth depth) + ;; This next is the match condition depth == node-depth + (if (eq? currnode nodenum) + (begin + ;; (display " ") + (append path (list node-title))) + (loop (+ currnode 1) + (+ depth 1) + (append path (list node-title)))) + ;; didn't match, reset to base path and keep looking + ;; due to more iup odditys we don't reset to base + (begin + ;; (display " ") + (loop (+ 1 currnode) + 2 + (append (take path ndepth)(list node-title))))))))))) + (test #f 0 (tree-find-node t '("Figures"))) (test #f 1 (tree-find-node t '("Figures" "Other"))) (test #f #f (tree-find-node t '("Figures" "Other" "equilateral"))) (test #f 3 (tree-find-node t '("Figures" "triangle" "equilateral"))) (test #f #t (tree-add-node t "Figures" '())) @@ -98,7 +131,15 @@ (test #f #t (tree-add-node t "Figures" '("d" "b" "c"))) (test #f 3 (tree-find-node t '("Figures" "d" "b" "c"))) (test #f 6 (tree-find-node t '("Figures" "a" "b" "c"))) (test #f #t (tree-add-node t "Figures" '("a" "e" "c"))) (test #f 6 (tree-find-node t '("Figures" "a" "e" "c"))) -(main-loop) + +(test #f '("Figures") (tree-node->path t 0)) +(test #f '("Figures" "d") (tree-node->path t 1)) +(test #f '("Figures" "d" "b" "c") (tree-node->path t 3)) +(test #f '("Figures" "a") (tree-node->path t 4)) +(test #f '("Figures" "a" "b" "c") (tree-node->path t 8)) +(test #f '() (tree-node->path t 40)) + +(iup:main-loop) Index: newdashboard.scm ================================================================== --- newdashboard.scm +++ newdashboard.scm @@ -333,11 +333,11 @@ #f (loop hed tal depth (+ nodenum 1))))) #f)))) ;; top is the top node name zeroeth node VALUE=0 -(define (tree-add-node obj top nodelst) +(define (tree-add-node obj top nodelst #!key (userdata #f)) (if (not (iup:attribute obj "TITLE0")) (iup:attribute-set! obj "ADDBRANCH0" top)) (cond ((not (string=? top (iup:attribute obj "TITLE0"))) (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0"))) @@ -356,10 +356,12 @@ (nodenum (tree-find-node obj newpath))) ;; Add the branch under lastnode if not found (if (not nodenum) (begin (iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed) + (if userdata + (iup:attribute-set! obj (conc "USERDATA" parentnode) userdata)) (if (null? tal) #t ;; reset to top (loop (car nodelst)(cdr nodelst) 1 (list top)))) (if (null? tal) ;; if null here then this path has already been added @@ -490,11 +492,12 @@ (hash-table-set! (dboard:data-get-run-keys *data*) run-id run-path) (iup:attribute-set! (dboard:data-get-runs-matrix *data*) (conc rownum ":" colnum) col-name) (hash-table-set! runid-to-col run-id (list colnum run-record)) ;; Here we update the tests treebox and tree keys - (tree-add-node (dboard:data-get-tests-tree *data*) "Runs" (append key-vals (list run-name))) + (tree-add-node (dboard:data-get-tests-tree *data*) "Runs" (append key-vals (list run-name)) + userdata: (conc "run-id: " run-id)) (set! colnum (+ colnum 1)))) run-ids) ;; Scan all tests to be displayed and organise all the test names, respecting what is in the hash table ;; Do this analysis in the order of the run-ids, the most recent run wins @@ -524,21 +527,23 @@ ;; run view panel? The run view panel can have a tree selector for ;; browsing the tests/items ;; SWITCH THIS TO USING CHANGED TESTS ONLY (for-each (lambda (test) - (let* ((state (db:mintest-get-state test)) + (let* ((test-id (db:mintest-get-id test)) + (state (db:mintest-get-state test)) (status (db:mintest-get-status test)) (testname (db:mintest-get-testname test)) (itempath (db:mintest-get-item_path test)) (fullname (conc testname "/" itempath)) (dispname (if (string=? itempath "") testname (conc " " itempath))) (rownum (hash-table-ref/default testname-to-row fullname #f))) (tree-add-node (dboard:data-get-tests-tree *data*) "Runs" (append run-path (if (equal? itempath "") (list testname) - (list testname itempath)))) + (list testname itempath))) + userdata: (conc "test-id: " test-id)) (if (not rownum) (let ((rownums (hash-table-values testname-to-row))) (set! rownum (if (null? rownums) 1 (+ 1 (apply max rownums))))