|
| 1 | +(* ::Package:: *) |
| 2 | + |
| 3 | +(* :Title: Combinatorica Lite *) |
| 4 | + |
| 5 | +(* :Summary: |
| 6 | +This is a stripped-down version of Combinatorica. |
| 7 | +
|
| 8 | +Perhaps one day we'll be support the full thing, as an import. |
| 9 | +
|
| 10 | +Until then this is useful for getting us there. |
| 11 | +
|
| 12 | +The original contains: |
| 13 | +
|
| 14 | +:Copyright: Copyright 2000-2003 by Sriram V. Pemmaraju and Steven S. Skiena |
| 15 | +
|
| 16 | +This package may be copied in its entirety for nonprofit purposes only |
| 17 | +Sale, other than for the direct cost of the media, is prohibited. This |
| 18 | +copyright notice must accompany all copies. |
| 19 | +
|
| 20 | +The authors, Wolfram Research, and Cambridge University Press |
| 21 | +make no representations, express or implied, with respect to this |
| 22 | +documentation, or the software it describes and contains, including |
| 23 | +without limitations, any implied warranties of mechantability or fitness |
| 24 | +for a particular purpose, all of which are expressly disclaimed. The |
| 25 | +authors, Wolfram Research, or Cambridge University Press, their licensees, |
| 26 | +distributors and dealers shall in no event be liable for any indirect, |
| 27 | +incidental, or consequential damages. |
| 28 | +*) |
| 29 | + |
| 30 | +BeginPackage["DiscreteMath`CombinatoricaLite`"] |
| 31 | + |
| 32 | +PermutationQ::usage = "PermutationQ[p] yields True if p is a list representing a permutation and False otherwise." |
| 33 | +PermutationQ[e_List] := (Sort[e] === Range[Length[e]]) |
| 34 | + |
| 35 | +(* |
| 36 | +Unprotect[Permutations] |
| 37 | +Permutations[n_Integer] := Permutations[Range[n]] |
| 38 | +Protect[Permutations] |
| 39 | + *) |
| 40 | + |
| 41 | +Permute::usage = "Permute[l, p] permutes list l according to permutation p." |
| 42 | +Permute[l_List,p_?PermutationQ] := l [[ p ]] |
| 43 | +Permute[l_List,p_List] := Map[ (Permute[l,#])&, p] /; (Apply[And, Map[PermutationQ, p]]) |
| 44 | + |
| 45 | +InversePermutation::usage = "InversePermutation[p] yields the multiplicative inverse of permutation p." |
| 46 | +InversePermutation[p_?PermutationQ] := |
| 47 | + Module[{inverse=p}, |
| 48 | + Do[ inverse[[ p[[i]] ]] = i, {i,Length[p]} ]; |
| 49 | + inverse |
| 50 | + ] |
| 51 | + |
| 52 | +LexicographicPermutations::usage = "LexicographicPermutations[l] constructs all permutations of list l in lexicographic order." |
| 53 | +LexicographicPermutations[0] := {{}} |
| 54 | +LexicographicPermutations[1] := {{1}} |
| 55 | + |
| 56 | +LexicographicPermutations[n_Integer?Positive] := LP[n] |
| 57 | +LexicographicPermutations[l_List] := Permute[l, LexicographicPermutations[Length[l]] ] |
| 58 | +LP[{{n, _Integer}}] := |
| 59 | + Module[{l = Range[n], i, j, t}, |
| 60 | + NestList[(i = n-1; While[ #[[i]] > #[[i+1]], i--]; |
| 61 | + j = n; While[ #[[j]] < #[[i]], j--]; |
| 62 | + t = #[[i]]; #[[i]] = #[[j]]; #[[j]] = t; |
| 63 | + Join[ Take[#,i], Reverse[Drop[#,i]] ])&, |
| 64 | + l, n!-1 |
| 65 | + ] |
| 66 | + ] |
| 67 | + |
| 68 | +MinimumChangePermutations::usage = "MinimumChangePermutations[l] constructs all permutations of list l such that adjacent permutations differ by only one transposition." |
| 69 | +MinimumChangePermutations[l_List] := LexicographicPermutations[l] /; (Length[l] < 2) |
| 70 | +MinimumChangePermutations[l_List] := |
| 71 | + Module[{i=1,c,p=l,n=Length[l],k}, |
| 72 | + c = Table[1,{n}]; |
| 73 | + Join[{l}, |
| 74 | + Table[While [ c[[i]] >= i, c[[i]] = 1; i++]; |
| 75 | + If[OddQ[i], k=1, k=c[[i]] ]; |
| 76 | + {p[[i]],p[[k]]} = {p[[k]],p[[i]]}; |
| 77 | + c[[i]]++; i = 2; p, |
| 78 | + {n!-1} |
| 79 | + ] |
| 80 | + ] |
| 81 | + ] |
| 82 | + |
| 83 | +RankPermutation::usage = "RankPermutation[p] gives the rank of permutation p in lexicographic order." |
| 84 | +RankPermutation[{1}] := 0 |
| 85 | +RankPermutation[{}] := 0 |
| 86 | + |
| 87 | +RankPermutation[p_?PermutationQ] := |
| 88 | + Block[{$RecursionLimit = Infinity}, |
| 89 | + (p[[1]]-1) (Length[Rest[p]]!) + |
| 90 | + RankPermutation[ Map[(If[#>p[[1]], #-1, #])&, Rest[p]]] |
| 91 | + ] |
| 92 | + |
| 93 | +UnrankPermutation::usage = "UnrankPermutation[r, l] gives the rth permutation in the lexicographic list of permutations of list l. UnrankPermutation[r, n] gives the rth permutation in the lexicographic list of permutations of {1, 2,..., n}." |
| 94 | + |
| 95 | +UnrankPermutation[r_Integer, {}] := {} |
| 96 | +UnrankPermutation[r_Integer, l_List] := |
| 97 | + Module[{s = l, k, t, p = UP[Mod[r, Length[l]!], Length[l]]}, |
| 98 | + Table[k = s[[t = p[[i]] ]]; |
| 99 | + s = Delete[s, t]; |
| 100 | + k, |
| 101 | + {i, Length[ p ]} |
| 102 | + ] |
| 103 | + ] |
| 104 | + |
| 105 | +UnrankPermutation[r_Integer, n_Integer?Positive] := |
| 106 | + UnrankPermutation[r, Range[n]] |
| 107 | + |
| 108 | +Cyclic::usage = "Cyclic is an argument to the Polya-theoretic functions ListNecklaces, NumberOfNecklace, and NecklacePolynomial, which count or enumerate distinct necklaces. Cyclic refers to the cyclic group acting on necklaces to make equivalent necklaces that can be obtained from each other by rotation."; |
| 109 | + |
| 110 | +CyclicGroup::usage = "CyclicGroup[n] returns the cyclic group of permutations on n symbols."; |
| 111 | + |
| 112 | +DihedralGroupIndex::usage = "DihedralGroupIndex[n, x] returns the cycle index of the dihedral group on n symbols, expressed as a polynomial in x[1], x[2], ..., x[n]."; |
| 113 | + |
| 114 | +NecklacePolynomial::usage = "NecklacePolynomial[n, c, Cyclic] returns a polynomial in the colors in c whose coefficients represent numbers of ways of coloring an n-bead necklace with colors chosen from c, assuming that two colorings are equivalent if one can be obtained from the other by a rotation. NecklacePolynomial[n, c, Dihedral] is different in that it considers two colorings equivalent if one can be obtained from the other by a rotation or a flip or both."; |
| 115 | + |
| 116 | +OrbitInventory::usage = "OrbitInventory[ci, x, w] returns the value of the cycle index ci when each formal variable x[i] is replaced by w. OrbitInventory[ci, x, weights] returns the inventory of orbits induced on a set of functions by the action of a group with cycle index ci. It is assumed that each element in the range of the functions is assigned a weight in list weights."; |
| 117 | + |
| 118 | + |
| 119 | +NecklacePolynomial[n_Integer?Positive, c_, Cyclic] := |
| 120 | + OrbitInventory[CyclicGroupIndex[n, x], x, c] |
| 121 | + |
| 122 | +NecklacePolynomial[n_Integer?Positive, c_, Dihedral] := |
| 123 | + OrbitInventory[DihedralGroupIndex[n, x], x, c] |
| 124 | + |
| 125 | +OrbitInventory[ci_?PolynomialQ, x_Symbol, weights_List] := |
| 126 | + Expand[ci /. Table[x[i] -> Apply[Plus, Map[#^i&, weights]], |
| 127 | + {i, Exponent[ci, x[1]]} |
| 128 | + ] |
| 129 | + ] |
| 130 | + |
| 131 | +OrbitInventory[ci_?PolynomialQ, x_Symbol, r_] := |
| 132 | + Expand[ci /. Table[x[i] -> r, {i, Exponent[ci, x[1]]} ]] |
| 133 | + |
| 134 | +(*** Not working |
| 135 | +RandomPermutation::usage = "RandomPermutation[n] generates a random permutation of the first n natural numbers."; |
| 136 | +RP[n, _Integer] := |
| 137 | + Module[{p = Range[n],i,x,t}, |
| 138 | + Do [x = Random[Integer,{1,i}]; |
| 139 | + t = p[[i]]; p[[i]] = p[[x]]; p[[x]] = t, |
| 140 | + {i,n,2,-1} |
| 141 | + ]; |
| 142 | + p |
| 143 | + ] |
| 144 | +
|
| 145 | +
|
| 146 | +RandomPermutation[n_Integer] := RP[n] |
| 147 | +RandomPermutation[l_List] := Permute[l, RP[Length[l]]] |
| 148 | + ***) |
| 149 | + |
| 150 | +GrayCodeSubsets::usage = "GrayCodeSubsets[l] constructs a binary reflected Gray code on set l"; |
| 151 | +GrayCodeSubsets[n_Integer?Positive] := GrayCodeSubsets[Range[n]] |
| 152 | + |
| 153 | +GrayCodeSubsets[ { } ] := { {} } |
| 154 | + |
| 155 | +GrayCodeSubsets[l_List] := |
| 156 | + Block[{s, $RecursionLimit = Infinity}, |
| 157 | + s = GrayCodeSubsets[Take[l, 1-Length[l]]]; |
| 158 | + Join[s, Map[Prepend[#, First[l]] &, Reverse[s]]] |
| 159 | + ] |
| 160 | + |
| 161 | +(* We have a builtin that does this. Keep that? |
| 162 | +Subsets::usage = "Subsets[l] gives all subsets of set l." |
| 163 | +Subsets[l_List] := GrayCodeSubsets[l] |
| 164 | +Subsets[n_Integer] := GrayCodeSubsets[Range[n]] |
| 165 | +*) |
| 166 | + |
| 167 | +(* |
| 168 | +KSubsets[l_List,0] := { {} } |
| 169 | +KSubsets[l_List,1] := Partition[l,1] |
| 170 | +KSubsets[l_List,2] := Flatten[Table[{l[[i]], l[[j]]}, |
| 171 | + {i, Length[l]-1}, |
| 172 | + {j, i+1, Length[l]} |
| 173 | + ], |
| 174 | + 1 |
| 175 | +
|
| 176 | +KSubsets::usage = "KSubsets[l, k] gives all subsets of set l containing exactly k elements, ordered lexicographically."; |
| 177 | +KSubsets[l_List,k_Integer?Positive] := {l} /; (k == Length[l]) |
| 178 | +KSubsets[l_List,k_Integer?Positive] := {} /; (k > Length[l]) |
| 179 | +
|
| 180 | +KSubsets[s_List, k_Integer] := Prepend[Map[s[[#]] &, KS[Length[s], k]], s[[Range[k] ]] ] |
| 181 | + *) |
| 182 | + |
| 183 | +(* |
| 184 | +BinarySearch::usage = "BinarySearch[l, k] searches sorted list l for key k and gives the position of l containing k, if k is present in l. Otherwise, if k is absent in l, the function returns (p + 1/2) where k falls between the elements of l in positions p and p+1. BinarySearch[l, k, f] gives the position of k in the list obtained from l by applying f to each element in l." |
| 185 | +
|
| 186 | +BinarySearch::error = "The input list is non-numeric." |
| 187 | +BinarySearch[l_?(Length[#] > 0&), k_?NumericQ, f_:Identity]:= |
| 188 | + With[{res = binarysearchchore[l, k, f]}, |
| 189 | + res/; res =!= $Failed |
| 190 | + ] |
| 191 | +binarysearchchore[l_, k_, f_]:= |
| 192 | + Module[{lo = 1, mid, hi = Length[l], el}, |
| 193 | + While[lo <= hi, |
| 194 | + If[(el=f[l[[mid = |
| 195 | + Floor[ (lo + hi)/2 ]]]])===k, |
| 196 | + Return[mid] |
| 197 | + ]; |
| 198 | + If[!NumericQ[el], (Message[BinarySearch::error]; Return[$Failed])]; |
| 199 | + If[el > k, hi = mid-1, lo = mid+1] |
| 200 | + ]; |
| 201 | + Return[lo-1/2] |
| 202 | + ]; |
| 203 | +
|
| 204 | +Partitions::usage = "Partitions[n] constructs all partitions of integer n in reverse lexicographic order. Partitions[n, k] constructs all partitions of the integer n with maximum part at most k, in reverse lexicographic order." |
| 205 | +
|
| 206 | +Partitions[n_Integer] := Partitions[n,n] |
| 207 | +
|
| 208 | +Partitions[n_Integer,_] := {} /; (n<0) |
| 209 | +Partitions[0,_] := { {} } |
| 210 | +Partitions[n_Integer,1] := { Table[1,{n}] } |
| 211 | +Partitions[_,0] := {} |
| 212 | +
|
| 213 | +Partitions[n_Integer, maxpart_Integer] := |
| 214 | + Block[{$RecursionLimit = Infinity}, |
| 215 | + Join[Map[(Prepend[#,maxpart])&, Partitions[n-maxpart,maxpart]], |
| 216 | + Partitions[n,maxpart-1] |
| 217 | + ] |
| 218 | + ] |
| 219 | + *) |
| 220 | + |
| 221 | +EndPackage[] |
0 commit comments