25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
|
)
(map (lambda (attr)
(print attr " is " (attribute t attr)))
'("KIND1" "PARENT2" "STATE1"))
(define (tree-find-node obj path)
;; start at the base of the tree
(let loop ((hed (car path))
(tal (cdr path))
(depth 0)
(nodenum 0))
(attribute-set! obj "VALUE" nodenum)
(if (not (equal? (string->number (attribute obj "VALUE")) nodenum))
;; when not equal we have reached the end of the line
#f
(let ((node-depth (string->number (attribute obj (conc "DEPTH" nodenum))))
(node-title (attribute obj (conc "TITLE" nodenum))))
(if (and (equal? depth node-depth)
(equal? hed node-title)) ;; yep, this is the one!
(if (null? tal) ;; end of the line
nodenum
(loop (car tal)(cdr tal)(+ depth 1) nodenum))
(loop hed tal depth (+ nodenum 1)))))))
(main-loop)
|
>
>
|
|
|
|
|
>
|
<
<
|
|
>
|
|
|
|
|
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
|
)
(map (lambda (attr)
(print attr " is " (attribute t attr)))
'("KIND1" "PARENT2" "STATE1"))
(define (tree-find-node obj path)
;; start at the base of the tree
(if (null? path)
#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))))
;; (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
(loop (car tal)(cdr tal)(+ depth 1)(+ 1 nodenum)))
;; this is the case where we found part of the hierarchy but not
;; all of it, i.e. the node-depth went from deep to less deep
(if (> depth node-depth) ;; (+ 1 node-depth))
#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)
(if (not (attribute obj "TITLE0"))
(attribute-set! obj "ADDBRANCH0" top))
(cond
((not (string=? top (attribute obj "TITLE0")))
(print "ERROR: top name " top " doesn't match " (attribute obj "TITLE0")))
((null? nodelst))
(else
(let loop ((hed (car nodelst))
(tal (cdr nodelst))
(depth 1)
(pathl (list top)))
;; Because the tree dialog changes node numbers when
;; nodes are added or removed we must look up nodes
;; each and every time. 0 is the top node so default
;; to that.
(let* ((newpath (append pathl (list hed)))
(parentnode (tree-find-node obj pathl))
(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)
(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
#t
;; (if nodenum
(loop (car tal)(cdr tal)(+ depth 1) newpath)))))))) ;; (if nodenum nodenum lastnode)))))))
;; (loop hed tal depth pathl lastnode)))))))
(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" '()))
(test #f #t (tree-add-node t "Figures" '("a" "b" "c")))
(test #f 3 (tree-find-node t '("Figures" "a" "b" "c")))
(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)
|