home *** CD-ROM | disk | FTP | other *** search
/ ftp.cs.arizona.edu / ftp.cs.arizona.edu.tar / ftp.cs.arizona.edu / icon / historic / v941.tgz / icon.v941src.tar / icon.v941src / ipl / procs / lists.icn < prev    next >
Text File  |  2002-01-24  |  29KB  |  1,340 lines
  1. ############################################################################
  2. #
  3. #    File:     lists.icn
  4. #
  5. #    Subject:  Procedures to manipulate lists
  6. #
  7. #    Author:   Ralph E. Griswold
  8. #
  9. #    Date:     October 22, 2001
  10. #
  11. ############################################################################
  12. #
  13. #   This file is in the public domain.
  14. #
  15. ############################################################################
  16. #
  17. #    Contributor:  Richard L. Goerwitz
  18. #
  19. ############################################################################
  20. #
  21. #    file2lst(s)    create list from lines in file
  22. #
  23. #    imag2lst(s)    convert limage() output to list
  24. #
  25. #    l_Bscan(e1)    begin list scanning
  26. #
  27. #    l_Escan(l_OuterEnvir, e2)
  28. #            end list scanning
  29. #
  30. #    l_any(l1,l2,i,j)
  31. #            any() for list scanning
  32. #
  33. #    l_bal(l1,l2,l3,l,i,j
  34. #            bal() for list scanning
  35. #
  36. #    l_find(l1,l2,i,j)
  37. #            find() for list scanning
  38. #
  39. #    l_many(l1,l2,i,j)
  40. #            many() for list scanning
  41. #
  42. #    l_match(l1,l2,i,j)
  43. #            match() for list scanning
  44. #
  45. #    l_move(i)    move() for list scanning
  46. #
  47. #    l_pos(i)    pos() for list scanning
  48. #
  49. #    l_tab(i)    tab() for list scanning
  50. #
  51. #    l_upto(l1,l2,i,j)
  52. #            upto() for list scanning
  53. #
  54. #    lclose(L)    close open palindrome
  55. #
  56. #    lcomb(L,i)    list combinations
  57. #
  58. #    lcompact(L)    compact list, mapping out missing values
  59. #
  60. #    ldecollate(I, L)
  61. #            list decollation
  62. #
  63. #    ldelete(L, spec)
  64. #            list deletion
  65. #
  66. #    ldupl(L, i)    list term duplication
  67. #
  68. #    lequiv(L1, L2)    list equivalence
  69. #
  70. #    levate(L, m, n)    list elevation
  71. #
  72. #    lextend(L, i)    list extension
  73. #
  74. #    lfliph(L)    list horizontal flip (reversal)
  75. #
  76. #    lflipv(L)    list vertical flip
  77. #
  78. #    limage(L)    unadorned list image
  79. #
  80. #    lindex(L, x)
  81. #            generate indices of L whose values are x
  82. #
  83. #    lcollate(L1, L2, ...)
  84. #            list collation; like linterl() except stops on
  85. #            short list
  86. #
  87. #    lconstant(L)    succeeds and returns element if all are the same
  88. #
  89. #    linterl(L1, L2)    list interleaving
  90. #
  91. #    llayer(L1, L2, ...)
  92. #            layer and interleave L1, L2, ... 
  93. #
  94. #    llpad(L, i, x)    list padding at left
  95. #
  96. #    lltrim(L, S)    list left trimming
  97. #
  98. #    lmap(L1,L2,L3)    list mapping
  99. #
  100. #    lpalin(L, x)    list palindrome
  101. #
  102. #    lpermute(L)    list permutations
  103. #
  104. #    lreflect(L, i)  returns L concatenated with its reversal to produce
  105. #            palindrome; the values of i determine "end
  106. #            conditions" for the reversal:
  107. #
  108. #                0    omit first and last elements; default
  109. #                1    omit first element
  110. #                2    omit last element
  111. #                3    don't omit element
  112. #
  113. #    lremvals(L, x1, x2, ...)
  114. #            remove values from list
  115. #
  116. #    lrepl(L, i)    list replication
  117. #
  118. #    lresidue(L, m, i)
  119. #            list residue
  120. #
  121. #    lreverse(L)    list reverse
  122. #
  123. #    lrotate(L, i)    list rotation
  124. #
  125. #    lrpad(L, i, x)    list right padding
  126. #
  127. #    lrundown(L1, L2, L3)
  128. #            list run down
  129. #
  130. #    lrunup(L1, L2, L3)
  131. #            list run up
  132. #
  133. #    lrtrim(L, S)    list right trimming
  134. #
  135. #    lshift(L, i)    shift list terms
  136. #
  137. #    lswap(L)    list element swap
  138. #
  139. #    lunique(L)    keep only unique list elements
  140. #
  141. #    lmaxlen(L, p)    returns the size of the largest value in L.
  142. #            If p is given, it is applied to each string as
  143. #            as a "length" procedure.  The default for p is
  144. #            proc("*", 1).
  145. #
  146. #    lminlen(L, p)    returns the size of the smallest value in L.
  147. #            If p is given, it is applied to each string as
  148. #            as a "length" procedure.  The default for p is
  149. #            proc("*", 1).
  150. #
  151. #    sortkeys(L)    returns list of keys from L, where L is the
  152. #            result of sorting a table with option 3 or 4.
  153. #
  154. #    sortvalues(L)    return list of values from L, where L is the
  155. #            result of sorting a table with option 3 or 4.
  156. #
  157. #    str2lst(s, i)    creates list with i-character lines from s.  The
  158. #            default for i is 1.
  159. #
  160. ############################################################################
  161. #
  162. #        About List Mapping
  163. #
  164. #  The procedure lmap(L1,L2,L3) maps elements of L1 according to L2
  165. #  and L3.  This procedure is the analog for lists of the built-in
  166. #  string-mapping function map(s1,s2,s3). Elements in L1 that are
  167. #  the same as elements in L2 are mapped into the corresponding ele-
  168. #  ments of L3. For example, given the lists
  169. #  
  170. #     L1 := [1,2,3,4]
  171. #     L2 := [4,3,2,1]
  172. #     L3 := ["a","b","c","d"]
  173. #  
  174. #  then
  175. #  
  176. #     lmap(L1,L2,L3)
  177. #  
  178. #  produces a new list
  179. #  
  180. #     ["d","c","b","a"]
  181. #  
  182. #     Lists that are mapped can have any kinds of elements. The
  183. #  operation
  184. #  
  185. #     x === y
  186. #  
  187. #  is used to determine if elements x and y are equivalent.
  188. #  
  189. #     All cases in lmap are handled as they are in map, except that
  190. #  no defaults are provided for omitted arguments. As with map, lmap
  191. #  can be used for transposition as well as substitution.
  192. #  
  193. #  Warning:
  194. #
  195. #     If lmap is called with the same lists L2 and L3 as in
  196. #  the immediately preceding call, the same mapping is performed,
  197. #  even if the values in L2 and L3 have been changed. This improves
  198. #  performance, but it may cause unexpected effects.
  199. #  
  200. #     This ``caching'' of the mapping table based on L2 and L3
  201. #  can be easily removed to avoid this potential problem.
  202. #  
  203. ############################################################################
  204. #
  205. #    About List Scanning by Richard L. Goerwitz
  206. #
  207. #  PURPOSE: String scanning is terrific, but often I am forced to
  208. #  tokenize and work with lists.  So as to make operations on these
  209. #  lists as close to corresponding string operations as possible, I've
  210. #  implemented a series of list analogues to any(), bal(), find(),
  211. #  many(), match(), move(), pos(), tab(), and upto().  Their names are
  212. #  just like corresponding string functions, except with a prepended
  213. #  "l_" (e.g. l_any()).  Functionally, the list routines parallel the
  214. #  string ones closely, except that in place of strings, l_find and
  215. #  l_match accept lists as their first argument.  L_any(), l_many(),
  216. #  and l_upto() all take either sets of lists or lists of lists (e.g.
  217. #  l_tab(l_upto([["a"],["b"],["j","u","n","k"]])).  Note that l_bal(),
  218. #  unlike the builtin bal(), has no defaults for the first four
  219. #  arguments.  This just seemed appropriate, given that no precise
  220. #  list analogue to &cset, etc. occurs.
  221. #
  222. #  The default subject for list scans (analogous to &subject) is
  223. #  l_SUBJ.  The equivalent of &pos is l_POS.  Naturally, these
  224. #  variables are both global.  They are used pretty much like &subject
  225. #  and &pos, except that they are null until a list scanning
  226. #  expression has been encountered containing a call to l_Bscan() (on
  227. #  which, see below).
  228. #
  229. #  Note that environments cannot be maintained quite as elegantly as
  230. #  they can be for the builtin string-scanning functions.  One must
  231. #  use instead a set of nested procedure calls, as explained in the
  232. #  _Icon Analyst_ 1:6 (June, 1991), p. 1-2.  In particular, one cannot
  233. #  suspend, return, or otherwise break out of the nested procedure
  234. #  calls.  They can only be exited via failure.  The names of these
  235. #  procedures, at least in this implementation, are l_Escan and
  236. #  l_Bscan.  Here is one example of how they might be invoked:
  237. #
  238. #      suspend l_Escan(l_Bscan(some_list_or_other), {
  239. #          l_tab(10 to *l_SUBJ) & {
  240. #              if l_any(l1) | l_match(l2) then
  241. #                  old_l_POS + (l_POS-1)
  242. #          }
  243. #      })
  244. #
  245. #  Note that you cannot do this:
  246. #
  247. #      l_Escan(l_Bscan(some_list_or_other), {
  248. #          l_tab(10 to *l_SUBJ) & {
  249. #              if l_any(l1) | l_match(l2) then
  250. #                  suspend old_l_POS + (l_POS-1)
  251. #          }
  252. #      })
  253. #
  254. #  Remember, it's no fair to use suspend within the list scanning
  255. #  expression.  l_Escan must do all the suspending.  It is perfectly OK,
  256. #  though, to nest well-behaved list scanning expressions.  And they can
  257. #  be reliably used to generate a series of results as well.
  258. #
  259. ############################################################################
  260. #
  261. #  Here's another simple example of how one might invoke the l_scan
  262. #  routines:
  263. #
  264. #  procedure main()
  265. #
  266. #      l := ["h","e","l","l","o"," ","t","t","t","h","e","r","e"]
  267. #
  268. #      l_Escan(l_Bscan(l), {
  269. #          hello_list := l_tab(l_match(["h","e","l","l","o"]))
  270. #          every writes(!hello_list)
  271. #          write()
  272. #
  273. #          # Note the nested list-scanning expressions.
  274. #       l_Escan(l_Bscan(l_tab(0)), {
  275. #           l_tab(l_many([[" "],["t"]]) - 1)
  276. #              every writes(!l_tab(0))
  277. #           write()
  278. #          })
  279. #      })
  280. #  
  281. #  end
  282. #
  283. #  The above program simply writes "hello" and "there" on successive
  284. #  lines to the standard output.
  285. #
  286. ############################################################################
  287. #
  288. #  PITFALLS: In general, note that we are comparing lists here instead
  289. #  of strings, so l_find("h", l), for instance, will yield an error
  290. #  message (use l_find(["h"], l) instead).  The point at which I
  291. #  expect this nuance will be most confusing will be in cases where
  292. #  one is looking for lists within lists.  Suppose we have a list,
  293. #
  294. #      l1 := ["junk",[["hello"]," ",["there"]],"!","m","o","r","e","junk"]
  295. #
  296. #  and suppose, moreover, that we wish to find the position in l1 at
  297. #  which the list
  298. #
  299. #      [["hello"]," ",["there"]]
  300. #
  301. #  occurs.  If, say, we assign [["hello"]," ",["there"]] to the
  302. #  variable l2, then our l_find() expression will need to look like
  303. #
  304. #      l_find([l2],l1)
  305. #
  306. ############################################################################
  307. #
  308. #  Extending scanning to lists is really very difficult.  What I think
  309. #  (at least tonight) is that scanning should never have been
  310. #  restricted to strings.  It should have been designed to operate on
  311. #  all homogenous one-dimensional arrays (vectors, for you LISPers).
  312. #  You should be able, in other words, to scan vectors of ints, longs,
  313. #  characters - any data type that seems useful.  The only question in
  314. #  my mind is how to represent vectors as literals.  Extending strings
  315. #  to lists goes beyond the bounds of scanning per-se.  This library is
  316. #  therefore something of a stab in the dark.
  317. #
  318. ############################################################################
  319. #
  320. #  Links:  equiv, indices, numbers
  321. #
  322. ############################################################################
  323.  
  324. link equiv
  325. link indices
  326. link numbers
  327.  
  328. procedure file2lst(s)            #: create list from lines in file
  329.    local input, result
  330.  
  331.    input := open(s) | fail
  332.  
  333.    result := []
  334.  
  335.    every put(result, !input)
  336.  
  337.    close(input)
  338.  
  339.    return result
  340.  
  341. end
  342.  
  343. procedure imag2lst(seqimage)        #: convert limage() output to list
  344.    local seq, term
  345.  
  346.    seq := []
  347.  
  348.    seqimage[2:-1] ? {
  349.       while term := tab(upto(',') | 0) do {
  350.          term := numeric(term)            # special interest
  351.          put(seq, term)
  352.          move(1) | break
  353.          }
  354.       }
  355.  
  356.    return seq
  357.  
  358. end
  359.  
  360. global l_POS
  361. global l_SUBJ
  362.  
  363. record l_ScanEnvir(subject,pos)
  364.  
  365. procedure l_Bscan(e1)            #: begin list scanning
  366.  
  367.     #
  368.     # Prototype list scan initializer.  Based on code published in
  369.     # the _Icon Analyst_ 1:6 (June, 1991), p. 1-2.
  370.     #
  371.     local l_OuterEnvir
  372.     initial {
  373.     l_SUBJ := []
  374.     l_POS := 1
  375.     }
  376.  
  377.     #
  378.     # Save outer scanning environment.
  379.     #
  380.     l_OuterEnvir := l_ScanEnvir(l_SUBJ, l_POS)
  381.  
  382.     #
  383.     # Set current scanning environment to subject e1 (arg 1).  Pos
  384.     # defaults to 1.  Suspend the saved environment.  Later on, the
  385.     # l_Escan procedure will need this in case the scanning expres-
  386.     # sion as a whole sends a result back to the outer environment,
  387.     # and the outer environment changes l_SUBJ and l_POS.
  388.     #
  389.     l_SUBJ := e1
  390.     l_POS  := 1
  391.     suspend l_OuterEnvir
  392.  
  393.     #
  394.     # Restore the saved environment (plus any changes that might have
  395.     # been made to it as noted in the previous run of comments).
  396.     #
  397.     l_SUBJ := l_OuterEnvir.subject
  398.     l_POS := l_OuterEnvir.pos
  399.  
  400.     #
  401.     # Signal failure of the scanning expression (we're done producing
  402.     # results if we get to here).
  403.     #
  404.     fail
  405.  
  406. end
  407.  
  408.  
  409.  
  410. procedure l_Escan(l_OuterEnvir, e2)    #: end list scanning
  411.  
  412.     local l_InnerEnvir
  413.  
  414.     #
  415.     # Set the inner scanning environment to the values assigned to it
  416.     # by l_Bscan.  Remember that l_SUBJ and l_POS are global.  They
  417.     # don't need to be passed as parameters from l_Bscan.  What
  418.     # l_Bscan() needs to pass on is the l_OuterEnvir record,
  419.     # containing the values of l_SUBJ and l_POS before l_Bscan() was
  420.     # called.  l_Escan receives this "outer environment" as its first
  421.     # argument, l_OuterEnvir.
  422.     #
  423.     l_InnerEnvir := l_ScanEnvir(l_SUBJ, l_POS)
  424.  
  425.     #
  426.     # Whatever expression produced e2 has passed us a result.  Now we
  427.     # restore l_SUBJ and l_POS, and send that result back to the outer
  428.     # environment.
  429.     #
  430.     l_SUBJ := l_OuterEnvir.subject
  431.     l_POS := l_OuterEnvir.pos
  432.     suspend e2
  433.  
  434.     #
  435.     # Okay, we've resumed to (attempt to) produce another result.  Re-
  436.     # store the inner scanning environment (the one we're using in the
  437.     # current scanning expression).  Remember?  It was saved in l_Inner-
  438.     # Envir just above.
  439.     #
  440.     l_SUBJ := l_InnerEnvir.subject
  441.     l_POS := l_InnerEnvir.pos
  442.  
  443.     #
  444.     # Fail so that the second argument (the one that produced e2) gets
  445.     # resumed.  If it fails to produce another result, then the first
  446.     # argument is resumed, which is l_Bscan().  If l_Bscan is resumed, it
  447.     # will restore the outer environment and fail, causing the entire
  448.     # scanning expression to fail.
  449.     #
  450.     fail
  451.  
  452. end
  453.  
  454. procedure l_any(l1,l2,i,j)        #: any() for list scanning
  455.  
  456.     #
  457.     # Like any(c,s2,i,j) except that the string & cset arguments are
  458.     # replaced by list arguments.  l1 must be a list of one-element
  459.     # lists, while l2 can be any list (l_SUBJ by default).
  460.     #
  461.  
  462.     local x, sub_l
  463.  
  464.     /l1 & stop("l_any:  Null first argument!")
  465.     if type(l1) == "set" then l1 := sort(l1)
  466.  
  467.     /l2 := l_SUBJ
  468.     if \i then {
  469.     if i < 1 then
  470.         i := *l2 + (i+1)
  471.     }
  472.     else i := \l_POS | 1
  473.     if \j then {
  474.     if j < 1 then
  475.         j := *l2 + (j+1)
  476.     }
  477.     else j := *l_SUBJ+1
  478.  
  479.     (i+1) > j & i :=: j
  480.     every sub_l := !l1 do {
  481.     if not (type(sub_l) == "list", *sub_l = 1) then
  482.         stop("l_any:  Elements of l1 must be lists of length 1.")
  483.     # Let l_match check to see if i+1 is out of range.
  484.     if x := l_match(sub_l,l2,i,i+1) then
  485.         return x
  486.     }
  487.     
  488. end
  489.  
  490. procedure l_bal(l1,l2,l3,l,i,j)        #: bal() for list scanning
  491.  
  492.     local default_val, l2_count, l3_count, x, position
  493.  
  494.     /l1 & stop("l_bal:  Null first argument!")
  495.     if type(l1) == "set" then l1 := sort(l1)  # convert to a list
  496.     if type(l2) == "set" then l1 := sort(l2)
  497.     if type(l3) == "set" then l1 := sort(l3)
  498.  
  499.     if /l2 := l_SUBJ
  500.     then default_val := \l_POS | 1
  501.     else default_val := 1
  502.  
  503.     if \i then {
  504.     if i < 1 then
  505.         i := *l2 + (i+1)
  506.     }
  507.     else i := default_val
  508.  
  509.     if \j then {
  510.     if j < 1 then
  511.         j := *l2 + (j+1)
  512.     }
  513.     else j := *l_SUBJ+1
  514.  
  515.     l2_count := l3_count := 0
  516.  
  517.     every x := i to j-1 do {
  518.  
  519.     if l_any(l2, l, x, x+1) then {
  520.         l2_count +:= 1
  521.     }
  522.     if l_any(l3, l, x, x+1) then {
  523.         l3_count +:= 1
  524.     }
  525.     if l2_count = l3_count then {
  526.         if l_any(l1,l,x,x+1)
  527.         then suspend x
  528.     }
  529.     }
  530.  
  531. end
  532.  
  533. procedure l_comp(l1,l2)            # list comparison
  534.  
  535.     #
  536.     # List comparison routine basically taken from Griswold & Griswold
  537.     # (1st ed.), p. 174.
  538.     #
  539.  
  540.     local i
  541.  
  542.     /l1 | /l2 & stop("l_comp:  Null argument!")
  543.     l1 === l2 & (return l2)
  544.  
  545.     if type(l1) == type(l2) == "list" then {
  546.     *l1 ~= *l2 & fail
  547.     every i := 1 to *l1
  548.     do l_comp(l1[i],l2[i]) | fail
  549.     return l2
  550.     }
  551.  
  552. end
  553.  
  554. procedure l_find(l1,l2,i,j)        #: find() for list scanning
  555.  
  556.     #
  557.     # Like the builtin find(s1,s2,i,j), but for lists.
  558.     #
  559.  
  560.     local x, old_l_POS, default_val
  561.  
  562.     /l1 & stop("l_find:  Null first argument!")
  563.  
  564.     if /l2 := l_SUBJ
  565.     then default_val := \l_POS | 1
  566.     else default_val := 1
  567.  
  568.     if \i then {
  569.     if i < 1 then
  570.         i := *l2 + (i+1)
  571.     }
  572.     else i := default_val
  573.  
  574.     if \j then {
  575.     if j < 1 then
  576.         j := *l2 + (j+1)
  577.     }
  578.     else j := *l_SUBJ+1
  579.  
  580.     #
  581.     # See l_upto() below for a discussion of why things have to be done
  582.     # in this manner.
  583.     #
  584.     old_l_POS := l_POS
  585.  
  586.     suspend l_Escan(l_Bscan(l2[i:j]), {
  587.     l_tab(1 to *l_SUBJ) & {
  588.         if l_match(l1) then
  589.         old_l_POS + (l_POS-1)
  590.     }
  591.     })
  592.     
  593. end
  594.  
  595. procedure l_many(l1,l2,i,j)        #: many() for list scanning
  596.  
  597.     local x, old_l_POS, default_val
  598.  
  599.     /l1 & stop("l_many:  Null first argument!")
  600.     if type(l1) == "set" then l1 := sort(l1)
  601.  
  602.     if /l2 := l_SUBJ
  603.     then default_val := \l_POS | 1
  604.     else default_val := 1
  605.  
  606.     if \i then {
  607.     if i < 1 then
  608.         i := *l2 + (i+1)
  609.     }
  610.     else i := default_val
  611.  
  612.     if \j then {
  613.     if j < 1 then
  614.         j := *l2 + (j+1)
  615.     }
  616.     else j := *l_SUBJ+1
  617.  
  618.     #
  619.     # L_many(), like many(), is not a generator.  We can therefore
  620.     # save one final result in x, and then later return (rather than
  621.     # suspend) that result.
  622.     #
  623.     old_l_POS := l_POS
  624.     l_Escan(l_Bscan(l2[i:j]), {
  625.     while l_tab(l_any(l1))
  626.     x := old_l_POS + (l_POS-1)
  627.     })
  628.  
  629.     #
  630.     # Fails if there was no positional change (i.e. l_any() did not
  631.     # succeed even once).
  632.     #
  633.     return old_l_POS ~= x
  634.  
  635. end
  636.  
  637. procedure l_match(l1,l2,i,j)        #: match() for list scanning
  638.  
  639.     #
  640.     # Analogous to match(s1,s2,i,j), except that s1 and s2 are lists,
  641.     # and l_match returns the next position in l2 after that portion
  642.     # (if any) which is structurally identical to l1.  If a match is not
  643.     # found, l_match fails.
  644.     #
  645.     local default_val
  646.  
  647.     if /l1
  648.     then stop("l_match:  Null first argument!")
  649.     if type(l1) ~== "list"
  650.     then stop("l_match:  Call me with a list as the first arg.")
  651.  
  652.     if /l2 := l_SUBJ
  653.     then default_val := \l_POS | 1
  654.     else default_val := 1
  655.  
  656.     if \i then {
  657.     if i < 1 then
  658.         i := *l2 + (i+1)
  659.     }
  660.     else i := default_val
  661.     
  662.     if \j then {
  663.     if j < 1 then
  664.         j := *l2 + (j+1)
  665.     }
  666.     else j := *l_SUBJ+1
  667.  
  668.     i + *l1 > j & i :=: j
  669.     i + *l1 > j & fail
  670.     if l_comp(l1,l2[i+:*l1]) then
  671.     return i + *l1
  672.  
  673. end
  674.  
  675. procedure l_move(i)            #: move() for list scanning
  676.  
  677.     /i & stop("l_move:  Null argument.")
  678.     if /l_POS | /l_SUBJ then
  679.     stop("l_move:  Call l_Bscan() first.")
  680.  
  681.     #
  682.     # Sets l_POS to l_POS+i; suspends that portion of l_SUBJ extending
  683.     # from the old l_POS to the new one.  Resets l_POS if resumed,
  684.     # just the way matching procedures are supposed to.  Fails if l_POS
  685.     # plus i is larger than l_SUBJ+1 or if l_POS+i is less than 1.
  686.     #
  687.     suspend l_SUBJ[.l_POS:l_POS <- (0 < (*l_SUBJ+1 >= l_POS+i))]
  688.  
  689. end
  690.  
  691. procedure l_pos(i)            #: pos() for list scanning
  692.  
  693.     local x
  694.  
  695.     if /l_POS | /l_SUBJ
  696.     then stop("l_move:  Call l_Bscan() first.")
  697.  
  698.     if i <= 0
  699.     then x := 0 < (*l_SUBJ+1 >= (*l_SUBJ+1)+i) | fail
  700.     else x := 0 < (*l_SUBJ+1 >= i) | fail
  701.  
  702.     if x = l_POS
  703.     then return x
  704.     else fail
  705.  
  706. end
  707.  
  708. procedure l_tab(i)            #: tab() for list scanning
  709.  
  710.     /i & stop("l_tab:  Null argument.")
  711.     if /l_POS | /l_SUBJ then
  712.     stop("l_tab:  Call l_Bscan() first.")
  713.  
  714.     if i <= 0
  715.     then suspend l_SUBJ[.l_POS:l_POS <- 0 < (*l_SUBJ+1 >= (*l_SUBJ+1)+i)]
  716.     else suspend l_SUBJ[.l_POS:l_POS <- 0 < (*l_SUBJ+1 >= i)]
  717.  
  718. end
  719.  
  720. procedure l_upto(l1,l2,i,j)        #: upto() for list scanning
  721.  
  722.     #
  723.     # See l_any() above.  This procedure just moves through l2, calling
  724.     # l_any() for each member of l2[i:j].
  725.     #
  726.  
  727.     local old_l_POS, default_val
  728.  
  729.     /l1 & stop("l_upto:  Null first argument!")
  730.     if type(l1) == "set" then l1 := sort(l1)
  731.  
  732.     if /l2 := l_SUBJ
  733.     then default_val := \l_POS | 1
  734.     else default_val := 1
  735.  
  736.     if \i then {
  737.     if i < 1 then
  738.         i := *l2 + (i+1)
  739.     }
  740.     else i := default_val
  741.  
  742.     if \j then {
  743.     if j < 1 then
  744.         j := *l2 + (j+1)
  745.     }
  746.     else j := *l_SUBJ+1
  747.  
  748.     #
  749.     # Save the old pos, then try arb()ing through the list to see if we
  750.     # can do an l_any(l1) at any position.
  751.     #
  752.     old_l_POS := l_POS
  753.  
  754.     suspend l_Escan(l_Bscan(l2[i:j]), {
  755.     l_tab(1 to *l_SUBJ) & {
  756.         if l_any(l1) then
  757.         old_l_POS + (l_POS-1)
  758.     }
  759.     })
  760.  
  761.     #
  762.     # Note that it WILL NOT WORK if you say:
  763.     #
  764.     # l_Escan(l_Bscan(l2[i:j]), {
  765.     #     l_tab(1 to *l_SUBJ) & {
  766.     #         if l_any(l1) then
  767.     #             suspend old_l_POS + (l_POS-1)
  768.     #     }
  769.     # })
  770.     #
  771.     # If we are to suspend a result, l_Escan must suspend that result.
  772.     # Otherwise scanning environments are not saved and/or restored
  773.     # properly.
  774.     #
  775.     
  776. end
  777.  
  778. procedure lblock(L1, L2)
  779.    local L3, i, j
  780.  
  781.    if *L1 < *L2 then L1 := lextend(L1, *L2) | fail
  782.    else if *L2 < *L1 then L2 := lextend(L2, *L1) | fail
  783.  
  784.    L3 := []
  785.  
  786.     every i := 1 to *L1 do
  787.        every j := 1 to L2[i] do
  788.           put(L3, L2[i])
  789.  
  790.       return L3
  791.  
  792. end
  793.  
  794. procedure llayer(args[])        #: interleave lists with layering
  795.    local offsets, offset, seq, arg, lists, k
  796.  
  797.    lists := []
  798.  
  799.    every put(lists, lcompact(!args))
  800.  
  801.    offsets := []
  802.  
  803.    offset := 0
  804.  
  805.    every arg := !lists do {
  806.       put(offsets, offset)
  807.       offset +:= max ! arg
  808.       }
  809.  
  810.    seq := []
  811.  
  812.    repeat {
  813.       every k := 1 to *lists do {
  814.          arg := lists[k]
  815.          put(seq, get(arg) + offsets[k]) | break break
  816.          }
  817.       }
  818.  
  819.    return seq
  820.  
  821. end
  822.  
  823. procedure lcompact(seq)            #: compact sequence
  824.    local unique, target
  825.  
  826.    unique := set(seq)
  827.  
  828.    target := []
  829.  
  830.    every put(target, 1 to *unique)
  831.  
  832.    return lmap(seq, sort(unique), target)
  833.  
  834. end
  835.  
  836. procedure lclose(L)            #: close open palindrome
  837.  
  838.    if equiv(L, lreverse(L)) then return L
  839.    else {
  840.       L := copy(L)
  841.       put(L, L[1])
  842.       return L
  843.       }
  844.  
  845. end
  846.  
  847. procedure lcomb(L,i)            #: list combinations
  848.    local j
  849.  
  850.    if i < 1 then fail
  851.    suspend if i = 1 then [!L]
  852.       else [L[j := 1 to *L - i + 1]] ||| lcomb(L[j + 1:0],i - 1)
  853.  
  854. end
  855.  
  856. procedure ldecollate(indices, L)    #: list decollation
  857.    local result, i, x
  858.  
  859.    result := list(max ! indices)    # list of lists to return
  860.    every !result := []            # initially empty
  861.  
  862.    every x := !L do {
  863.       i := get(indices)    | fail
  864.       put(indices, i)
  865.       put(result[i], x)
  866.       }
  867.  
  868.    return result
  869.  
  870. end
  871.  
  872. procedure ldelete(L, spec)        #: delete specified list elements
  873.    local i, tmp
  874.  
  875.    tmp := indices(spec, *L) | fail        # bad specification
  876.  
  877.    while i := pull(tmp) do
  878.       L := L[1+:i - 1] ||| L[i + 1:0]
  879.  
  880.    return L
  881.  
  882. end
  883.  
  884. procedure ldupl(L1, L2)            #: list term duplication
  885.    local L3, i, j
  886.  
  887.    if integer(L2) then L2 := [L2]
  888.  
  889.    L3 := []
  890.  
  891.    every i := !L2 do
  892.       every j := !L1 do
  893.         every 1 to i do
  894.            put(L3, j)
  895.  
  896.    return L3
  897.  
  898. end
  899.  
  900. procedure lequiv(x,y)            #: compare lists for equivalence
  901.    local i
  902.  
  903.    if x === y then return y
  904.    if type(x) == type(y) == "list" then {
  905.       if *x ~= *y then fail
  906.       every i := 1 to *x do
  907.          if not lequiv(x[i],y[i]) then fail
  908.       return y
  909.      }
  910.  
  911. end
  912.  
  913. procedure levate(seq, m, n)        #: elevate values
  914.    local shafts, reseq, i, j, k
  915.  
  916.    shafts := list(m)
  917.  
  918.    every !shafts := []
  919.  
  920.    every i := 1 to m do
  921.       every put(shafts[i], i to n by m)
  922.  
  923.    reseq := []
  924.  
  925.    while j := get(seq) do {
  926.       i := j % m + 1
  927.       k := get(shafts[i])
  928.       put(reseq, k)
  929.       put(shafts[i], k)
  930.       }
  931.  
  932.    return reseq
  933.  
  934. end
  935.     
  936. procedure lextend(L, i)            #: list extension
  937.    local result
  938.  
  939.    if *L = 0 then fail
  940.  
  941.    result := copy(L)
  942.  
  943.    until *result >= i do
  944.       result |||:= L
  945.  
  946.    result := result[1+:i]
  947.  
  948.    return result
  949.  
  950. end
  951.  
  952. procedure lfliph(L)            #: list horizontal flip (reversal)
  953.  
  954.    lfliph := lreverse
  955.  
  956.    return lfliph(L)
  957.  
  958. end
  959.  
  960. procedure lflipv(L)            #: list vertical flip
  961.    local L1, m, i
  962.  
  963.    m := max ! L
  964.  
  965.    L1 := []
  966.  
  967.    every i := !L do
  968.       put(L1, residue(-i + 1, m, 1))
  969.  
  970.    return L1
  971.  
  972. end
  973.  
  974. procedure limage(L)            #: list image
  975.    local result
  976.  
  977.    if type(L) ~== "list" then stop("*** invalid type to limage()")
  978.  
  979.    result := ""
  980.  
  981.    every result ||:= image(!L) || ","
  982.  
  983.    return ("[" || result[1:-1] || "]") | "[]"
  984.  
  985. end
  986.  
  987. procedure lcollate(args[])        #: generalized list collation
  988.    local seq, arg, lists, k
  989.  
  990.    lists := []
  991.  
  992.    every put(lists, copy(!args))
  993.  
  994.    seq := []
  995.  
  996.    repeat {
  997.       every k := 1 to *lists do {
  998.          arg := lists[k]
  999.          put(seq, get(arg)) | break break
  1000.          }
  1001.       }
  1002.  
  1003.    return seq
  1004.  
  1005. end
  1006.  
  1007. procedure lconstant(L)            #: test list for all terms equal
  1008.  
  1009.    if *set(L) = 1 then return L[1]
  1010.    else fail
  1011.  
  1012. end
  1013.  
  1014. procedure lindex(lst, x)        #: generate indices for items matching x
  1015.    local i
  1016.  
  1017.    every i := 1 to *lst do
  1018.       if lst[i] === x then suspend i
  1019.  
  1020. end
  1021.  
  1022. procedure linterl(L1, L2)        #: list interleaving
  1023.    local L3, i
  1024.  
  1025.    if *L1 < *L2 then L1 := lextend(L1, *L2) | fail
  1026.    else if *L2 < *L1 then L2 := lextend(L2, *L1) | fail
  1027.  
  1028.    L3 := []
  1029.  
  1030.    every i := 1 to *L1 do
  1031.       put(L3, L1[i], L2[i])
  1032.  
  1033.    return L3
  1034.  
  1035. end
  1036.  
  1037. procedure llpad(L, i, x)        #: list padding at left
  1038.  
  1039.    L := copy(L)
  1040.  
  1041.    while *L < i do push(L, x)
  1042.  
  1043.    return L
  1044.  
  1045. end
  1046.  
  1047. procedure lrunup(L1, L2, L3)        #: list run up
  1048.    local L4
  1049.  
  1050.    /L3 := [1]        # could be /L3 := 1 ...
  1051.  
  1052.    L4 := []
  1053.  
  1054.    every put(L4, !L1 to !L2 by !L3)
  1055.  
  1056.    return L4
  1057.  
  1058. end
  1059.  
  1060. procedure lrundown(L1, L2, L3)        #: list run up
  1061.    local L4
  1062.  
  1063.    /L3 := [1]        # could be /L3 := 1 ...
  1064.  
  1065.    L4 := []
  1066.  
  1067.    every put(L4, !L1 to !L2 by -!L3)
  1068.  
  1069.    return L4
  1070.  
  1071. end
  1072.  
  1073. procedure lltrim(L, S)            #: list left trimming
  1074.  
  1075.    L := copy(L)
  1076.  
  1077.    while member(S, L[1]) do
  1078.       get(L)
  1079.  
  1080.     return L
  1081.  
  1082. end
  1083.  
  1084. procedure lmap(L1,L2,L3)        #: list mapping
  1085.    static lmem2, lmem3, lmaptbl, tdefault
  1086.    local i, a
  1087.  
  1088.    initial tdefault := []
  1089.  
  1090.    if type(a := L1 | L2 | L3) ~== "list" then runerr(108,a)
  1091.    if *L2 ~= *L3 then runerr(208,L2)
  1092.  
  1093.    L1 := copy(L1)
  1094.  
  1095.    if not(lmem2 === L2 & lmem3 === L3) then {    # if an argument is new, rebuild
  1096.       lmem2 := L2                # save for future reference
  1097.       lmem3 := L3
  1098.       lmaptbl := table(tdefault)        # new mapping table
  1099.       every i := 1 to *L2 do            # build the map
  1100.          lmaptbl[L2[i]] := L3[i]
  1101.       }
  1102.    every i := 1 to *L1 do            # map the values
  1103.       L1[i] := (tdefault ~=== lmaptbl[L1[i]])
  1104.    return L1
  1105.  
  1106. end
  1107.  
  1108. procedure lresidue(L, m, i)        #: list residue
  1109.    local result
  1110.  
  1111.    /i := 0
  1112.  
  1113.    result := []
  1114.  
  1115.    every put(result, residue(!L, m, i))
  1116.  
  1117.    return result
  1118.  
  1119. end
  1120.  
  1121. procedure lpalin(L, x)            #: list palindrome
  1122.  
  1123.    L |||:= lreverse(L)
  1124.  
  1125.    if /x then pull(L)
  1126.  
  1127.    return L
  1128.  
  1129. end
  1130.  
  1131. procedure lpermute(L)            #: list permutations
  1132.    local i
  1133.  
  1134.    if *L = 0 then return []
  1135.    suspend [L[i := 1 to *L]] ||| lpermute(L[1:i] ||| L[i+1:0])
  1136.  
  1137. end
  1138.  
  1139. procedure lreflect(L, i)        #: list reflection
  1140.    local L1
  1141.  
  1142.    /i := 0
  1143.  
  1144.    if i > 3 then stop("*** invalid argument to lreflect()")
  1145.  
  1146.    if i < 3 then L1 := copy(L)
  1147.  
  1148.    return L ||| lreverse(
  1149.       case i of {
  1150.          0:   {get(L1); pull(L1); L1}
  1151.          1:   {get(L1); L1}
  1152.          2:   {pull(L1); L1}
  1153.          3:   L
  1154.          }
  1155.       )
  1156.  
  1157. end
  1158.  
  1159. procedure lremvals(L, x[])        #: remove values from list
  1160.    local result, y
  1161.  
  1162.    result := []
  1163.  
  1164.    every y := !L do
  1165.       if y === !x then next
  1166.       else put(result, y)
  1167.  
  1168.    return result
  1169.  
  1170. end
  1171.  
  1172. procedure lrepl(L, i)            #: list replication
  1173.    local j, k
  1174.  
  1175.    i := (0 < integer(i)) | stop("*** invalid replication factor in lrepl()")
  1176.  
  1177.    L := copy(L)
  1178.  
  1179.    j := *L
  1180.  
  1181.    every 1 to i - 1 do
  1182.       every k := 1 to j do
  1183.          put(L, L[k])
  1184.  
  1185.    return L
  1186.  
  1187. end
  1188.  
  1189. procedure lreverse(L)            #: list reverse
  1190.    local i
  1191.  
  1192.    L := copy(L)
  1193.  
  1194.    every i := 1 to *L / 2 do
  1195.       L[i] :=: L[-i]
  1196.  
  1197.    return L
  1198.  
  1199. end
  1200.  
  1201. procedure lrotate(L, i)            #: list rotation
  1202.  
  1203.    /i := 1
  1204.  
  1205.    L := copy(L)
  1206.  
  1207.    if i > 0 then
  1208.       every 1 to i do
  1209.          put(L, get(L))
  1210.    else
  1211.       every 1 to -i do
  1212.          push(L, pull(L))
  1213.  
  1214.    return L
  1215.  
  1216. end
  1217.  
  1218. procedure lrpad(L, i, x)        #: list right padding
  1219.  
  1220.    L := copy(L)
  1221.  
  1222.    while *L < i do put(L, x)
  1223.  
  1224.    return L
  1225.  
  1226. end
  1227.  
  1228. procedure lrtrim(L, S)            #: list right trimming
  1229.  
  1230.    L := copy(L)
  1231.  
  1232.    while member(S, L[-1]) do
  1233.       pull(L)
  1234.  
  1235.     return L
  1236.  
  1237. end
  1238.  
  1239. procedure lshift(L, i)            #: shift list terms
  1240.  
  1241.    L := copy(L)
  1242.  
  1243.    every !L +:= i
  1244.  
  1245.    return L
  1246.  
  1247. end
  1248.  
  1249. procedure lswap(L)            #: list element swap
  1250.    local i
  1251.  
  1252.    L := copy(L)
  1253.  
  1254.    every i := 1 to *L by 2 do
  1255.       L[i] :=: L[i + 1]
  1256.  
  1257.    return L
  1258.  
  1259. end
  1260.  
  1261. procedure lunique(L)            #: keep only unique list elements
  1262.    local result, culls, x
  1263.  
  1264.    result := []
  1265.    culls := set(L)
  1266.  
  1267.    every x := !L do
  1268.       if member(culls, x) then {
  1269.          delete(culls, x)
  1270.          put(result, x)
  1271.          }
  1272.  
  1273.    return result
  1274.  
  1275. end
  1276.  
  1277. procedure lmaxlen(L, p)            #: size of largest list entry
  1278.    local i
  1279.  
  1280.    /p := proc("*", 1)
  1281.  
  1282.    i := p(L[1]) | fail
  1283.  
  1284.    every i <:= p(!L)
  1285.  
  1286.    return i
  1287.  
  1288. end
  1289.  
  1290. procedure lminlen(L, p)            #: size of smallest list entry
  1291.    local i
  1292.  
  1293.    /p := proc("*", 1)
  1294.  
  1295.    i := p(L[1]) | fail
  1296.  
  1297.    every i >:= p(!L)
  1298.  
  1299.    return i
  1300.  
  1301. end
  1302.  
  1303. procedure sortkeys(L)            #: extract keys from sorted list
  1304.    local result
  1305.  
  1306.    result := []
  1307.  
  1308.    every put(result, L[1 to *L by 2])
  1309.  
  1310.    return result
  1311.  
  1312. end
  1313.  
  1314. procedure sortvalues(L)            #: extract values from sorted list
  1315.    local result
  1316.  
  1317.    result := []
  1318.  
  1319.    every put(result, L[2 to *L by 2])
  1320.  
  1321.    return result
  1322.  
  1323. end
  1324.  
  1325. procedure str2lst(s, i)            #: list from string
  1326.    local L
  1327.  
  1328.    /i := 1
  1329.  
  1330.    L := []
  1331.  
  1332.    s ? {
  1333.       while put(L, move(i))
  1334.       if not pos(0) then put(L, tab(0))
  1335.       }
  1336.  
  1337.    return L
  1338.  
  1339. end
  1340.