path: root/ipl/procs/lists.icn

############################################################################
#
#	File:     lists.icn
#
#	Subject:  Procedures to manipulate lists
#
#	Author:   Ralph E. Griswold
#
#	Date:     March 5, 2003
#
############################################################################
#
#   This file is in the public domain.
#
############################################################################
#
#	Contributor:  Richard L. Goerwitz
#
############################################################################
#
#	file2lst(s)	create list from lines in file
#
#	imag2lst(s)	convert limage() output to list
#
#	l_Bscan(e1)	begin list scanning
#
#	l_Escan(l_OuterEnvir, e2)
#			end list scanning
#
#	l_any(l1,l2,i,j)
#			any() for list scanning
#
#	l_bal(l1,l2,l3,l,i,j
#			bal() for list scanning
#
#	l_find(l1,l2,i,j)
#			find() for list scanning
#
#	l_many(l1,l2,i,j)
#			many() for list scanning
#
#	l_match(l1,l2,i,j)
#			match() for list scanning
#
#	l_move(i)	move() for list scanning
#
#	l_pos(i)	pos() for list scanning
#
#	l_tab(i)	tab() for list scanning
#
#	l_upto(l1,l2,i,j)
#			upto() for list scanning
#
#	lclose(L)	close open palindrome
#
#	lcomb(L,i)	list combinations
#
#	lcompact(L)	compact list, mapping out missing values
#
#	ldecollate(I, L)
#			list decollation
#
#	ldelete(L, spec)
#			list deletion
#
#	ldupl(L, i)	list term duplication
#
#	lequiv(L1, L2)	list equivalence
#
#	levate(L, m, n)	list elevation
#
#	lextend(L, i)	list extension
#
#	lfliph(L)	list horizontal flip (reversal)
#
#	lflipv(L)	list vertical flip
#
#	limage(L)	unadorned list image
#
#	lindex(L, x)
#			generate indices of L whose values are x
#
#	lcollate(L1, L2, ...)
#			list collation; like linterl() except stops on
#			short list
#
#	lconstant(L)	succeeds and returns element if all are the same
#
#	linterl(L1, L2)	list interleaving
#
#	llayer(L1, L2, ...)
#			layer and interleave L1, L2, ... 
#
#	llpad(L, i, x)	list padding at left
#
#	lltrim(L, S)	list left trimming
#
#	lmap(L1,L2,L3)	list mapping
#
#	lpalin(L, x)	list palindrome
#
#	lpermute(L)	list permutations
#
#	lreflect(L, i)  returns L concatenated with its reversal to produce
#			palindrome; the values of i determine "end
#			conditions" for the reversal:
#
#				0	omit first and last elements; default
#				1	omit first element
#				2	omit last element
#				3	don't omit element
#
#	lremvals(L, x1, x2, ...)
#			remove values from list
#
#	lrepl(L, i)	list replication
#
#	lresidue(L, m, i)
#			list residue
#
#	lreverse(L)	list reverse
#
#	lrotate(L, i)	list rotation
#
#	lrpad(L, i, x)	list right padding
#
#	lrundown(L1, L2, L3)
#			list run down
#
#	lrunup(L1, L2, L3)
#			list run up
#
#	lrtrim(L, S)	list right trimming
#
#	lshift(L, i)	shift list terms
#
#	lst2str(L)	string from concatenated values in L
#
#	lswap(L)	list element swap
#
#	lunique(L)	keep only unique list elements
#
#	lmaxlen(L, p)	returns the size of the largest value in L.
#			If p is given, it is applied to each string as
#			as a "length" procedure.  The default for p is
#			proc("*", 1).
#
#	lminlen(L, p)	returns the size of the smallest value in L.
#			If p is given, it is applied to each string as
#			as a "length" procedure.  The default for p is
#			proc("*", 1).
#
#	sortkeys(L)	returns list of keys from L, where L is the
#			result of sorting a table with option 3 or 4.
#
#	sortvalues(L)	return list of values from L, where L is the
#			result of sorting a table with option 3 or 4.
#
#	str2lst(s, i)	creates list with i-character lines from s.  The
#			default for i is 1.
#
############################################################################
#
#		About List Mapping
#
#  The procedure lmap(L1,L2,L3) maps elements of L1 according to L2
#  and L3.  This procedure is the analog for lists of the built-in
#  string-mapping function map(s1,s2,s3). Elements in L1 that are
#  the same as elements in L2 are mapped into the corresponding ele-
#  ments of L3. For example, given the lists
#  
#     L1 := [1,2,3,4]
#     L2 := [4,3,2,1]
#     L3 := ["a","b","c","d"]
#  
#  then
#  
#     lmap(L1,L2,L3)
#  
#  produces a new list
#  
#     ["d","c","b","a"]
#  
#     Lists that are mapped can have any kinds of elements. The
#  operation
#  
#     x === y
#  
#  is used to determine if elements x and y are equivalent.
#  
#     All cases in lmap are handled as they are in map, except that
#  no defaults are provided for omitted arguments. As with map, lmap
#  can be used for transposition as well as substitution.
#  
#  Warning:
#
#     If lmap is called with the same lists L2 and L3 as in
#  the immediately preceding call, the same mapping is performed,
#  even if the values in L2 and L3 have been changed. This improves
#  performance, but it may cause unexpected effects.
#  
#     This ``caching'' of the mapping table based on L2 and L3
#  can be easily removed to avoid this potential problem.
#  
############################################################################
#
#	About List Scanning by Richard L. Goerwitz
#
#  PURPOSE: String scanning is terrific, but often I am forced to
#  tokenize and work with lists.  So as to make operations on these
#  lists as close to corresponding string operations as possible, I've
#  implemented a series of list analogues to any(), bal(), find(),
#  many(), match(), move(), pos(), tab(), and upto().  Their names are
#  just like corresponding string functions, except with a prepended
#  "l_" (e.g. l_any()).  Functionally, the list routines parallel the
#  string ones closely, except that in place of strings, l_find and
#  l_match accept lists as their first argument.  L_any(), l_many(),
#  and l_upto() all take either sets of lists or lists of lists (e.g.
#  l_tab(l_upto([["a"],["b"],["j","u","n","k"]])).  Note that l_bal(),
#  unlike the builtin bal(), has no defaults for the first four
#  arguments.  This just seemed appropriate, given that no precise
#  list analogue to &cset, etc. occurs.
#
#  The default subject for list scans (analogous to &subject) is
#  l_SUBJ.  The equivalent of &pos is l_POS.  Naturally, these
#  variables are both global.  They are used pretty much like &subject
#  and &pos, except that they are null until a list scanning
#  expression has been encountered containing a call to l_Bscan() (on
#  which, see below).
#
#  Note that environments cannot be maintained quite as elegantly as
#  they can be for the builtin string-scanning functions.  One must
#  use instead a set of nested procedure calls, as explained in the
#  _Icon Analyst_ 1:6 (June, 1991), p. 1-2.  In particular, one cannot
#  suspend, return, or otherwise break out of the nested procedure
#  calls.  They can only be exited via failure.  The names of these
#  procedures, at least in this implementation, are l_Escan and
#  l_Bscan.  Here is one example of how they might be invoked:
#
#      suspend l_Escan(l_Bscan(some_list_or_other), {
#          l_tab(10 to *l_SUBJ) & {
#              if l_any(l1) | l_match(l2) then
#                  old_l_POS + (l_POS-1)
#          }
#      })
#
#  Note that you cannot do this:
#
#      l_Escan(l_Bscan(some_list_or_other), {
#          l_tab(10 to *l_SUBJ) & {
#              if l_any(l1) | l_match(l2) then
#                  suspend old_l_POS + (l_POS-1)
#          }
#      })
#
#  Remember, it's no fair to use suspend within the list scanning
#  expression.  l_Escan must do all the suspending.  It is perfectly OK,
#  though, to nest well-behaved list scanning expressions.  And they can
#  be reliably used to generate a series of results as well.
#
############################################################################
#
#  Here's another simple example of how one might invoke the l_scan
#  routines:
#
#  procedure main()
#
#      l := ["h","e","l","l","o"," ","t","t","t","h","e","r","e"]
#
#      l_Escan(l_Bscan(l), {
#          hello_list := l_tab(l_match(["h","e","l","l","o"]))
#          every writes(!hello_list)
#          write()
#
#          # Note the nested list-scanning expressions.
#	   l_Escan(l_Bscan(l_tab(0)), {
#	       l_tab(l_many([[" "],["t"]]) - 1)
#              every writes(!l_tab(0))
#	       write()
#          })
#      })
#  
#  end
#
#  The above program simply writes "hello" and "there" on successive
#  lines to the standard output.
#
############################################################################
#
#  PITFALLS: In general, note that we are comparing lists here instead
#  of strings, so l_find("h", l), for instance, will yield an error
#  message (use l_find(["h"], l) instead).  The point at which I
#  expect this nuance will be most confusing will be in cases where
#  one is looking for lists within lists.  Suppose we have a list,
#
#      l1 := ["junk",[["hello"]," ",["there"]],"!","m","o","r","e","junk"]
#
#  and suppose, moreover, that we wish to find the position in l1 at
#  which the list
#
#      [["hello"]," ",["there"]]
#
#  occurs.  If, say, we assign [["hello"]," ",["there"]] to the
#  variable l2, then our l_find() expression will need to look like
#
#      l_find([l2],l1)
#
############################################################################
#
#  Extending scanning to lists is really very difficult.  What I think
#  (at least tonight) is that scanning should never have been
#  restricted to strings.  It should have been designed to operate on
#  all homogenous one-dimensional arrays (vectors, for you LISPers).
#  You should be able, in other words, to scan vectors of ints, longs,
#  characters - any data type that seems useful.  The only question in
#  my mind is how to represent vectors as literals.  Extending strings
#  to lists goes beyond the bounds of scanning per-se.  This library is
#  therefore something of a stab in the dark.
#
############################################################################
#
#  Links:  equiv, indices, numbers
#
############################################################################

link equiv
link indices
link numbers

procedure file2lst(s)			#: create list from lines in file
   local input, result

   input := open(s) | fail

   result := []

   every put(result, !input)

   close(input)

   return result

end

procedure imag2lst(seqimage)		#: convert limage() output to list
   local seq, term

   seq := []

   seqimage[2:-1] ? {
      if pos(0) then return seq
      tab(many(' '))
      while term := tab(bal(',', '[', ']') | 0) do {
         term := numeric(term)			# special interest
         put(seq, term)
         move(1) | break
         tab(many(' '))
         }
      }

   return seq

end

global l_POS
global l_SUBJ

record l_ScanEnvir(subject,pos)

procedure l_Bscan(e1)			#: begin list scanning

    #
    # Prototype list scan initializer.  Based on code published in
    # the _Icon Analyst_ 1:6 (June, 1991), p. 1-2.
    #
    local l_OuterEnvir
    initial {
	l_SUBJ := []
	l_POS := 1
    }

    #
    # Save outer scanning environment.
    #
    l_OuterEnvir := l_ScanEnvir(l_SUBJ, l_POS)

    #
    # Set current scanning environment to subject e1 (arg 1).  Pos
    # defaults to 1.  Suspend the saved environment.  Later on, the
    # l_Escan procedure will need this in case the scanning expres-
    # sion as a whole sends a result back to the outer environment,
    # and the outer environment changes l_SUBJ and l_POS.
    #
    l_SUBJ := e1
    l_POS  := 1
    suspend l_OuterEnvir

    #
    # Restore the saved environment (plus any changes that might have
    # been made to it as noted in the previous run of comments).
    #
    l_SUBJ := l_OuterEnvir.subject
    l_POS := l_OuterEnvir.pos

    #
    # Signal failure of the scanning expression (we're done producing
    # results if we get to here).
    #
    fail

end



procedure l_Escan(l_OuterEnvir, e2)	#: end list scanning

    local l_InnerEnvir

    #
    # Set the inner scanning environment to the values assigned to it
    # by l_Bscan.  Remember that l_SUBJ and l_POS are global.  They
    # don't need to be passed as parameters from l_Bscan.  What
    # l_Bscan() needs to pass on is the l_OuterEnvir record,
    # containing the values of l_SUBJ and l_POS before l_Bscan() was
    # called.  l_Escan receives this "outer environment" as its first
    # argument, l_OuterEnvir.
    #
    l_InnerEnvir := l_ScanEnvir(l_SUBJ, l_POS)

    #
    # Whatever expression produced e2 has passed us a result.  Now we
    # restore l_SUBJ and l_POS, and send that result back to the outer
    # environment.
    #
    l_SUBJ := l_OuterEnvir.subject
    l_POS := l_OuterEnvir.pos
    suspend e2

    #
    # Okay, we've resumed to (attempt to) produce another result.  Re-
    # store the inner scanning environment (the one we're using in the
    # current scanning expression).  Remember?  It was saved in l_Inner-
    # Envir just above.
    #
    l_SUBJ := l_InnerEnvir.subject
    l_POS := l_InnerEnvir.pos

    #
    # Fail so that the second argument (the one that produced e2) gets
    # resumed.  If it fails to produce another result, then the first
    # argument is resumed, which is l_Bscan().  If l_Bscan is resumed, it
    # will restore the outer environment and fail, causing the entire
    # scanning expression to fail.
    #
    fail

end

procedure l_any(l1,l2,i,j)		#: any() for list scanning

    #
    # Like any(c,s2,i,j) except that the string & cset arguments are
    # replaced by list arguments.  l1 must be a list of one-element
    # lists, while l2 can be any list (l_SUBJ by default).
    #

    local x, sub_l

    /l1 & stop("l_any:  Null first argument!")
    if type(l1) == "set" then l1 := sort(l1)

    /l2 := l_SUBJ
    if \i then {
	if i < 1 then
	    i := *l2 + (i+1)
    }
    else i := \l_POS | 1
    if \j then {
	if j < 1 then
	    j := *l2 + (j+1)
    }
    else j := *l_SUBJ+1

    (i+1) > j & i :=: j
    every sub_l := !l1 do {
	if not (type(sub_l) == "list", *sub_l = 1) then
	    stop("l_any:  Elements of l1 must be lists of length 1.")
	# Let l_match check to see if i+1 is out of range.
	if x := l_match(sub_l,l2,i,i+1) then
	    return x
    }
    
end

procedure l_bal(l1,l2,l3,l,i,j)		#: bal() for list scanning

    local default_val, l2_count, l3_count, x, position

    /l1 & stop("l_bal:  Null first argument!")
    if type(l1) == "set" then l1 := sort(l1)  # convert to a list
    if type(l2) == "set" then l1 := sort(l2)
    if type(l3) == "set" then l1 := sort(l3)

    if /l2 := l_SUBJ
    then default_val := \l_POS | 1
    else default_val := 1

    if \i then {
	if i < 1 then
	    i := *l2 + (i+1)
    }
    else i := default_val

    if \j then {
	if j < 1 then
	    j := *l2 + (j+1)
    }
    else j := *l_SUBJ+1

    l2_count := l3_count := 0

    every x := i to j-1 do {

	if l_any(l2, l, x, x+1) then {
	    l2_count +:= 1
	}
	if l_any(l3, l, x, x+1) then {
	    l3_count +:= 1
	}
	if l2_count = l3_count then {
	    if l_any(l1,l,x,x+1)
	    then suspend x
	}
    }

end

procedure l_comp(l1,l2)			# list comparison

    #
    # List comparison routine basically taken from Griswold & Griswold
    # (1st ed.), p. 174.
    #

    local i

    /l1 | /l2 & stop("l_comp:  Null argument!")
    l1 === l2 & (return l2)

    if type(l1) == type(l2) == "list" then {
	*l1 ~= *l2 & fail
	every i := 1 to *l1
	do l_comp(l1[i],l2[i]) | fail
	return l2
    }

end

procedure l_find(l1,l2,i,j)		#: find() for list scanning

    #
    # Like the builtin find(s1,s2,i,j), but for lists.
    #

    local x, old_l_POS, default_val

    /l1 & stop("l_find:  Null first argument!")

    if /l2 := l_SUBJ
    then default_val := \l_POS | 1
    else default_val := 1

    if \i then {
	if i < 1 then
	    i := *l2 + (i+1)
    }
    else i := default_val

    if \j then {
	if j < 1 then
	    j := *l2 + (j+1)
    }
    else j := *l_SUBJ+1

    #
    # See l_upto() below for a discussion of why things have to be done
    # in this manner.
    #
    old_l_POS := l_POS

    suspend l_Escan(l_Bscan(l2[i:j]), {
	l_tab(1 to *l_SUBJ) & {
	    if l_match(l1) then
		old_l_POS + (l_POS-1)
	}
    })
    
end

procedure l_many(l1,l2,i,j)		#: many() for list scanning

    local x, old_l_POS, default_val

    /l1 & stop("l_many:  Null first argument!")
    if type(l1) == "set" then l1 := sort(l1)

    if /l2 := l_SUBJ
    then default_val := \l_POS | 1
    else default_val := 1

    if \i then {
	if i < 1 then
	    i := *l2 + (i+1)
    }
    else i := default_val

    if \j then {
	if j < 1 then
	    j := *l2 + (j+1)
    }
    else j := *l_SUBJ+1

    #
    # L_many(), like many(), is not a generator.  We can therefore
    # save one final result in x, and then later return (rather than
    # suspend) that result.
    #
    old_l_POS := l_POS
    l_Escan(l_Bscan(l2[i:j]), {
	while l_tab(l_any(l1))
	x := old_l_POS + (l_POS-1)
    })

    #
    # Fails if there was no positional change (i.e. l_any() did not
    # succeed even once).
    #
    return old_l_POS ~= x

end

procedure l_match(l1,l2,i,j)		#: match() for list scanning

    #
    # Analogous to match(s1,s2,i,j), except that s1 and s2 are lists,
    # and l_match returns the next position in l2 after that portion
    # (if any) which is structurally identical to l1.  If a match is not
    # found, l_match fails.
    #
    local default_val

    if /l1
    then stop("l_match:  Null first argument!")
    if type(l1) ~== "list"
    then stop("l_match:  Call me with a list as the first arg.")

    if /l2 := l_SUBJ
    then default_val := \l_POS | 1
    else default_val := 1

    if \i then {
	if i < 1 then
	    i := *l2 + (i+1)
    }
    else i := default_val
    
    if \j then {
	if j < 1 then
	    j := *l2 + (j+1)
    }
    else j := *l_SUBJ+1

    i + *l1 > j & i :=: j
    i + *l1 > j & fail
    if l_comp(l1,l2[i+:*l1]) then
	return i + *l1

end

procedure l_move(i)			#: move() for list scanning

    /i & stop("l_move:  Null argument.")
    if /l_POS | /l_SUBJ then
	stop("l_move:  Call l_Bscan() first.")

    #
    # Sets l_POS to l_POS+i; suspends that portion of l_SUBJ extending
    # from the old l_POS to the new one.  Resets l_POS if resumed,
    # just the way matching procedures are supposed to.  Fails if l_POS
    # plus i is larger than l_SUBJ+1 or if l_POS+i is less than 1.
    #
    suspend l_SUBJ[.l_POS:l_POS <- (0 < (*l_SUBJ+1 >= l_POS+i))]

end

procedure l_pos(i)			#: pos() for list scanning

    local x

    if /l_POS | /l_SUBJ
    then stop("l_move:  Call l_Bscan() first.")

    if i <= 0
    then x := 0 < (*l_SUBJ+1 >= (*l_SUBJ+1)+i) | fail
    else x := 0 < (*l_SUBJ+1 >= i) | fail

    if x = l_POS
    then return x
    else fail

end

procedure l_tab(i)			#: tab() for list scanning

    /i & stop("l_tab:  Null argument.")
    if /l_POS | /l_SUBJ then
	stop("l_tab:  Call l_Bscan() first.")

    if i <= 0
    then suspend l_SUBJ[.l_POS:l_POS <- 0 < (*l_SUBJ+1 >= (*l_SUBJ+1)+i)]
    else suspend l_SUBJ[.l_POS:l_POS <- 0 < (*l_SUBJ+1 >= i)]

end

procedure l_upto(l1,l2,i,j)		#: upto() for list scanning

    #
    # See l_any() above.  This procedure just moves through l2, calling
    # l_any() for each member of l2[i:j].
    #

    local old_l_POS, default_val

    /l1 & stop("l_upto:  Null first argument!")
    if type(l1) == "set" then l1 := sort(l1)

    if /l2 := l_SUBJ
    then default_val := \l_POS | 1
    else default_val := 1

    if \i then {
	if i < 1 then
	    i := *l2 + (i+1)
    }
    else i := default_val

    if \j then {
	if j < 1 then
	    j := *l2 + (j+1)
    }
    else j := *l_SUBJ+1

    #
    # Save the old pos, then try arb()ing through the list to see if we
    # can do an l_any(l1) at any position.
    #
    old_l_POS := l_POS

    suspend l_Escan(l_Bscan(l2[i:j]), {
	l_tab(1 to *l_SUBJ) & {
	    if l_any(l1) then
		old_l_POS + (l_POS-1)
	}
    })

    #
    # Note that it WILL NOT WORK if you say:
    #
    # l_Escan(l_Bscan(l2[i:j]), {
    #     l_tab(1 to *l_SUBJ) & {
    #         if l_any(l1) then
    #             suspend old_l_POS + (l_POS-1)
    #     }
    # })
    #
    # If we are to suspend a result, l_Escan must suspend that result.
    # Otherwise scanning environments are not saved and/or restored
    # properly.
    #
    
end

procedure lblock(L1, L2)
   local L3, i, j

   if *L1 < *L2 then L1 := lextend(L1, *L2) | fail
   else if *L2 < *L1 then L2 := lextend(L2, *L1) | fail

   L3 := []

    every i := 1 to *L1 do
       every j := 1 to L2[i] do
          put(L3, L2[i])

      return L3

end

procedure llayer(args[])		#: interleave lists with layering
   local offsets, offset, seq, arg, lists, k

   lists := []

   every put(lists, lcompact(!args))

   offsets := []

   offset := 0

   every arg := !lists do {
      put(offsets, offset)
      offset +:= max ! arg
      }

   seq := []

   repeat {
      every k := 1 to *lists do {
         arg := lists[k]
         put(seq, get(arg) + offsets[k]) | break break
         }
      }

   return seq

end

procedure lcompact(seq)			#: compact sequence
   local unique, target

   unique := set(seq)

   target := []

   every put(target, 1 to *unique)

   return lmap(seq, sort(unique), target)

end

procedure lclose(L)			#: close open palindrome

   if equiv(L, lreverse(L)) then return L
   else {
      L := copy(L)
      put(L, L[1])
      return L
      }

end

procedure lcomb(L,i)			#: list combinations
   local j

   if i < 1 then fail
   suspend if i = 1 then [!L]
      else [L[j := 1 to *L - i + 1]] ||| lcomb(L[j + 1:0],i - 1)

end

procedure ldecollate(indices, L)	#: list decollation
   local result, i, x

   result := list(max ! indices)	# list of lists to return
   every !result := []			# initially empty

   every x := !L do {
      i := get(indices)	| fail
      put(indices, i)
      put(result[i], x)
      }

   return result

end

procedure ldelete(L, spec)		#: delete specified list elements
   local i, tmp

   tmp := indices(spec, *L) | fail		# bad specification

   while i := pull(tmp) do
      L := L[1+:i - 1] ||| L[i + 1:0]

   return L

end

procedure ldupl(L1, L2)			#: list term duplication
   local L3, i, j

   if integer(L2) then L2 := [L2]

   L3 := []

   every i := !L2 do
      every j := !L1 do
        every 1 to i do
           put(L3, j)

   return L3

end

procedure lequiv(x,y)			#: compare lists for equivalence
   local i

   if x === y then return y
   if type(x) == type(y) == "list" then {
      if *x ~= *y then fail
      every i := 1 to *x do
         if not lequiv(x[i],y[i]) then fail
      return y
     }

end

procedure levate(seq, m, n)		#: elevate values
   local shafts, reseq, i, j, k

   shafts := list(m)

   every !shafts := []

   every i := 1 to m do
      every put(shafts[i], i to n by m)

   reseq := []

   while j := get(seq) do {
      i := j % m + 1
      k := get(shafts[i])
      put(reseq, k)
      put(shafts[i], k)
      }

   return reseq

end
	
procedure lextend(L, i)			#: list extension
   local result

   if *L = 0 then fail

   result := copy(L)

   until *result >= i do
      result |||:= L

   result := result[1+:i]

   return result
 
end

procedure lfliph(L)			#: list horizontal flip (reversal)

   lfliph := lreverse

   return lfliph(L)

end

procedure lflipv(L)			#: list vertical flip
   local L1, m, i

   m := max ! L

   L1 := []

   every i := !L do
      put(L1, residue(-i + 1, m, 1))

   return L1

end

procedure limage(L)			#: list image
   local result

   if type(L) ~== "list" then stop("*** invalid type to limage()")

   result := ""

   every result ||:= image(!L) || ","

   return ("[" || result[1:-1] || "]") | "[]"

end

procedure lcollate(args[])		#: generalized list collation
   local seq, arg, lists, k

   lists := []

   every put(lists, copy(!args))

   seq := []

   repeat {
      every k := 1 to *lists do {
         arg := lists[k]
         put(seq, get(arg)) | break break
         }
      }

   return seq

end

procedure lconstant(L)			#: test list for all terms equal

   if *set(L) = 1 then return L[1]
   else fail

end

procedure lindex(lst, x)		#: generate indices for items matching x
   local i

   every i := 1 to *lst do
      if lst[i] === x then suspend i

end

procedure linterl(L1, L2)		#: list interleaving
   local L3, i

   if *L1 < *L2 then L1 := lextend(L1, *L2) | fail
   else if *L2 < *L1 then L2 := lextend(L2, *L1) | fail

   L3 := []

   every i := 1 to *L1 do
      put(L3, L1[i], L2[i])

   return L3

end

procedure llpad(L, i, x)		#: list padding at left

   L := copy(L)

   while *L < i do push(L, x)

   return L

end

procedure lrunup(L1, L2, L3)		#: list run up
   local L4

   /L3 := [1]		# could be /L3 := 1 ...

   L4 := []

   every put(L4, !L1 to !L2 by !L3)

   return L4

end

procedure lrundown(L1, L2, L3)		#: list run up
   local L4

   /L3 := [1]		# could be /L3 := 1 ...

   L4 := []

   every put(L4, !L1 to !L2 by -!L3)

   return L4

end

procedure lltrim(L, S)			#: list left trimming

   L := copy(L)

   while member(S, L[1]) do
      get(L)

    return L

end

procedure lmap(L1,L2,L3)		#: list mapping
   static lmem2, lmem3, lmaptbl, tdefault
   local i, a

   initial tdefault := []

   if type(a := L1 | L2 | L3) ~== "list" then runerr(108,a)
   if *L2 ~= *L3 then runerr(208,L2)

   L1 := copy(L1)

   if not(lmem2 === L2 & lmem3 === L3) then {	# if an argument is new, rebuild
      lmem2 := L2				# save for future reference
      lmem3 := L3
      lmaptbl := table(tdefault)		# new mapping table
      every i := 1 to *L2 do			# build the map
         lmaptbl[L2[i]] := L3[i]
      }
   every i := 1 to *L1 do			# map the values
      L1[i] := (tdefault ~=== lmaptbl[L1[i]])
   return L1

end

procedure lresidue(L, m, i)		#: list residue
   local result

   /i := 0

   result := []

   every put(result, residue(!L, m, i))

   return result

end

procedure lpalin(L, x)			#: list palindrome

   L |||:= lreverse(L)

   if /x then pull(L)

   return L

end

procedure lpermute(L)			#: list permutations
   local i

   if *L = 0 then return []
   suspend [L[i := 1 to *L]] ||| lpermute(L[1:i] ||| L[i+1:0])

end

procedure lreflect(L, i)		#: list reflection
   local L1

   /i := 0

   if i > 3 then stop("*** invalid argument to lreflect()")

   if i < 3 then L1 := copy(L)

   return L ||| lreverse(
      case i of {
         0:   {get(L1); pull(L1); L1}
         1:   {get(L1); L1}
         2:   {pull(L1); L1}
         3:   L
         }
      )

end

procedure lremvals(L, x[])		#: remove values from list
   local result, y

   result := []

   every y := !L do
      if y === !x then next
      else put(result, y)

   return result

end

procedure lrepl(L, i)			#: list replication
   local j, k

   i := (0 < integer(i)) | stop("*** invalid replication factor in lrepl()")

   L := copy(L)

   j := *L

   every 1 to i - 1 do
      every k := 1 to j do
         put(L, L[k])

   return L

end

procedure lreverse(L)			#: list reverse
   local i

   L := copy(L)

   every i := 1 to *L / 2 do
      L[i] :=: L[-i]

   return L

end

procedure lrotate(L, i)			#: list rotation

   /i := 1

   L := copy(L)

   if i > 0 then
      every 1 to i do
         put(L, get(L))
   else
      every 1 to -i do
         push(L, pull(L))

   return L

end

procedure lrpad(L, i, x)		#: list right padding

   L := copy(L)

   while *L < i do put(L, x)

   return L

end

procedure lrtrim(L, S)			#: list right trimming

   L := copy(L)

   while member(S, L[-1]) do
      pull(L)

    return L

end

procedure lshift(L, i)			#: shift list terms

   L := copy(L)

   every !L +:= i

   return L

end

procedure lst2str(L)			#: convert list to string
   local str

   str := ""

   every str ||:= !L

   return str

end

procedure lswap(L)			#: list element swap
   local i

   L := copy(L)

   every i := 1 to *L by 2 do
      L[i] :=: L[i + 1]

   return L

end

procedure lunique(L)			#: keep only unique list elements
   local result, culls, x

   result := []
   culls := set(L)

   every x := !L do
      if member(culls, x) then {
         delete(culls, x)
         put(result, x)
         }

   return result

end

procedure lmaxlen(L, p)			#: size of largest list entry
   local i

   /p := proc("*", 1)

   i := p(L[1]) | fail

   every i <:= p(!L)

   return i

end

procedure lminlen(L, p)			#: size of smallest list entry
   local i

   /p := proc("*", 1)

   i := p(L[1]) | fail

   every i >:= p(!L)

   return i

end

procedure sortkeys(L)			#: extract keys from sorted list
   local result

   result := []

   every put(result, L[1 to *L by 2])

   return result

end

procedure sortvalues(L)			#: extract values from sorted list
   local result

   result := []

   every put(result, L[2 to *L by 2])

   return result

end

procedure str2lst(s, i)			#: list from string
   local L

   /i := 1

   L := []

   s ? {
      while put(L, move(i))
      if not pos(0) then put(L, tab(0))
      }

   return L

end