OKlibrary  0.2.1.6
Lists.mac
Go to the documentation of this file.
00001 /* Oliver Kullmann, 20.2.2008 (Swansea) */
00002 /* Copyright 2008, 2009, 2010, 2011, 2012, 2013 Oliver Kullmann
00003 This file is part of the OKlibrary. OKlibrary is free software; you can redistribute
00004 it and/or modify it under the terms of the GNU General Public License as published by
00005 the Free Software Foundation and included in this library; either version 3 of the
00006 License, or any later version. */
00007 
00022 oklib_include("OKlib/ComputerAlgebra/DataStructures/Lisp/HashMaps.mac")$
00023 
00024 
00025 /* ***************
00026    * List access *
00027    ***************
00028 */
00029 
00030 /* x can either be a non-list, then it is returned, or a list,
00031    and then we get the corresponding element:
00032 */
00033 firste(x) := if listp(x) then first(x) else x$
00034 seconde(x) := if listp(x) then second(x) else x$
00035 thirde(x) := if listp(x) then third(x) else x$
00036 fourthe(x) := if listp(x) then fourth(x) else x$
00037 
00038 
00039 /* ***********************
00040    * Apply-functionality *
00041    ***********************
00042 */
00043 
00044 /* "Unrestricted apply" (for arbitrary argument-list-length);
00045    dissipating into apply's with blocksize many arguments: 
00046 */
00047 uapply(_op,L,blocksize) :=  block([l : length(L)],
00048   if l <= blocksize then apply('_op,L)
00049   else block([d : divide(l-1, blocksize), res : apply('_op,[first(L)])],
00050     L : rest(L),
00051     thru d[1] do (
00052       res : apply('_op, [res, apply('_op, take_elements(blocksize,L))]),
00053       L : rest(L, blocksize)
00054     ),
00055     if d[2] # 0 then
00056       apply('_op, [res, apply('_op, take_elements(d[2],L))])
00057     else
00058       res))$
00059 /* To be used with "append" etc.: */
00060 uaapply(_op,L) := uapply(_op,L,maximal_argument_length)$
00061 /* Remark: "apply("+",L)" etc. is possible for arbitrary lists L. */
00062 /* Remark: For "union" and "intersection" use lunion resp. lintersection.
00063 */
00064 
00065 /* The special case of appending the elements of a list: */
00066 lappend(L) := uaapply(append,L)$
00067 
00068 
00069 /* *********************
00070    * Map-functionality *
00071    *********************
00072 */
00073 
00074 /* Apply mapping_ to the elements of the elements of L: */
00075 map2(mapping_, L) := map(lambda([e], map(mapping_,e)), L)$
00076 
00077 
00078 /* *******************************
00079    * Testing properties of lists *
00080    *******************************
00081 */
00082 
00083 /* The versions of "every" and "some" with short-circuit evaluation: */
00084 
00085 /* For unary predicates: */
00086 every_s(_prede,_L) := block([_nocountex : true],
00087   for _x in _L while _nocountex do
00088     _nocountex : _prede(_x),
00089   return(_nocountex))$
00090 /* For arbitrary predicates (with at least one argument): */
00091 everynary_s([_L]) := block(
00092  [_nocountex : true, _pred : first(_L), _R : rest(_L)],
00093   for _x in apply(map, cons("[",_R)) while _nocountex do
00094     _nocountex : ev(apply(_pred, _x),pred),
00095   return(_nocountex))$
00096 /* Remarks:
00097  - every is faster than every_s if all elements are to be evaluated;
00098    every_s is faster than everynary_s if the predicate is unary.
00099 */
00100 
00101 /* For unary predicates: */
00102 some_s(_preds,_L) := block([_countex : false],
00103   for _x in _L unless _countex do
00104     _countex : _preds(_x),
00105   return(_countex))$
00106 /* For arbitrary predicates (with at least one argument): */
00107 somenary_s([_L]) := block(
00108  [_countex : false, _pred : first(_L), _R : rest(_L)],
00109   for _x in apply(map, cons("[",_R)) unless _countex do
00110     _countex : ev(apply(_pred, _x),pred),
00111   return(_countex))$
00112 /* Remarks:
00113  - some is faster than some_s if all elements are to be evaluated;
00114  - some_s is faster than somenary_s if the predicate is unary.
00115 */
00116 
00117 /* Checks whether L is a list without repetitions: */
00118 listnorep_p(L) := listp(L) and is(length(unique(L)) = length(L))$
00119 /* Checks whether L is a constant list: */
00120 lconstant_p(L) := if emptyp(L) then true else
00121   block([x : first(L)], every_s(lambda([y],is(x=y)), rest(L)))$
00122 
00123 /* Checks whether L is strictly ascending: */
00124 strictascending_p(L) := if length(L) <= 1 then true
00125  else everynary_s("<",rest(L,-1),rest(L))$
00126 strictdescending_p(L) := if length(L) <= 1 then true
00127  else everynary_s(">",rest(L,-1),rest(L))$
00128 /* Checks whether L is ascending: */
00129 ascending_p(L) := if length(L) <= 1 then true
00130  else everynary_s("<=",rest(L,-1),rest(L))$
00131 descending_p(L) := if length(L) <= 1 then true
00132  else everynary_s(">=",rest(L,-1),rest(L))$
00133 
00134 /* Checks whether L1 is an initial part of L2: */
00135 prefix_p(L1,L2) := if length(L1) > length(L2) then false
00136  else is(L1 = take_l(length(L1),L2))$
00137 
00138 
00139 /* *******************************************
00140    * Summations and products over lists/sets *
00141    *******************************************
00142 */
00143 
00144 sum_l(L) := apply("+",L)$
00145 sum_s(S) := apply("+",listify(S))$
00146 gsum_l(f,L) := apply("+",map(f,L))$
00147 gsum_s(f,S) := apply("+",map(f,listify(S)))$
00148 prod_l(L) := apply("*",L)$
00149 prod_s(S) := apply("*",listify(S))$
00150 gprod_l(f,L) := apply("*",map(f,L))$
00151 gprod_s(f,S) := apply("*",map(f,listify(S)))$
00152 
00153 
00154 /* *************************************
00155    * Finding special elements in lists *
00156    *************************************
00157 */
00158 
00159 /* Computing the first smallest element w.r.t. length of a list
00160    (or of a set). */
00161 /* Prerequisite: L is not empty. */
00162 first_smallest_l(L) := block([s : inf, S, l],  
00163   for x in L do (l : length(x),
00164     if l < s then (s : l, S : x)),
00165   S)$
00166 /* Now a lower bound on length is given: */
00167 first_smallest_lb_l(L,lb) := block([s : inf, S, l],  
00168   for x in L unless s = lb do (l : length(x),
00169     if l < s then (s : l, S : x)),
00170   S)$
00171 /* first_smallest_lb_l(L,0) computes the same result as first_smallest_l(L),
00172    but the computation is aborted as soon as an empty element was found
00173    (the price is the repeated evaluation of the condition).
00174 */
00175 
00176 /* More generally, compute the minimum value of function _fmin together with
00177    the corresponding first element (returned as pair).
00178    If the list is empty, then return [inf].
00179 */
00180 /* Prerequisite: _fmin(x) < inf for x in L. */
00181 first_smallest_f_l(_fmin,L) := if emptyp(L) then [inf] else
00182  block([min_v : inf, opt_x, v],
00183   for x in L do (v : _fmin(x),
00184     if v < min_v then (opt_x : x, min_v : v)),
00185   [min_v, opt_x])$
00186 /* Prerequisite: _fmax(x) > minf for x in L. */
00187 first_largest_f_l(_fmax,L) := if emptyp(L) then [minf] else
00188  block([max_v : minf, opt_x, v],
00189   for x in L do (v : _fmax(x),
00190     if v > max_v then (opt_x : x, max_v : v)),
00191   [max_v, opt_x])$
00192 
00193 /* Just computing the smallest element of f(x) for x in L: */
00194 smallest_f_l(_fmin,L) := if length(L) <= 20000 then lmin(map(_fmin,L)) else 
00195  block([min_v : inf, v],
00196   for x in L do ( v : _fmin(x), if v < min_v then min_v : v ),
00197   min_v)$
00198 /* And computing the largest element of f(x) for x in L: */
00199 largest_f_l(_fmax,L) := if length(L) <= 20000 then lmax(map(_fmax,L)) else 
00200  block([max_v : minf, v],
00201   for x in L do ( v : _fmax(x), if v > max_v then max_v : v ),
00202   max_v)$
00203 
00204 
00205 /* The index of the first element x in list L with property _pred(x);
00206    if there is no such x then return inf. */
00207 find_first_l(_pred,L) := if emptyp(L) then inf else
00208  block([found : false, i : 1],
00209   for x_ in L unless found do
00210     if _pred(x_)=true then found : true
00211     else i : i + 1,
00212   if found then i else inf)$
00213 /* Finding the first occurrence of x: */
00214 find_firste_l(x,L) := block([found : false, i : 1],
00215   for y in L unless found do
00216     if x=y then found : true
00217     else i : i + 1,
00218   if found then i else inf)$
00219 
00220 
00221 /* The index of the last element x in list L with property _pred(x);
00222    if there is no such x then return minf. */
00223 find_last_l(_pred,L) := if emptyp(L) then minf else
00224  block([found : false, i : length(L)],
00225   for x_ in reverse(L) unless found do
00226     if _pred(x_)=true then found : true
00227     else i : i - 1,
00228   if found then i else minf)$
00229 find_laste_l(x,L) := block([found : false, i : length(L)],
00230   for y in reverse(L) unless found do
00231     if x=y then found : true
00232     else i : i - 1,
00233   if found then i else minf)$
00234 
00235 
00236 elementp_l(x,L) := block([found : false],
00237   for y in L do if x=y then (found:true, return()),
00238   return(found))$
00239 
00240 
00241 /* *************************
00242    * Sublist constructions *
00243    *************************
00244 */
00245 
00246 /* The first n elements of L for 0 <= n <= length(L), while for 
00247    length(L) <= n <= 2 length(L) we use n' := 2 length(L) - n and
00248    return the last n' elements. Error if n < 0 or n > 2 length(L). */
00249 /* Returns a shallow copy of L. */
00250 /* RENAME: take_l */
00251 take_elements(n,L) := rest(L, - (length(L) - n))$
00252 take_l(n,L) := take_elements(n,L)$
00253 
00254 /* Finds the list of indices of elements equal to x. */
00255 sublist_indices_el(L,x) := sublist_indices(L,lambda([e],is(e=x)))$
00256 
00257 /* Removes element with index i from list L. Error if i < 1 or 
00258    i > length(L). */
00259 /* Returns a shallow copy of L. */
00260 remove_element(i,L) := append(take_elements(i-1,L), rest(L,i))$
00261 /* Removes all elements in list E from list L (returing a shallow copy of L):
00262 */
00263 remove_elements(E,L) := (for x in E do L : delete(x,L), L)$
00264 
00265 /* Return the sublist of list L for which the corresponding entry in
00266    okl-array I is 0. Returns a shallow copy. */
00267 sublist_indicator(L,I) := block([res : [], l : length(L), i : 1],
00268  for x in L do (
00269    if I[i] = 0 then res : cons(x,res),
00270    i : i + 1),
00271  return(reverse(res)))$
00272 
00273 /* Remove consecutive repeated elements: */
00274 remove_consrep(L) := if length(L) <= 1 then L
00275  elseif first(L)#second(L) then cons(first(L),remove_consrep(rest(L)))
00276  else remove_consrep(rest(L))$
00277 
00278 
00279 /* *********************
00280    * List partitioning *
00281    *********************
00282 */
00283 
00284 /* Partitions a given list l into a list of lists of size n,
00285    or less (in the case of the last-element list).
00286    Prerequisite n > 0. */
00287 /* Returns a shallow copy of L. */
00288 partition_elements(l,n) := if emptyp(l) then [] else 
00289  block([nn : min(length(l),n)],
00290   cons(take_elements(nn,l), partition_elements(rest(l,nn),n)))$
00291 /* We have apply(append, partition_elements(l,n)) = l. */
00292 
00293 
00294 /* Partition a list into yes- and no- instances */
00295 partition_list(L,pred_) := [sublist(L,'pred_),sublist(L,lambda([x],not pred_(x)))]$
00296 /* Same functionality, but now for more expensive predicates ("epo" for
00297    "evaluate predicate once"): */
00298 partition_list_epo(L,pred_) := block([A : [], B : []],
00299   for x in L do if pred_(x) then A : cons(x,A) else B : cons(x,B),
00300   return([reverse(A),reverse(B)]))$
00301 
00302 /* Partition a list into lists of elements which have the same value under
00303    the mapping eq_, maintaining the original order of elements in the
00304    sublists, while sorting the whole list according to the built-in-order
00305    for the values of map eq_: */
00306 partition_list_eq(L,eq_) := block([H : sm2hm({}),v,S],
00307   for x in L do (v : eq_(x),
00308     if (S : ev_hm(H,v)) = false then set_hm(H,v,[x])
00309     else set_hm(H,v,cons(x,S))),
00310   return(map(lambda([A],reverse(second(A))),listify(hm2sm(H)))))$
00311 
00312 
00313 /* Split a list into sublists using values e as breakpoints; the result has
00314    at least one (list-)element, and the concatentation yields the original
00315    list with e removed (i.e., lappend(split_list(L,e)) = delete(e,L)), where
00316    for each split-point we get the list to the left and to the right: */
00317 split_list(L,e) := split_list_epo(L,buildq([e],lambda([a], is(a = e))))$
00318 
00319 /* More generally, split a list into sublists using elements for which the
00320    given predicate returns true as the delimiting elements: */
00321 split_list_epo(L,pred_) := block([res: [], part : []],
00322   for x in L do
00323     if pred_(x) then (res : cons(reverse(part),res), part : [])
00324     else part : cons(x,part),
00325   res : cons(reverse(part),res),
00326   reverse(res))$
00327 
00328 
00329 /* **********************
00330    * List constructions *
00331    **********************
00332 */
00333 
00334 /* Rotates a list n elements to the right. Negative n rotates to the left. */
00335 rotate(l,n) := 
00336   if n = 0 or l = [] then l
00337   else if sign(n) = pos then rotate(append([last(l)],rest(l,-1)), n-1)
00338   else rotate(append(rest(l), [first(l)]), n+1)$
00339 
00340 /* Converts a list "l" to a matrix with rows of length "len_row", 
00341    computes the transposed matrix, and returns the flattening of 
00342    this matrix. len_row must be a multiple of the length of l. */
00343 transpose_l(l,len_row) :=
00344   m2l_r(transpose(apply(matrix,partition_elements(l,len_row))))$
00345 
00346 /* Removes duplicated elements in the order they appear (i.e., the second
00347    occurrence and later ones are removed).
00348    Returns copies of each first occurrence.
00349 */
00350 stable_unique(L) := block([S:{}, res:[]],
00351  for x in L do if not elementp(x,S) then (S : adjoin(x,S), res : cons(x,res)),
00352  reverse(res))$
00353 /* Remark: The Maxima-function unique(L) is not stable (but faster). */
00354 
00355 /* Interleaving the elements of all input lists in the order they are given
00356    as arguments. The lists are truncated to their first k elements, where
00357    k is the size of the smallest list.
00358    That is, given n lists L_1, ..., L_n, each of size k, return the list
00359    L_1[1],...,L_n[1],...,L_1[k],...,L_n[k].
00360 */
00361 interleave_l([L]) := block([l : length(L)],
00362   if l=0 then []
00363   elseif l=1 then first(L)
00364   elseif l=2 then join(first(L),second(L))
00365   elseif member([], L) then []
00366   else append(map(first,L), apply(interleave_l, map(rest,L))))$
00367 
00368 /* Add x's to the front of L, until length n is reached: */
00369 paddingfront_l(x,L,n) := append(create_list(x,i,1,n-length(L)),L)$
00370 paddingback_l(x,L,n) := append(L,create_list(x,i,1,n-length(L)))$
00371 
00372 
00373 /* *************************
00374    * Random parts of lists *
00375    *************************
00376 */
00377 
00378 /* Setting the state 0 <= n < 2^32. */
00379 /* Apparently each state is independent of every other state, and comprises
00380    a reasonably long sequence of random numbers.*/
00381 /* It appears that when Maxima is initialised then the random state is set
00382    to some fixed but unspecified value. */
00383 set_random(n) := set_random_state(make_random_state(n))$
00384 
00385 /* Returns a random element with indices between a and b
00386    from a non-empty list L. */
00387 /* Prerequisites: 1 <= a <= b <= length(L). */
00388 random_element_ab(a,b,L) := L[random(b-a+1)+a]$
00389 /* Returns a random element from a non-empty list: */
00390 random_element(L) := random_element_ab(1,length(L),L)$
00391 
00392 /* Removes a random element from a non-empty list passed by
00393    reference, and returns that element: */
00394 remove_random_element(L) := block([n : length(ev(L)), i, x],
00395   i : random(n) + 1,
00396   x : ev(L)[i],
00397   L :: remove_element(i,ev(L)),
00398   return(x))$
00399 
00400 
00401 /* ************************
00402    * Numerical operations *
00403    ************************
00404 */
00405 
00406 /* Count the number of occurrences of x in L: */
00407 count_l(x,L) := block([_res : 0],
00408  for _y in L do if _y = x then _res : _res + 1,
00409  _res)$
00410 /* Count the number of occurrences of elements > x in L: */
00411 countgt_l(x, L) := block([_res : 0],
00412  for _y in L do if _y > x then _res : _res + 1,
00413  _res)$
00414 /* Count the number of occurrences of elements < x in L: */
00415 countlt_l(x, L) := block([_res : 0],
00416  for _y in L do if _y < x then _res : _res + 1,
00417  _res)$
00418 /* More generally, count the number of elements in L where _pred is true: */
00419 countpred_l(_pred,L) := block([_res : 0],
00420  for _x in L do if _pred(_x) then _res : _res + 1,
00421  _res)$
00422 
00423 /* Count the number of non-trivial maximal contiguous sublists of L with
00424    constant value x:
00425 */
00426 countntconst_l(x,L) := if length(L) <= 1 then 0
00427  elseif first(L) # x then countntconst_l(x,rest(L))
00428  elseif second(L) # x then countntconst_l(x,rest(L,2))
00429  else block([i : find_first_l(lambda([y],is(y#x)),L)],
00430    if i=inf then 1
00431    else 1 + countntconst_l(x,rest(L, i)))$
00432 
00433 /* The list of sizes of (maximal) constant intervals: */
00434 size_constintervals_l(L) := if emptyp(L) then []
00435  elseif length(L) = 1 then [1]
00436  else block([r : size_constintervals_l(rest(L))],
00437    if first(L) = second(L) then (r[1] : r[1] + 1, r)
00438    else cons(1,r))$
00439 
00440 
00441 /* Applies the Delta-operator to list L, that is, take the difference
00442    of successive elements L[i+1] - L[i]:
00443 */
00444 Delta_l(L) := if length(L) <= 1 then [] else
00445  cons(second(L)-first(L), Delta_l(rest(L)))$
00446 
00447 /* Count the number of "plateaus of inflection": */
00448 count_extremals_l(L) := if emptyp(L) then 0
00449  elseif length(L)=1 then 1
00450  else 1 + length(remove_consrep(delete(0,signum(Delta_l(L)))))$
00451 
00452 
00453 /* MOVE functions to ComputerAlgebra/CombinatorialMatrices/Lisp/Basics.mac. */
00454 
00455 /* Flattens a matrix into a list of the elements, row by row: */
00456 m2l_r(m) := lappend(create_list(m[i],i,1,length(m)))$
00457 
00458 /* Returns a list of the given matrix's columns (as lists) */
00459 /* RENAME: m2ll_c */
00460 matrixcolumns(m) := partition_elements(m2l_r(transpose(m)),length(m))$
00461 
00462 /* Builds a matrix from a list of its columns (as lists) */
00463 /* RENAME: m_c */
00464 columns2matrix(mc) := transpose(uaapply(matrix, mc))$
00465 
00466 
00467 /* ***********
00468    * Sorting *
00469    ***********
00470 */
00471 
00472 /* Sorts a list according to the element's length (ascending and stable): */
00473 sort_length(L) := lappend(sort_length_part(L))$
00474 /* Now sorting by descending length (stable): */
00475 sort_length_desc(L) := lappend(sort_length_desc_part(L))$
00476 
00477 /* Distributing the elements of list L into a list of list, collecting
00478    elements of equal length, and sorting the meta-lists by ascending
00479    element-length. First returning the result as okl-array:
00480 */
00481 sort_length_part_ary(L) := block([S : listify(setify(map(length,L))), n, h, A, m],
00482   n : length(S),
00483   h : osm2hm(l2osm_inv(S)),
00484   A : okl_make_array(any, n),
00485   for i : 1 thru n do A[i] : [],
00486   for x in L do (m : ev_hm(h,length(x)), A[m] : cons(x,A[m])),
00487   for i : 1 thru n do A[i] : reverse(A[i]),
00488   A)$
00489 /* Now returning a list (of lists): */
00490 sort_length_part(L) := ary2l(sort_length_part_ary(L))$
00491 /* Now sorting by descending element-length: */
00492 sort_length_desc_part(L) := reverse(sort_length_part(L))$
00493 
00494 /* Returning the binary comparison which is true for two elements x and y iff
00495    the index of x is less than or equal to the index of y in the
00496    duplicate-free list L. If x or y is not in L, then und is returned. */
00497 l2order_p(L) := block([hm : sm2hm(l2osm_inv(L))],
00498   buildq([L,hm],
00499     lambda([x,y], block([x_i, y_i],
00500         x_i : ev_hm(hm, x),
00501         y_i : ev_hm(hm, y),
00502         if x_i = false or y_i = false then return(und)
00503         else is(x_i <= y_i)))))$
00504