Artifact
49f7155a591f25e17408c6228e87f894dee2610e:
0000: 3b 3b 20 53 6f 6d 65 20 74 72 65 65 20 75 74 69 ;; Some tree uti
0010: 6c 69 74 69 65 73 2e 20 28 43 29 20 32 30 31 34 lities. (C) 2014
0020: 20 4d 61 74 74 20 57 65 6c 6c 61 6e 64 2c 20 47 Matt Welland, G
0030: 50 4c 20 56 32 2e 30 0a 3b 3b 20 54 61 6b 65 20 PL V2.0.;; Take
0040: 66 72 6f 6d 20 4d 65 67 61 74 65 73 74 20 68 74 from Megatest ht
0050: 74 70 3a 2f 2f 77 77 77 2e 6b 69 61 74 6f 61 2e tp://www.kiatoa.
0060: 63 6f 6d 2f 66 6f 73 73 69 6c 73 2f 6d 65 67 61 com/fossils/mega
0070: 74 65 73 74 0a 3b 3b 0a 28 75 73 65 20 74 65 73 test.;;.(use tes
0080: 74 29 0a 28 72 65 71 75 69 72 65 2d 6c 69 62 72 t).(require-libr
0090: 61 72 79 20 69 75 70 29 0a 28 69 6d 70 6f 72 74 ary iup).(import
00a0: 20 28 70 72 65 66 69 78 20 69 75 70 20 69 75 70 (prefix iup iup
00b0: 3a 29 29 0a 0a 28 64 65 66 69 6e 65 20 74 20 23 :))..(define t #
00c0: 66 29 20 0a 0a 28 64 65 66 69 6e 65 20 74 72 65 f) ..(define tre
00d0: 65 2d 64 69 61 6c 6f 67 0a 20 20 28 69 75 70 3a e-dialog. (iup:
00e0: 64 69 61 6c 6f 67 0a 20 20 20 23 3a 74 69 74 6c dialog. #:titl
00f0: 65 20 22 54 72 65 65 20 54 65 73 74 22 0a 20 20 e "Tree Test".
0100: 20 28 6c 65 74 20 28 28 74 31 20 28 69 75 70 3a (let ((t1 (iup:
0110: 74 72 65 65 62 6f 78 0a 09 20 20 20 20 20 20 23 treebox.. #
0120: 3a 73 65 6c 65 63 74 69 6f 6e 5f 63 62 20 28 6c :selection_cb (l
0130: 61 6d 62 64 61 20 28 6f 62 6a 20 69 64 20 73 74 ambda (obj id st
0140: 61 74 65 29 0a 09 09 09 20 20 20 20 20 20 20 28 ate).... (
0150: 70 72 69 6e 74 20 22 73 65 6c 65 63 74 69 6f 6e print "selection
0160: 5f 64 62 20 77 69 74 68 20 69 64 3d 22 20 69 64 _db with id=" id
0170: 20 22 20 73 74 61 74 65 3d 22 20 73 74 61 74 65 " state=" state
0180: 29 0a 09 09 09 20 20 20 20 20 20 20 28 70 72 69 ).... (pri
0190: 6e 74 20 22 55 53 45 52 44 41 54 41 3a 20 22 20 nt "USERDATA: "
01a0: 28 69 75 70 3a 61 74 74 72 69 62 75 74 65 20 6f (iup:attribute o
01b0: 62 6a 20 22 55 53 45 52 44 41 54 41 22 29 29 0a bj "USERDATA")).
01c0: 09 09 09 20 20 20 20 20 20 20 28 70 72 69 6e 74 ... (print
01d0: 20 22 53 50 45 43 49 41 4c 44 41 54 41 3a 20 22 "SPECIALDATA: "
01e0: 20 28 69 75 70 3a 61 74 74 72 69 62 75 74 65 20 (iup:attribute
01f0: 6f 62 6a 20 22 53 50 45 43 49 41 4c 44 41 54 41 obj "SPECIALDATA
0200: 22 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 70 ")).... (p
0210: 72 69 6e 74 20 22 44 65 70 74 68 3a 20 22 20 28 rint "Depth: " (
0220: 69 75 70 3a 61 74 74 72 69 62 75 74 65 20 6f 62 iup:attribute ob
0230: 6a 20 22 44 45 50 54 48 22 29 29 0a 09 09 09 20 j "DEPTH"))....
0240: 20 20 20 20 20 20 29 29 29 29 0a 20 20 20 20 20 )))).
0250: 28 73 65 74 21 20 74 20 74 31 29 0a 20 20 20 20 (set! t t1).
0260: 20 74 31 29 29 29 0a 0a 28 69 75 70 3a 73 68 6f t1)))..(iup:sho
0270: 77 20 74 72 65 65 2d 64 69 61 6c 6f 67 29 0a 0a w tree-dialog)..
0280: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 65 6c (map (lambda (el
0290: 6e 61 6d 65 20 65 6c 29 0a 20 20 20 20 20 20 20 name el).
02a0: 28 70 72 69 6e 74 20 22 41 64 64 69 6e 67 20 22 (print "Adding "
02b0: 20 65 6c 6e 61 6d 65 20 22 20 77 69 74 68 20 76 elname " with v
02c0: 61 6c 75 65 20 22 20 65 6c 29 0a 20 20 20 20 20 alue " el).
02d0: 20 20 28 69 75 70 3a 61 74 74 72 69 62 75 74 65 (iup:attribute
02e0: 2d 73 65 74 21 20 74 20 65 6c 6e 61 6d 65 20 65 -set! t elname e
02f0: 6c 29 0a 20 20 20 20 20 20 20 28 69 75 70 3a 61 l). (iup:a
0300: 74 74 72 69 62 75 74 65 2d 73 65 74 21 20 74 20 ttribute-set! t
0310: 22 55 53 45 52 44 41 54 41 22 20 65 6c 29 29 0a "USERDATA" el)).
0320: 20 20 20 20 20 27 28 22 56 41 4c 55 45 22 20 22 '("VALUE" "
0330: 4e 41 4d 45 22 20 20 20 20 22 41 44 44 4c 45 41 NAME" "ADDLEA
0340: 46 22 20 22 41 44 44 42 52 41 4e 43 48 31 22 20 F" "ADDBRANCH1"
0350: 22 41 44 44 4c 45 41 46 32 22 20 20 20 20 22 56 "ADDLEAF2" "V
0360: 41 4c 55 45 22 29 0a 20 20 20 20 20 27 28 22 30 ALUE"). '("0
0370: 22 20 20 20 20 20 22 46 69 67 75 72 65 73 22 20 " "Figures"
0380: 22 4f 74 68 65 72 22 20 20 20 22 74 72 69 61 6e "Other" "trian
0390: 67 6c 65 22 20 20 20 22 65 71 75 69 6c 61 74 65 gle" "equilate
03a0: 72 61 6c 22 20 22 34 22 29 0a 20 20 20 20 20 29 ral" "4"). )
03b0: 0a 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 61 .(map (lambda (a
03c0: 74 74 72 29 0a 20 20 20 20 20 20 20 28 70 72 69 ttr). (pri
03d0: 6e 74 20 61 74 74 72 20 22 20 69 73 20 22 20 28 nt attr " is " (
03e0: 69 75 70 3a 61 74 74 72 69 62 75 74 65 20 74 20 iup:attribute t
03f0: 61 74 74 72 29 29 29 0a 20 20 20 20 20 27 28 22 attr))). '("
0400: 4b 49 4e 44 31 22 20 22 50 41 52 45 4e 54 32 22 KIND1" "PARENT2"
0410: 20 22 53 54 41 54 45 31 22 29 29 0a 0a 28 64 65 "STATE1"))..(de
0420: 66 69 6e 65 20 28 74 72 65 65 2d 66 69 6e 64 2d fine (tree-find-
0430: 6e 6f 64 65 20 6f 62 6a 20 70 61 74 68 29 0a 20 node obj path).
0440: 20 3b 3b 20 73 74 61 72 74 20 61 74 20 74 68 65 ;; start at the
0450: 20 62 61 73 65 20 6f 66 20 74 68 65 20 74 72 65 base of the tre
0460: 65 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 e. (if (null? p
0470: 61 74 68 29 0a 20 20 20 20 20 20 23 66 20 3b 3b ath). #f ;;
0480: 20 6f 72 20 30 20 3f 3f 3f 3f 0a 20 20 20 20 20 or 0 ????.
0490: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 (let loop ((hed
04a0: 20 20 20 20 20 20 28 63 61 72 20 70 61 74 68 29 (car path)
04b0: 29 0a 09 09 20 28 74 61 6c 20 20 20 20 20 20 28 )... (tal (
04c0: 63 64 72 20 70 61 74 68 29 29 0a 09 09 20 28 64 cdr path))... (d
04d0: 65 70 74 68 20 20 20 20 30 29 0a 09 09 20 28 6e epth 0)... (n
04e0: 6f 64 65 6e 75 6d 20 20 30 29 29 0a 09 3b 3b 20 odenum 0))..;;
04f0: 6e 6f 64 65 73 20 69 6e 20 69 75 70 20 74 72 65 nodes in iup tre
0500: 65 20 61 72 65 20 31 30 30 25 20 73 65 71 75 65 e are 100% seque
0510: 6e 74 69 61 6c 20 73 6f 20 69 74 65 72 61 74 65 ntial so iterate
0520: 20 6f 76 65 72 20 6e 6f 64 65 6e 75 6d 0a 09 28 over nodenum..(
0530: 69 66 20 28 69 75 70 3a 61 74 74 72 69 62 75 74 if (iup:attribut
0540: 65 20 6f 62 6a 20 28 63 6f 6e 63 20 22 44 45 50 e obj (conc "DEP
0550: 54 48 22 20 6e 6f 64 65 6e 75 6d 29 29 20 3b 3b TH" nodenum)) ;;
0560: 20 65 6e 64 20 77 68 65 6e 20 6e 6f 20 6d 6f 72 end when no mor
0570: 65 20 6e 6f 64 65 73 0a 09 20 20 20 20 28 6c 65 e nodes.. (le
0580: 74 20 28 28 6e 6f 64 65 2d 64 65 70 74 68 20 28 t ((node-depth (
0590: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 string->number (
05a0: 69 75 70 3a 61 74 74 72 69 62 75 74 65 20 6f 62 iup:attribute ob
05b0: 6a 20 28 63 6f 6e 63 20 22 44 45 50 54 48 22 20 j (conc "DEPTH"
05c0: 6e 6f 64 65 6e 75 6d 29 29 29 29 0a 09 09 20 20 nodenum))))...
05d0: 28 6e 6f 64 65 2d 74 69 74 6c 65 20 28 69 75 70 (node-title (iup
05e0: 3a 61 74 74 72 69 62 75 74 65 20 6f 62 6a 20 28 :attribute obj (
05f0: 63 6f 6e 63 20 22 54 49 54 4c 45 22 20 6e 6f 64 conc "TITLE" nod
0600: 65 6e 75 6d 29 29 29 29 0a 09 20 20 20 20 20 20 enum))))..
0610: 3b 3b 20 28 70 72 69 6e 74 20 30 20 22 68 65 64 ;; (print 0 "hed
0620: 3a 20 22 20 68 65 64 20 22 2c 20 64 65 70 74 68 : " hed ", depth
0630: 3a 20 22 20 64 65 70 74 68 20 22 2c 20 6e 6f 64 : " depth ", nod
0640: 65 2d 64 65 70 74 68 3a 20 22 20 6e 6f 64 65 2d e-depth: " node-
0650: 64 65 70 74 68 20 22 2c 20 6e 6f 64 65 6e 75 6d depth ", nodenum
0660: 3a 20 22 20 6e 6f 64 65 6e 75 6d 20 22 2c 20 6e : " nodenum ", n
0670: 6f 64 65 2d 74 69 74 6c 65 3a 20 22 20 6e 6f 64 ode-title: " nod
0680: 65 2d 74 69 74 6c 65 29 0a 09 20 20 20 20 20 20 e-title)..
0690: 28 69 66 20 28 61 6e 64 20 28 65 71 75 61 6c 3f (if (and (equal?
06a0: 20 64 65 70 74 68 20 6e 6f 64 65 2d 64 65 70 74 depth node-dept
06b0: 68 29 0a 09 09 20 20 20 20 20 20 20 28 65 71 75 h)... (equ
06c0: 61 6c 3f 20 68 65 64 20 20 20 6e 6f 64 65 2d 74 al? hed node-t
06d0: 69 74 6c 65 29 29 20 3b 3b 20 79 65 70 2c 20 74 itle)) ;; yep, t
06e0: 68 69 73 20 69 73 20 74 68 65 20 6f 6e 65 21 0a his is the one!.
06f0: 09 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 .. (if (null? t
0700: 61 6c 29 20 3b 3b 20 65 6e 64 20 6f 66 20 74 68 al) ;; end of th
0710: 65 20 6c 69 6e 65 0a 09 09 20 20 20 20 20 20 6e e line... n
0720: 6f 64 65 6e 75 6d 0a 09 09 20 20 20 20 20 20 28 odenum... (
0730: 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
0740: 64 72 20 74 61 6c 29 28 2b 20 64 65 70 74 68 20 dr tal)(+ depth
0750: 31 29 28 2b 20 31 20 6e 6f 64 65 6e 75 6d 29 29 1)(+ 1 nodenum))
0760: 29 0a 09 09 20 20 3b 3b 20 74 68 69 73 20 69 73 )... ;; this is
0770: 20 74 68 65 20 63 61 73 65 20 77 68 65 72 65 20 the case where
0780: 77 65 20 66 6f 75 6e 64 20 70 61 72 74 20 6f 66 we found part of
0790: 20 74 68 65 20 68 69 65 72 61 72 63 68 79 20 62 the hierarchy b
07a0: 75 74 20 6e 6f 74 20 0a 09 09 20 20 3b 3b 20 61 ut not ... ;; a
07b0: 6c 6c 20 6f 66 20 69 74 2c 20 69 2e 65 2e 20 74 ll of it, i.e. t
07c0: 68 65 20 6e 6f 64 65 2d 64 65 70 74 68 20 77 65 he node-depth we
07d0: 6e 74 20 66 72 6f 6d 20 64 65 65 70 20 74 6f 20 nt from deep to
07e0: 6c 65 73 73 20 64 65 65 70 0a 09 09 20 20 28 69 less deep... (i
07f0: 66 20 28 3e 20 64 65 70 74 68 20 6e 6f 64 65 2d f (> depth node-
0800: 64 65 70 74 68 29 20 3b 3b 20 28 2b 20 31 20 6e depth) ;; (+ 1 n
0810: 6f 64 65 2d 64 65 70 74 68 29 29 0a 09 09 20 20 ode-depth))...
0820: 20 20 20 20 23 66 0a 09 09 20 20 20 20 20 20 28 #f... (
0830: 6c 6f 6f 70 20 68 65 64 20 74 61 6c 20 64 65 70 loop hed tal dep
0840: 74 68 20 28 2b 20 6e 6f 64 65 6e 75 6d 20 31 29 th (+ nodenum 1)
0850: 29 29 29 29 0a 09 20 20 20 20 23 66 29 29 29 29 )))).. #f))))
0860: 0a 0a 3b 3b 20 74 6f 70 20 69 73 20 74 68 65 20 ..;; top is the
0870: 74 6f 70 20 6e 6f 64 65 20 6e 61 6d 65 20 7a 65 top node name ze
0880: 72 6f 65 74 68 20 6e 6f 64 65 20 56 41 4c 55 45 roeth node VALUE
0890: 3d 30 0a 28 64 65 66 69 6e 65 20 28 74 72 65 65 =0.(define (tree
08a0: 2d 61 64 64 2d 6e 6f 64 65 20 6f 62 6a 20 74 6f -add-node obj to
08b0: 70 20 6e 6f 64 65 6c 73 74 29 0a 20 20 28 69 66 p nodelst). (if
08c0: 20 28 6e 6f 74 20 28 69 75 70 3a 61 74 74 72 69 (not (iup:attri
08d0: 62 75 74 65 20 6f 62 6a 20 22 54 49 54 4c 45 30 bute obj "TITLE0
08e0: 22 29 29 0a 20 20 20 20 20 20 28 69 75 70 3a 61 ")). (iup:a
08f0: 74 74 72 69 62 75 74 65 2d 73 65 74 21 20 6f 62 ttribute-set! ob
0900: 6a 20 22 41 44 44 42 52 41 4e 43 48 30 22 20 74 j "ADDBRANCH0" t
0910: 6f 70 29 29 0a 20 20 28 63 6f 6e 64 0a 20 20 20 op)). (cond.
0920: 28 28 6e 6f 74 20 28 73 74 72 69 6e 67 3d 3f 20 ((not (string=?
0930: 74 6f 70 20 28 69 75 70 3a 61 74 74 72 69 62 75 top (iup:attribu
0940: 74 65 20 6f 62 6a 20 22 54 49 54 4c 45 30 22 29 te obj "TITLE0")
0950: 29 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 45 )). (print "E
0960: 52 52 4f 52 3a 20 74 6f 70 20 6e 61 6d 65 20 22 RROR: top name "
0970: 20 74 6f 70 20 22 20 64 6f 65 73 6e 27 74 20 6d top " doesn't m
0980: 61 74 63 68 20 22 20 28 69 75 70 3a 61 74 74 72 atch " (iup:attr
0990: 69 62 75 74 65 20 6f 62 6a 20 22 54 49 54 4c 45 ibute obj "TITLE
09a0: 30 22 29 29 29 0a 20 20 20 28 28 6e 75 6c 6c 3f 0"))). ((null?
09b0: 20 6e 6f 64 65 6c 73 74 29 29 0a 20 20 20 28 65 nodelst)). (e
09c0: 6c 73 65 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f lse. (let loo
09d0: 70 20 28 28 68 65 64 20 20 20 20 20 20 28 63 61 p ((hed (ca
09e0: 72 20 6e 6f 64 65 6c 73 74 29 29 0a 09 20 20 20 r nodelst))..
09f0: 20 20 20 20 28 74 61 6c 20 20 20 20 20 20 28 63 (tal (c
0a00: 64 72 20 6e 6f 64 65 6c 73 74 29 29 0a 09 20 20 dr nodelst))..
0a10: 20 20 20 20 20 28 64 65 70 74 68 20 20 20 20 31 (depth 1
0a20: 29 0a 09 20 20 20 20 20 20 20 28 70 61 74 68 6c ).. (pathl
0a30: 20 20 20 20 28 6c 69 73 74 20 74 6f 70 29 29 29 (list top)))
0a40: 0a 20 20 20 20 20 20 3b 3b 20 42 65 63 61 75 73 . ;; Becaus
0a50: 65 20 74 68 65 20 74 72 65 65 20 64 69 61 6c 6f e the tree dialo
0a60: 67 20 63 68 61 6e 67 65 73 20 6e 6f 64 65 20 6e g changes node n
0a70: 75 6d 62 65 72 73 20 77 68 65 6e 0a 20 20 20 20 umbers when.
0a80: 20 20 3b 3b 20 6e 6f 64 65 73 20 61 72 65 20 61 ;; nodes are a
0a90: 64 64 65 64 20 6f 72 20 72 65 6d 6f 76 65 64 20 dded or removed
0aa0: 77 65 20 6d 75 73 74 20 6c 6f 6f 6b 20 75 70 20 we must look up
0ab0: 6e 6f 64 65 73 0a 20 20 20 20 20 20 3b 3b 20 65 nodes. ;; e
0ac0: 61 63 68 20 61 6e 64 20 65 76 65 72 79 20 74 69 ach and every ti
0ad0: 6d 65 2e 20 30 20 69 73 20 74 68 65 20 74 6f 70 me. 0 is the top
0ae0: 20 6e 6f 64 65 20 73 6f 20 64 65 66 61 75 6c 74 node so default
0af0: 0a 20 20 20 20 20 20 3b 3b 20 74 6f 20 74 68 61 . ;; to tha
0b00: 74 2e 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 t.. (let* (
0b10: 28 6e 65 77 70 61 74 68 20 20 20 20 28 61 70 70 (newpath (app
0b20: 65 6e 64 20 70 61 74 68 6c 20 28 6c 69 73 74 20 end pathl (list
0b30: 68 65 64 29 29 29 0a 09 20 20 20 20 20 20 20 28 hed))).. (
0b40: 70 61 72 65 6e 74 6e 6f 64 65 20 28 74 72 65 65 parentnode (tree
0b50: 2d 66 69 6e 64 2d 6e 6f 64 65 20 6f 62 6a 20 70 -find-node obj p
0b60: 61 74 68 6c 29 29 0a 09 20 20 20 20 20 20 20 28 athl)).. (
0b70: 6e 6f 64 65 6e 75 6d 20 20 20 20 28 74 72 65 65 nodenum (tree
0b80: 2d 66 69 6e 64 2d 6e 6f 64 65 20 6f 62 6a 20 6e -find-node obj n
0b90: 65 77 70 61 74 68 29 29 29 0a 09 20 20 3b 3b 20 ewpath))).. ;;
0ba0: 28 70 72 69 6e 74 20 22 6e 65 77 70 61 74 68 3a (print "newpath:
0bb0: 20 22 20 6e 65 77 70 61 74 68 20 22 2c 20 6e 6f " newpath ", no
0bc0: 64 65 6e 75 6d 20 22 20 6e 6f 64 65 6e 75 6d 20 denum " nodenum
0bd0: 22 2c 20 68 65 64 3a 20 22 20 68 65 64 20 22 2c ", hed: " hed ",
0be0: 20 64 65 70 74 68 3a 20 22 20 64 65 70 74 68 20 depth: " depth
0bf0: 22 2c 20 70 61 72 65 6e 74 6e 6f 64 65 3a 20 22 ", parentnode: "
0c00: 20 70 61 72 65 6e 74 6e 6f 64 65 20 22 2c 20 70 parentnode ", p
0c10: 61 74 68 6c 3a 20 22 20 70 61 74 68 6c 29 0a 09 athl: " pathl)..
0c20: 20 20 3b 3b 20 41 64 64 20 74 68 65 20 62 72 61 ;; Add the bra
0c30: 6e 63 68 20 75 6e 64 65 72 20 6c 61 73 74 6e 6f nch under lastno
0c40: 64 65 20 69 66 20 6e 6f 74 20 66 6f 75 6e 64 0a de if not found.
0c50: 09 20 20 28 69 66 20 28 6e 6f 74 20 6e 6f 64 65 . (if (not node
0c60: 6e 75 6d 29 0a 09 20 20 20 20 20 20 28 62 65 67 num).. (beg
0c70: 69 6e 0a 09 09 28 69 75 70 3a 61 74 74 72 69 62 in...(iup:attrib
0c80: 75 74 65 2d 73 65 74 21 20 6f 62 6a 20 28 63 6f ute-set! obj (co
0c90: 6e 63 20 22 41 44 44 42 52 41 4e 43 48 22 20 70 nc "ADDBRANCH" p
0ca0: 61 72 65 6e 74 6e 6f 64 65 29 20 68 65 64 29 0a arentnode) hed).
0cb0: 09 09 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c ..(if (null? tal
0cc0: 29 0a 09 09 20 20 20 20 23 74 0a 09 09 20 20 20 )... #t...
0cd0: 20 3b 3b 20 72 65 73 65 74 20 74 6f 20 74 6f 70 ;; reset to top
0ce0: 0a 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 ... (loop (ca
0cf0: 72 20 6e 6f 64 65 6c 73 74 29 28 63 64 72 20 6e r nodelst)(cdr n
0d00: 6f 64 65 6c 73 74 29 20 31 20 28 6c 69 73 74 20 odelst) 1 (list
0d10: 74 6f 70 29 29 29 29 20 0a 09 20 20 20 20 20 20 top)))) ..
0d20: 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 20 (if (null? tal)
0d30: 3b 3b 20 69 66 20 6e 75 6c 6c 20 68 65 72 65 20 ;; if null here
0d40: 74 68 65 6e 20 74 68 69 73 20 70 61 74 68 20 68 then this path h
0d50: 61 73 20 61 6c 72 65 61 64 79 20 62 65 65 6e 20 as already been
0d60: 61 64 64 65 64 0a 09 09 20 20 23 74 0a 09 09 20 added... #t...
0d70: 20 3b 3b 20 28 69 66 20 6e 6f 64 65 6e 75 6d 0a ;; (if nodenum.
0d80: 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 .. (loop (car t
0d90: 61 6c 29 28 63 64 72 20 74 61 6c 29 28 2b 20 64 al)(cdr tal)(+ d
0da0: 65 70 74 68 20 31 29 20 6e 65 77 70 61 74 68 29 epth 1) newpath)
0db0: 29 29 29 29 29 29 29 20 3b 3b 20 20 28 69 66 20 ))))))) ;; (if
0dc0: 6e 6f 64 65 6e 75 6d 20 6e 6f 64 65 6e 75 6d 20 nodenum nodenum
0dd0: 6c 61 73 74 6e 6f 64 65 29 29 29 29 29 29 29 0a lastnode))))))).
0de0: 09 20 20 20 20 20 20 3b 3b 20 09 20 20 28 6c 6f . ;; . (lo
0df0: 6f 70 20 68 65 64 20 74 61 6c 20 64 65 70 74 68 op hed tal depth
0e00: 20 70 61 74 68 6c 20 6c 61 73 74 6e 6f 64 65 29 pathl lastnode)
0e10: 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))))..(define
0e20: 28 74 72 65 65 2d 6e 6f 64 65 2d 3e 70 61 74 68 (tree-node->path
0e30: 20 6f 62 6a 20 6e 6f 64 65 6e 75 6d 29 0a 20 20 obj nodenum).
0e40: 3b 3b 20 28 70 72 69 6e 74 20 22 5c 6e 63 75 72 ;; (print "\ncur
0e50: 72 6e 6f 64 65 20 20 6e 6f 64 65 6e 75 6d 20 20 rnode nodenum
0e60: 64 65 70 74 68 20 20 6e 6f 64 65 2d 64 65 70 74 depth node-dept
0e70: 68 20 20 6e 6f 64 65 2d 74 69 74 6c 65 20 20 20 h node-title
0e80: 70 61 74 68 22 29 0a 20 20 28 6c 65 74 20 6c 6f path"). (let lo
0e90: 6f 70 20 28 28 63 75 72 72 6e 6f 64 65 20 30 29 op ((currnode 0)
0ea0: 0a 09 20 20 20 20 20 28 64 65 70 74 68 20 20 20 .. (depth
0eb0: 20 30 29 0a 09 20 20 20 20 20 28 70 61 74 68 20 0).. (path
0ec0: 20 20 20 20 27 28 29 29 29 0a 20 20 20 20 28 6c '())). (l
0ed0: 65 74 20 28 28 6e 6f 64 65 2d 64 65 70 74 68 20 et ((node-depth
0ee0: 28 69 75 70 3a 61 74 74 72 69 62 75 74 65 20 6f (iup:attribute o
0ef0: 62 6a 20 28 63 6f 6e 63 20 22 44 45 50 54 48 22 bj (conc "DEPTH"
0f00: 20 63 75 72 72 6e 6f 64 65 29 29 29 0a 09 20 20 currnode)))..
0f10: 28 6e 6f 64 65 2d 74 69 74 6c 65 20 28 69 75 70 (node-title (iup
0f20: 3a 61 74 74 72 69 62 75 74 65 20 6f 62 6a 20 28 :attribute obj (
0f30: 63 6f 6e 63 20 22 54 49 54 4c 45 22 20 63 75 72 conc "TITLE" cur
0f40: 72 6e 6f 64 65 29 29 29 29 0a 20 20 20 20 20 20 rnode)))).
0f50: 3b 3b 20 28 64 69 73 70 6c 61 79 20 28 63 6f 6e ;; (display (con
0f60: 63 20 22 5c 6e 20 20 20 22 63 75 72 72 6e 6f 64 c "\n "currnod
0f70: 65 20 22 20 20 20 20 20 20 20 20 22 20 6e 6f 64 e " " nod
0f80: 65 6e 75 6d 20 22 20 20 20 20 20 20 20 22 20 64 enum " " d
0f90: 65 70 74 68 20 22 20 20 20 20 20 20 20 20 20 22 epth " "
0fa0: 20 6e 6f 64 65 2d 64 65 70 74 68 20 22 20 20 20 node-depth "
0fb0: 20 20 20 20 20 20 20 22 20 6e 6f 64 65 2d 74 69 " node-ti
0fc0: 74 6c 65 20 22 20 20 20 20 20 20 20 20 20 22 20 tle " "
0fd0: 70 61 74 68 29 29 0a 20 20 20 20 20 20 28 69 66 path)). (if
0fe0: 20 28 3e 20 63 75 72 72 6e 6f 64 65 20 6e 6f 64 (> currnode nod
0ff0: 65 6e 75 6d 29 0a 09 20 20 70 61 74 68 0a 09 20 enum).. path..
1000: 20 28 69 66 20 28 6e 6f 74 20 6e 6f 64 65 2d 64 (if (not node-d
1010: 65 70 74 68 29 20 3b 3b 20 23 66 20 69 66 20 77 epth) ;; #f if w
1020: 65 20 61 72 65 20 6f 75 74 20 6f 66 20 6e 6f 64 e are out of nod
1030: 65 73 0a 09 20 20 20 20 20 20 27 28 29 0a 09 20 es.. '()..
1040: 20 20 20 20 20 28 6c 65 74 20 28 28 6e 64 65 70 (let ((ndep
1050: 74 68 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 th (string->numb
1060: 65 72 20 6e 6f 64 65 2d 64 65 70 74 68 29 29 29 er node-depth)))
1070: 0a 09 09 28 69 66 20 28 65 71 3f 20 6e 64 65 70 ...(if (eq? ndep
1080: 74 68 20 64 65 70 74 68 29 0a 09 09 20 20 20 20 th depth)...
1090: 3b 3b 20 54 68 69 73 20 6e 65 78 74 20 69 73 20 ;; This next is
10a0: 74 68 65 20 6d 61 74 63 68 20 63 6f 6e 64 69 74 the match condit
10b0: 69 6f 6e 20 64 65 70 74 68 20 3d 3d 20 6e 6f 64 ion depth == nod
10c0: 65 2d 64 65 70 74 68 0a 09 09 20 20 20 20 28 69 e-depth... (i
10d0: 66 20 28 65 71 3f 20 63 75 72 72 6e 6f 64 65 20 f (eq? currnode
10e0: 6e 6f 64 65 6e 75 6d 29 0a 09 09 09 28 62 65 67 nodenum)....(beg
10f0: 69 6e 0a 09 09 09 20 20 3b 3b 20 28 64 69 73 70 in.... ;; (disp
1100: 6c 61 79 20 22 20 3c 58 3e 22 29 0a 09 09 09 20 lay " <X>")....
1110: 20 28 61 70 70 65 6e 64 20 70 61 74 68 20 28 6c (append path (l
1120: 69 73 74 20 6e 6f 64 65 2d 74 69 74 6c 65 29 29 ist node-title))
1130: 29 0a 09 09 09 28 6c 6f 6f 70 20 28 2b 20 63 75 )....(loop (+ cu
1140: 72 72 6e 6f 64 65 20 31 29 0a 09 09 09 20 20 20 rrnode 1)....
1150: 20 20 20 28 2b 20 64 65 70 74 68 20 31 29 0a 09 (+ depth 1)..
1160: 09 09 20 20 20 20 20 20 28 61 70 70 65 6e 64 20 .. (append
1170: 70 61 74 68 20 28 6c 69 73 74 20 6e 6f 64 65 2d path (list node-
1180: 74 69 74 6c 65 29 29 29 29 0a 09 09 20 20 20 20 title))))...
1190: 3b 3b 20 64 69 64 6e 27 74 20 6d 61 74 63 68 2c ;; didn't match,
11a0: 20 72 65 73 65 74 20 74 6f 20 62 61 73 65 20 70 reset to base p
11b0: 61 74 68 20 61 6e 64 20 6b 65 65 70 20 6c 6f 6f ath and keep loo
11c0: 6b 69 6e 67 0a 09 09 20 20 20 20 3b 3b 20 64 75 king... ;; du
11d0: 65 20 74 6f 20 6d 6f 72 65 20 69 75 70 20 6f 64 e to more iup od
11e0: 64 69 74 79 73 20 77 65 20 64 6f 6e 27 74 20 72 ditys we don't r
11f0: 65 73 65 74 20 74 6f 20 62 61 73 65 0a 09 09 20 eset to base...
1200: 20 20 20 28 62 65 67 69 6e 20 0a 09 09 20 20 20 (begin ...
1210: 20 20 20 3b 3b 20 28 64 69 73 70 6c 61 79 20 22 ;; (display "
1220: 20 3c 4c 3e 22 29 0a 09 09 20 20 20 20 20 20 28 <L>")... (
1230: 6c 6f 6f 70 20 28 2b 20 31 20 63 75 72 72 6e 6f loop (+ 1 currno
1240: 64 65 29 0a 09 09 09 20 20 20 20 32 0a 09 09 09 de).... 2....
1250: 20 20 20 20 28 61 70 70 65 6e 64 20 28 74 61 6b (append (tak
1260: 65 20 70 61 74 68 20 6e 64 65 70 74 68 29 28 6c e path ndepth)(l
1270: 69 73 74 20 6e 6f 64 65 2d 74 69 74 6c 65 29 29 ist node-title))
1280: 29 29 29 29 29 29 29 29 29 0a 0a 28 74 65 73 74 )))))))))..(test
1290: 20 23 66 20 30 20 20 28 74 72 65 65 2d 66 69 6e #f 0 (tree-fin
12a0: 64 2d 6e 6f 64 65 20 74 20 27 28 22 46 69 67 75 d-node t '("Figu
12b0: 72 65 73 22 29 29 29 0a 28 74 65 73 74 20 23 66 res"))).(test #f
12c0: 20 31 20 20 28 74 72 65 65 2d 66 69 6e 64 2d 6e 1 (tree-find-n
12d0: 6f 64 65 20 74 20 27 28 22 46 69 67 75 72 65 73 ode t '("Figures
12e0: 22 20 22 4f 74 68 65 72 22 29 29 29 0a 28 74 65 " "Other"))).(te
12f0: 73 74 20 23 66 20 23 66 20 28 74 72 65 65 2d 66 st #f #f (tree-f
1300: 69 6e 64 2d 6e 6f 64 65 20 74 20 27 28 22 46 69 ind-node t '("Fi
1310: 67 75 72 65 73 22 20 22 4f 74 68 65 72 22 20 20 gures" "Other"
1320: 20 20 22 65 71 75 69 6c 61 74 65 72 61 6c 22 29 "equilateral")
1330: 29 29 0a 28 74 65 73 74 20 23 66 20 33 20 20 28 )).(test #f 3 (
1340: 74 72 65 65 2d 66 69 6e 64 2d 6e 6f 64 65 20 74 tree-find-node t
1350: 20 27 28 22 46 69 67 75 72 65 73 22 20 22 74 72 '("Figures" "tr
1360: 69 61 6e 67 6c 65 22 20 22 65 71 75 69 6c 61 74 iangle" "equilat
1370: 65 72 61 6c 22 29 29 29 0a 28 74 65 73 74 20 23 eral"))).(test #
1380: 66 20 23 74 20 28 74 72 65 65 2d 61 64 64 2d 6e f #t (tree-add-n
1390: 6f 64 65 20 20 74 20 22 46 69 67 75 72 65 73 22 ode t "Figures"
13a0: 20 27 28 29 29 29 0a 28 74 65 73 74 20 23 66 20 '())).(test #f
13b0: 23 74 20 28 74 72 65 65 2d 61 64 64 2d 6e 6f 64 #t (tree-add-nod
13c0: 65 20 20 74 20 22 46 69 67 75 72 65 73 22 20 27 e t "Figures" '
13d0: 28 22 61 22 20 22 62 22 20 22 63 22 29 29 29 0a ("a" "b" "c"))).
13e0: 28 74 65 73 74 20 23 66 20 33 20 20 28 74 72 65 (test #f 3 (tre
13f0: 65 2d 66 69 6e 64 2d 6e 6f 64 65 20 74 20 27 28 e-find-node t '(
1400: 22 46 69 67 75 72 65 73 22 20 22 61 22 20 22 62 "Figures" "a" "b
1410: 22 20 22 63 22 29 29 29 0a 28 74 65 73 74 20 23 " "c"))).(test #
1420: 66 20 23 74 20 28 74 72 65 65 2d 61 64 64 2d 6e f #t (tree-add-n
1430: 6f 64 65 20 20 74 20 22 46 69 67 75 72 65 73 22 ode t "Figures"
1440: 20 27 28 22 64 22 20 22 62 22 20 22 63 22 29 29 '("d" "b" "c"))
1450: 29 0a 28 74 65 73 74 20 23 66 20 33 20 20 28 74 ).(test #f 3 (t
1460: 72 65 65 2d 66 69 6e 64 2d 6e 6f 64 65 20 74 20 ree-find-node t
1470: 27 28 22 46 69 67 75 72 65 73 22 20 22 64 22 20 '("Figures" "d"
1480: 22 62 22 20 22 63 22 29 29 29 0a 28 74 65 73 74 "b" "c"))).(test
1490: 20 23 66 20 36 20 20 28 74 72 65 65 2d 66 69 6e #f 6 (tree-fin
14a0: 64 2d 6e 6f 64 65 20 74 20 27 28 22 46 69 67 75 d-node t '("Figu
14b0: 72 65 73 22 20 22 61 22 20 22 62 22 20 22 63 22 res" "a" "b" "c"
14c0: 29 29 29 0a 28 74 65 73 74 20 23 66 20 23 74 20 ))).(test #f #t
14d0: 28 74 72 65 65 2d 61 64 64 2d 6e 6f 64 65 20 20 (tree-add-node
14e0: 74 20 22 46 69 67 75 72 65 73 22 20 27 28 22 61 t "Figures" '("a
14f0: 22 20 22 65 22 20 22 63 22 29 29 29 0a 28 74 65 " "e" "c"))).(te
1500: 73 74 20 23 66 20 36 20 20 28 74 72 65 65 2d 66 st #f 6 (tree-f
1510: 69 6e 64 2d 6e 6f 64 65 20 74 20 27 28 22 46 69 ind-node t '("Fi
1520: 67 75 72 65 73 22 20 22 61 22 20 22 65 22 20 22 gures" "a" "e" "
1530: 63 22 29 29 29 0a 0a 28 74 65 73 74 20 23 66 20 c")))..(test #f
1540: 27 28 22 46 69 67 75 72 65 73 22 29 20 20 20 20 '("Figures")
1550: 20 20 20 20 20 20 20 20 20 28 74 72 65 65 2d 6e (tree-n
1560: 6f 64 65 2d 3e 70 61 74 68 20 74 20 30 29 29 0a ode->path t 0)).
1570: 28 74 65 73 74 20 23 66 20 27 28 22 46 69 67 75 (test #f '("Figu
1580: 72 65 73 22 20 22 64 22 29 20 20 20 20 20 20 20 res" "d")
1590: 20 20 28 74 72 65 65 2d 6e 6f 64 65 2d 3e 70 61 (tree-node->pa
15a0: 74 68 20 74 20 31 29 29 0a 28 74 65 73 74 20 23 th t 1)).(test #
15b0: 66 20 27 28 22 46 69 67 75 72 65 73 22 20 22 64 f '("Figures" "d
15c0: 22 20 22 62 22 20 22 63 22 29 20 28 74 72 65 65 " "b" "c") (tree
15d0: 2d 6e 6f 64 65 2d 3e 70 61 74 68 20 74 20 33 29 -node->path t 3)
15e0: 29 0a 28 74 65 73 74 20 23 66 20 27 28 22 46 69 ).(test #f '("Fi
15f0: 67 75 72 65 73 22 20 22 61 22 29 20 20 20 20 20 gures" "a")
1600: 20 20 20 20 28 74 72 65 65 2d 6e 6f 64 65 2d 3e (tree-node->
1610: 70 61 74 68 20 74 20 34 29 29 0a 28 74 65 73 74 path t 4)).(test
1620: 20 23 66 20 27 28 22 46 69 67 75 72 65 73 22 20 #f '("Figures"
1630: 22 61 22 20 22 62 22 20 22 63 22 29 20 20 20 20 "a" "b" "c")
1640: 20 28 74 72 65 65 2d 6e 6f 64 65 2d 3e 70 61 74 (tree-node->pat
1650: 68 20 74 20 38 29 29 20 0a 28 74 65 73 74 20 23 h t 8)) .(test #
1660: 66 20 27 28 29 20 20 20 20 20 20 20 20 20 20 20 f '()
1670: 20 20 20 20 20 20 20 20 20 20 20 28 74 72 65 65 (tree
1680: 2d 6e 6f 64 65 2d 3e 70 61 74 68 20 74 20 34 30 -node->path t 40
1690: 29 29 0a 0a 28 69 75 70 3a 6d 61 69 6e 2d 6c 6f ))..(iup:main-lo
16a0: 6f 70 29 0a 0a op)..