home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / BIPL.ZIP / PROCS.ZIP / STRUCTS.ICN < prev    next >
Encoding:
Text File  |  1992-09-28  |  4.4 KB  |  175 lines
  1. ############################################################################
  2. #
  3. #    File:     structs.icn
  4. #
  5. #    Subject:  Procedures for structure operations
  6. #
  7. #    Author:   Ralph E. Griswold
  8. #
  9. #    Date:     June 10, 1988
  10. #
  11. ###########################################################################
  12. #  
  13. #     These procedures manipulate structures.
  14. #  
  15. #       depth(t)    compute maximum depth of tree t
  16. #  
  17. #       eq(x,y)     compare list structures x and y
  18. #
  19. #       teq(t1,t2)  compare trees t1 and t2
  20. #  
  21. #       equiv(s,y)  compare arbitrary structures x and y
  22. #  
  23. #       ldag(s)     construct a dag from the string s
  24. #  
  25. #       ltree(s)    construct a tree from the string s
  26. #  
  27. #       stree(t)    construct a string from the tree t
  28. #  
  29. #       tcopy(t)    copy tree t
  30. #  
  31. #       visit(t)  visit, in preorder, the nodes of the tree t
  32. #  
  33. #     The procedure equiv() tests for the "equivalence" of two values. For types
  34. #  other than structures, it does the same thing as x1 === x2.  For structures,
  35. #  the test is for "shape".  For example,
  36. #
  37. #    equiv([],[])
  38. #
  39. #  succeeds.
  40. #
  41. #     It handles loops, but does not recognize them as such.  For example,
  42. #  given
  43. #
  44. #    L1 := []
  45. #    L2 := []
  46. #    put(L1,L1)
  47. #    put(L2,L1)
  48. #
  49. #    equiv(L1,L2)
  50. #
  51. #  succeeds.
  52. #
  53. #     The concept of equivalence for tables and sets is not quite right
  54. #  if their elements are themselves structures.  The problem is that there
  55. #  is no concept of order for tables and sets, yet it is impractical to
  56. #  test for equivalence of their elements without imposing an order.  Since
  57. #  structures sort by "age", there may be a mismatch between equivalent
  58. #  structures in two tables or sets.
  59. #
  60. #  Note:
  61. #     The procedures equiv and ldag have a trailing argument that is used on
  62. #  internal recursive calls; a second argument must not be supplied
  63. #  by the user.
  64. #  
  65. ############################################################################
  66.  
  67. procedure eq(x,y)
  68.    local i
  69.    if x === y then return y
  70.    if type(x) == type(y) == "list" then {
  71.       if *x ~= *y then fail
  72.       every i := 1 to *x do
  73.          if not eq(x[i],y[i]) then fail
  74.       return y
  75.      }
  76. end
  77.  
  78. procedure depth(ltree)
  79.    local count
  80.    count := 0
  81.    every count <:= 1 + depth(ltree[2 to *ltree])
  82.    return count
  83. end
  84.  
  85. procedure ldag(stree,done)
  86.    local L
  87.    /done := table()
  88.    if L := \done[stree] then return L
  89.    stree ?
  90.       if L := [tab(upto('('))] then {
  91.          move(1)
  92.          while put(L,ldag(tab(bal(',)')),done)) do
  93.             move(1)
  94.          }
  95.       else L := [tab(0)]
  96.    return done[stree] := L
  97. end
  98.  
  99. procedure ltree(stree)
  100.    local L
  101.    stree ?
  102.       if L := [tab(upto('('))] then {
  103.          move(1)
  104.          while put(L,ltree(tab(bal(',)')))) do
  105.             move(1)
  106.          }
  107.       else L := [tab(0)]
  108.    return L
  109. end
  110.  
  111. procedure stree(ltree)
  112.    local s
  113.    if *ltree = 1 then return ltree[1]
  114.    s := ltree[1] || "("
  115.    every s ||:= stree(ltree[2 to *ltree]) || ","
  116.    return s[1:-1] || ")"
  117. end
  118.  
  119. procedure tcopy(ltree)
  120.    local L
  121.    L := [ltree[1]]
  122.    every put(L,tcopy(ltree[2 to *ltree]))
  123.    return L
  124. end
  125.  
  126. procedure teq(L1,L2)
  127.    local i
  128.    if *L1 ~= *L2 then fail
  129.    if L1[1] ~== L2[1] then fail
  130.    every i := 2 to *L1 do
  131.       if not teq(L1[i],L2[i]) then fail
  132.    return L2
  133. end
  134.  
  135. procedure visit(ltree)
  136.    suspend ltree | visit(ltree[2 to *ltree])
  137. end
  138.     
  139. procedure equiv(x1,x2,done)
  140.    local code, i
  141.  
  142.    if x1 === x2 then return x2        # Covers everything but structures.
  143.  
  144.    if type(x1) ~== type(x2) then fail    # Must be same type.
  145.  
  146.    if type(x1) == ("procedure" | "file" | "window")
  147.       then fail                # Leave only those with sizes (null
  148.                     # taken care of by first two tests).
  149.  
  150.    if *x1 ~= *x2 then fail        # Skip a lot of possibly useless work.
  151.  
  152.                     # Structures (and others) remain.
  153.  
  154.    /done := table()            # Basic call.
  155.  
  156.    (/done[x1] := set()) |        # Make set of equivalences if new.
  157.       (if member(done[x1],x2) then return x2)
  158.  
  159.                     # Records complicate things.
  160.    image(x1) ? (code := (="record" | type(x1)))
  161.  
  162.    case code of {
  163.       "list" | "record": 
  164.          every i := 1 to *x1 do
  165.             if not equiv(x1[i],x2[i],done) then fail
  166.       "table": if not equiv(sort(x1,3),sort(x2,3),done) then fail
  167.       "set":   if not equiv(sort(x1),sort(x2),done) then fail
  168.       default: fail            # Vaues of other types are different. 
  169.       }
  170.  
  171.    insert(done[x1],x2)            # Equivalent; add to set.
  172.    return x2
  173.  
  174. end
  175.