home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / BIPL.ZIP / PROCS.ZIP / IMAGE.ICN < prev    next >
Encoding:
Text File  |  1992-11-20  |  8.5 KB  |  320 lines
  1. ############################################################################
  2. #
  3. #    File:     image.icn
  4. #
  5. #    Subject:  Procedures to produce images of Icon values
  6. #
  7. #    Author:   Michael Glass, Ralph E. Griswold, and David Yost
  8. #
  9. #    Date:     June 10, 1988
  10. #
  11. ###########################################################################
  12. #  
  13. #  The procedure Image(x,style) produces a string image of the value x.
  14. #  The value produced is a generalization of the value produced by
  15. #  the Icon function image(x), providing detailed information about
  16. #  structures. The value of style determines the formatting and
  17. #  order of processing:
  18. #
  19. #     1   indented, with ] and ) at end of last item (default)
  20. #     2   indented, with ] and ) on new line
  21. #     3   puts the whole image on one line
  22. #     4   as 3, but with structures expanded breadth-first instead of
  23. #         depth-first as for other styles.
  24. #  
  25. ############################################################################
  26. #
  27. #     Tags are used to uniquely identify structures. A tag consists
  28. #  of a letter identifying the type followed by an integer. The tag
  29. #  letters are L for lists, R for records, S for sets, and T for
  30. #  tables. The first time a structure is encountered, it is imaged
  31. #  as the tag followed by a colon, followed by a representation of
  32. #  the structure. If the same structure is encountered again, only
  33. #  the tag is given.
  34. #  
  35. #     An example is
  36. #  
  37. #     a := ["x"]
  38. #     push(a,a)
  39. #     t := table()
  40. #     push(a,t)
  41. #     t[a] := t
  42. #     t["x"] := []
  43. #     t[t] := a
  44. #     write(Image(t))
  45. #  
  46. #  which produces
  47. #  
  48. #  T1:[
  49. #    "x"->L1:[],
  50. #    L2:[
  51. #      T1,
  52. #      L2,
  53. #      "x"]->T1,
  54. #    T1->L2]
  55. #
  56. #  On the other hand, Image(t,3) produces
  57. #
  58. #     T1:["x"->L1:[],L2:[T1,L2,"x"]->T1,T1->L2]
  59. #  
  60. #  Note that a table is represented as a list of entry and assigned
  61. #  values separated by ->.
  62. #  
  63. ############################################################################
  64. #
  65. #  Problem:
  66. #
  67. #     The procedure here really is a combination of an earlier version and
  68. #  two modifications to it.  It should be re-organized to combine the
  69. #  presentation style and order of expansion.
  70. #
  71. #  Bug:
  72. #
  73. #     Since the table of structures used in a call to Image is local to
  74. #  that call, but the numbers used to generate unique tags are static to
  75. #  the procedures that generate tags, the same structure gets different
  76. #  tags in different calls of Image.
  77. #
  78. ############################################################################
  79.  
  80. procedure Image(x,style,done,depth,nonewline)
  81.    local retval
  82.  
  83.    if style === 4 then return Imageb(x)    # breadth-first style
  84.  
  85.    /style := 1
  86.    /done := table()
  87.    if /depth then depth := 0
  88.    else depth +:= 2
  89.    if (style ~= 3 & depth > 0 & /nonewline) then
  90.       retval := "\n" || repl(" ",depth)
  91.    else retval := ""
  92.    if match("record ",image(x)) then retval ||:= rimage(x,done,depth,style)
  93.    else {
  94.       retval ||:=
  95.       case type(x) of {
  96.      "list":  limage(x,done,depth,style)
  97.      "table": timage(x,done,depth,style)
  98.      "set":   simage(x,done,depth,style)
  99.      default: image(x)
  100.      }
  101.    }
  102.    depth -:= 2
  103.    return retval
  104. end
  105.  
  106. #  list image
  107. #
  108. procedure limage(a,done,depth,style)
  109.    static i
  110.    local s, tag
  111.    initial i := 0
  112.    if \done[a] then return done[a]
  113.    done[a] := tag := "L" || (i +:= 1)
  114.    if *a = 0 then s := tag || ":[]" else {
  115.       s := tag || ":["
  116.       every s ||:= Image(!a,style,done,depth) || ","
  117.       s[-1] := endof("]",depth,style)
  118.       }
  119.    return s
  120. end
  121.  
  122. #  record image
  123. #
  124. procedure rimage(x,done,depth,style)
  125.    static i
  126.    local s, tag
  127.    initial i := 0
  128.    s := image(x)
  129.                     #  might be record constructor
  130.    if match("record constructor ",s) then return s
  131.    if \done[x] then return done[x]
  132.    done[x] := tag := "R" || (i +:= 1)
  133.    s ?:=  (="record " & (":" || (tab(upto('(') + 1))))
  134.    if *x = 0 then s := tag || s || ")" else {
  135.       s := tag || s
  136.       every s ||:= Image(!x,style,done,depth) || ","
  137.       s[-1] := endof(")",depth,style)
  138.       }
  139.    return s
  140. end
  141.  
  142. # set image
  143. #
  144. procedure simage(S,done,depth,style)
  145.    static i
  146.    local s, tag
  147.    initial i := 0
  148.    if \done[S] then return done[S]
  149.    done[S] := tag := "S" || (i +:= 1)
  150.    if *S = 0 then s := tag || ":[]" else {
  151.       s := tag || ":["
  152.       every s ||:= Image(!S,style,done,depth) || ","
  153.       s[-1] := endof("]",depth,style)
  154.       }
  155.    return s
  156. end
  157.  
  158. #  table image
  159. #
  160. procedure timage(t,done,depth,style)
  161.    static i
  162.    local s, tag, a, a1
  163.    initial i := 0
  164.    if \done[t] then return done[t]
  165.    done[t] := tag := "T" || (i +:= 1)
  166.    if *t = 0 then s := tag || ":[]" else {
  167.       a := sort(t,3)
  168.       s := tag || ":["
  169.       while s ||:= Image(get(a),style,done,depth) || "->" ||
  170.            Image(get(a),style,done,depth,1) || ","
  171.       s[-1] := endof("]",depth,style)
  172.       }
  173.    return s
  174. end
  175.  
  176. procedure endof (s,depth,style)
  177.    if style = 2 then return "\n" || repl(" ",depth) || "]"
  178.    else return "]"
  179. end
  180.  
  181. ############################################################################
  182. #
  183. #  What follows is the breadth-first expansion style
  184. #
  185.  
  186. procedure Imageb(x, done, tags)
  187.    local t
  188.  
  189.    if /done then {
  190.       done := [set()]  # done[1] actually done; done[2:0] pseudo-done
  191.       tags := table()    # unique label for each structure
  192.       }
  193.  
  194.    if member(!done, x) then return tags[x]
  195.  
  196.    t := tagit(x, tags)     # The tag for x if structure; image(x) if not
  197.  
  198.    if /tags[x] then
  199.       return t                       # Wasn't a structure
  200.    else {
  201.       insert(done[1], x)             # Mark x as actually done
  202.       return case t[1] of {
  203.          "R":  rimageb(x, done, tags)     # record
  204.          "L":  limageb(x, done, tags)     # list
  205.          "T":  timageb(x, done, tags)     # table
  206.          "S":  simageb(x, done, tags)     # set
  207.          }
  208.       }
  209. end
  210.  
  211.  
  212. #  Create and return a tag for a structure, and save it in tags[x].
  213. #  Otherwise, if x is not a structure, return image(x).
  214. #
  215. procedure tagit(x, tags)
  216.    local ximage, t, prefix
  217.    static serial
  218.    initial serial := table(0)
  219.  
  220.    if \tags[x] then return tags[x]
  221.  
  222.    if match("record constructor ", ximage := image(x)) then
  223.       return ximage                # record constructor
  224.  
  225.    if match("record ", t := ximage) |
  226.       ((t := type(x)) == ("list" | "table" | "set")) then {
  227.          prefix := map(t[1], "rlts", "RLTS")
  228.          return tags[x] := prefix || (serial[prefix] +:=1)
  229.          }                        # structure
  230.  
  231.    else return ximage             # anything else
  232. end
  233.  
  234.  
  235. #  Every component sub-structure of the current structure gets tagged
  236. #  and added to a pseudo-done set.
  237. #
  238. procedure defer_image(a, done, tags)
  239.    local x, t
  240.    t := set()
  241.    every x := !a do {
  242.       tagit(x, tags)
  243.       if \tags[x] then insert(t, x)  # if x actually is a sub-structure
  244.       }
  245.    put(done, t)
  246.    return
  247. end
  248.  
  249.  
  250. #  Create the image of every component of the current structure.
  251. #  Sub-structures get deleted from the local pseudo-done set before
  252. #  we actually create their image.
  253. #
  254. procedure do_image(a, done, tags)
  255.    local x, t
  256.    t := done[-1]
  257.    suspend (delete(t, x := !a), Imageb(x, done, tags))
  258. end
  259.  
  260.  
  261. #  list image
  262. #
  263. procedure limageb(a, done, tags)
  264.    local s
  265.    if *a = 0 then s := tags[a] || ":[]" else {
  266.       defer_image(a, done, tags)
  267.       s := tags[a] || ":["
  268.       every s ||:= do_image(a, done, tags) || ","
  269.       s[-1] := "]"
  270.       pull(done)
  271.       }
  272.    return s
  273. end
  274.  
  275. #  record image
  276. #
  277. procedure rimageb(x, done, tags)
  278.    local s
  279.    s := image(x)
  280.    s ?:=  (="record " & (":" || (tab(upto('(') + 1))))
  281.    if *x = 0 then s := tags[x] || s || ")" else {
  282.       defer_image(x, done, tags)
  283.       s := tags[x] || s
  284.       every s ||:= do_image(x, done, tags) || ","
  285.       s[-1] := ")"
  286.       pull(done)
  287.       }
  288.    return s
  289. end
  290.  
  291. # set image
  292. #
  293. procedure simageb(S, done, tags)
  294.    local s
  295.    if *S = 0 then s := tags[S] || ":[]" else {
  296.       defer_image(S, done, tags)
  297.       s := tags[S] || ":["
  298.       every s ||:= do_image(S, done, tags) || ","
  299.       s[-1] := "]"
  300.       pull(done)
  301.       }
  302.    return s
  303. end
  304.  
  305. #  table image
  306. #
  307. procedure timageb(t, done, tags)
  308.    local s, a
  309.    if *t = 0 then s := tags[t] || ":[]" else {
  310.       a := sort(t,3)
  311.       defer_image(a, done, tags)
  312.       s := tags[t] || ":["
  313.       while s ||:= do_image([get(a)], done, tags) || "->" ||
  314.                    do_image([get(a)], done, tags) || ","
  315.       s[-1] := "]"
  316.       pull(done)
  317.       }
  318.    return s
  319. end
  320.