APL Idioms in Mathematica

A.I. McLeod, University of Western Ontario
Copyright ©, A.I. McLeod, 1999.

Abstract

Elegant translations of numerous APL idioms are provided.  This collection is of interest to teachers of Mathematica programming and to former APL users.  A Mathematica package containing some of the most useful idioms is provided.

Keywords:  One-liners, Productivity studies; Teaching and education

In teaching Mathematica programming, I have found it helpful to have numerous short general purpose problems so that each student in the course may be assigned a different set of exercises.  APL idioms provide one source of manipulation problems which can be used for this purpose.  Although all of these problems deal with numeric data, many of them generalize to symbolic variables as well.  The range of difficulty is from trivial to challenging.  I would be interested in hearing from anyone who can provide a more elegant solution which avoids Do or While loops to any of the problems so that I can incorporate their improved solution in this list.  In return, I offer the honor of an acknowledgement!

APL is primarily a numeric programming language although it has been used for large industrial applications such as the production of a newspaper and for airline reservations.  APL is still going strong in the financial and actuarial industry due primarily to long usage by established researchers in these fields.  I expect that the younger generation will turn more to Mathematica.  At the University of Western Ontario for example my colleagues Drs. Jones, Stafford and Bellhouse are preparing a study note for the Society of Actuaries which entirely utilizes Mathematica notebooks.  Dr. Jones is also a former APL programmer.  The primary strength of APL is its elegant and powerful programming language.  Productivity studies by IBM and others have indicated that APL programmers are from ten to twenty times more productive than programmers working in Cobol and other similar languages like C.  Here productivity is measured as the time it takes the programmer to accomplish some task and not, of course, cpu time.  This is clearly the right measure nowdays with cheap cycles but even 20-30 years ago it was appropriate in many circumstances.  For example, I read a report some years ago, that the Toronto Sun newspaper had set an industry record in the speed of change from an old system of production to a new computerized system based on APL.  I myself have been used APL extensively since the summer of 1970 when I had a summer job programming standard actuarial functions in APL.

APL is a computer language rich in non-obvious elegant ways of doing many sorts of computations in a single statement.  One-liner APL idioms have been given by Iverson (1980), FinnAPL (1982) and Thompson (1989) and by many others.  Stephen Wolfram has said that the development of Mathematica was influenced by APL and that most of the standard APL functions are included in Mathematica.  Of course Mathematica contains many numeric and other capabilites beyond APL.

A Mathematica package containing some of the more useful APL idioms is provided.  This notebook may be of special interest to former APLers.

One noticeable difference between vector-thinking in APL and Mathematica is in the use of the outer product.  In APL one often uses the outer product operator ("jot-dot") to build an array or matrix and then operate on this to obtain the result.  But often in Mathematica it is possible to avoid the outer product and use the Mathematica Table function instead.  This is typically more efficient and elegant in Mathematica.  For diehards, Mathematica does provide an outer product function with similar APL capabilities.

Problems

In these exercises we express some well known APL idioms in Mathematica.  The variables are numerics.  Try to develop Mathematica functions which are as short and elegant as possible  I have written solutions to all these idioms which avoid all loops (Do, While, For).  In my solutions I have found that sometimes it is necessary or simplest to use several one-liner Mathematica functions instead of a longer and more complicated piece of Mathematica code.

Easy Problems

(1)  Find all elements of the vector X which are not in the vector Y.
(2)  Sort the elements of each column of a matrix in ascending order.
(3)  All pairs of elements from the vectors X and Y.
(4)  Let X be a positive integer. Form a vector from X is comprised of the digits of X in their correct order. For example if X = 341 then the answer would be {3, 4, 1}.
(5)  Let I denote a month with 1 corresponding to January, 2 to February and so on up to 12 for December.  Assuming it is not a leap year, write an expression which returns the number of days in month I.
(6)  Find the greatest common divisor all elements in a vector of positive integers.
(7)  AllTheSame[x]. Test if all elements of a vector are equal.
(8)  Index[x, y].  Find the index of the first occurence of the number X in the vector Y.
(9)  Triangular Numbers are defined by (Subscript[T, n]) = 1 + ... + n.  Find the first N triangular numbers.
(10)  Find the sum of the elements in a column of a matrix. 
(11)  Find the sum of the elements in a row of a matrix. 
(12)  Heron's Formula for the Area of a Triangle:  If X = {a,  b,  c} represents the sides of a triangle then its area is given by (Sqrt[s(s - a) (s - b) (s - c)]) where s =  (a + b + c)/2.
(13)  Let Y = {a, b} and let X be an arbitrary vector.  Replace all occurences of a in X with b.
(14)  Remove every second element of the vector X without using the Table function.
(15)  AbsSort[x].  Sort the elements of X in ascending order of absolute value but leave their values unchanged.
(16)  Square each element of a vector X but keep its sign.
(17)  Find the trace of a matrix
(18)  Test if vector X is a row in the matrix Y
(19) Round[x, n].  Round a floating point number x to n decimal places.
(20)  CoerceBoolean[x].  Change of True and False in a vector or matrix to 1 and 0.
(21) NumberVectorQ.  Test if X is a numeric vector.
(22) TSDifference. Form the d-th difference of a vector.
(23) SquareMatrixQ.  Test if X is a square matrix.
(24) Diagonal[x].  Find the diagonal elements of a square matrix.
(25) Toeplitz[x].  Write a function for the Toeplitz matrix of a vector x which is formed by taking the (i,j)-entry as x[[1+Abs[i-j]]. 
(26) SquareMatrixQ[x].  Test if a matrix is a square matrix.
(27) SymmetricMatrixQ[x].  Test if a matrix is symmetric.
(28) PersymmetricMatrixQ[x].  Test if a matrix is persymmetric, that is symmetric about the diagonal at a right angle to the main diagonal.
(29) DoublySymmetricMatrixQ[x].  Test if a matrix is symmetric about the main diagnonal and the diagonal at right angles to the main diagonal.
(30) ToeplitzMatrixQ[x].  Test if a matrix is a Toeplitz matrix.

Harder Problems

(1) Remove all duplicate elements from the an unordered vector X.  Leave X unordered.
(2) Test if X is a permutation of the set {1, 2,   ...  ,  Length(X)}
(3) Test if a matrix X is lower triangular.
(4)  Find the value of a saddle point of a vector X  For example, if X = {3, 7, 8, 8, 9, 2}, the saddlepoint is 8.
(5) Find the upward ranks corresponding to each element of a vector X, ie. rank 1 corresponds to the smallest X, etc.
(6) Find the upward ranks corresponding to each element of a vector X and replace tied values with their average rank. 
(7) Upward ranks of a vector, with tied values being given the lowest possible rank. 
(8) Set all elements of the vector X to 0 which occur after the first 0.
(9) Let Y be a vector of N nonnegative numbers and let X be any vector of length N.   Form the vector comprised of each element of X replicated according to the corresponding value of the element of Y.  For example, if Y={2,1,3} and X={dog, b, 7} then {dog, dog, b, 7,7,7}.
(10) Let X be a matrix and let Y be a vector with length equal to the number of columns of X.  Add Y to each column of X.
(11) Let X be a matrix and let Y be a vector with length equal to the number of columns of X.  Add Y to the i-th column of X.
(12) Remove duplicate rows of a matrix.
(13) Test if two vectors X and Y are the same.
(14) Sum over the subvectors of vector X by taking subvectors whose lengths are specified in the vector Y.  For example if X = {1, 2, 3, 4, 5} and Y = {2, 3} then the result is {3, 12}.  
 (15) Generates a random permutation of the elements of the list x  and generalize to a random permutation of k elements from the list x.
(16) Select a random sample of size r from the integers 1, ..., n
(17)  Use simulation to determine the probability of getting exactly one pair in 5 cards dealt at random from a standard card deck. 
(18) Game of 26.  Martin Gardiner, the columnist for Scientific American tried to solve this problem by combinatorial probability methods but was not able to. The Game of 26 used to be played in the bars of Chicago.In this game, thirteen die are rolled ten times. If your chosen number (from one to six) occurs 26 or more times, you win and your payoff is 4 to 1. Find the probability of winning and hence the fair betting odds. Verify your answer by simulation.
(19) In return for a payment of $7 now you will receive payments at the end of each for 7 years in the following amounts:  {1, 1.25, 1.35, 1.45, 1.5, 1.5,2}.  Compute the internal annualized rate of return.
(20) Generate the next n terms in the Fibonacci sequence, (Subscript[y, n]) = (Subscript[y, n - 1]) + (Subscript[y, n - 2])  starting with (Subscript[y, -1]) = (Subscript[y, 0]) = 1.
(21) Freedman's nonlinear white noise chaos is defined by (Subscript[z, t]) = f((Subscript[z, t - 1])), where
f(x)={({{2  x, , x < 0.5}, {2 - 2  x, , x ≥ 0.5}})
and initial value (Subscript[z, 0])  ϵ (0, 1).  In order to avoid the effect of roundoff error in the recursion to calculate (Subscript[z, t]) it is necessary to use exact arthimetic -- not floating-point.  Write a function to calculate n values in the sequence starting with an arbitrary (Subscript[z, 0]).
(22) Generate a sequence of uniform(0,1) pseudo-random numbers using a random number generator, developed P.A.W. Lewis (1967),  (Subscript[X, n]) = (7^5) (Subscript[X, n - 1]), mod((2^31) - 1) starting with initial seed, (Subscript[X, 0]) = (2^29) + 1.

Solutions

Easy Problems

(1)  Find all elements of the vector X which are not in the vector Y.

X = Range[5]; Y = {3,  3,  8}; Complement[X, Y]

(2)  Sort the elements of each column of a matrix in ascending order.

X = Table[Random[Integer, {1, 100}], {3}, {3}]

Transpose[Sort/@Transpose[X]]

(3)  All pairs of elements from the vectors X and Y.

X = {1, 3, 5}; Y = {2, 4, 6}; Flatten[Outer[List, X, Y], 1]

(4)  Let X be a positive integer. Form a vector from X is comprised of the digits of X in their correct order. For example if X = 341 then the answer would be {3, 4, 1}.

X = 341; IntegerDigits[X]

(5)  Let I denote a month with 1 corresponding to January, 2 to February and so on up to 12 for December.  Assuming it is not a leap year, write an expression which returns the number of days in month I.

NumberOfDaysInMonth[
        i_] := {31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31}
          [[i]]

(6)  Find the greatest common divisor all elements in a vector of positive integers.

GCD[120, 444, 840]

(7)  AllTheSame[x]. Test if all elements of a vector are equal.

X = {a,  a,  a};  Length[Union[X]] == 1

(8)  Index[x, y].  Find the index of the first occurence of the number X in the vector Y.

Index[x_?NumberQ,  y_?VectorQ] := First[Position[y, x] // Flatten]

Index[X, Y]

(9)  Triangular Numbers are defined by (Subscript[T, n]) = 1 +  ...  + n.  Find the first N triangular numbers.

Triangular[n_] := Drop[FoldList[Plus, 0, Range[n]], 1]

Triangular[5]

Alternatively, using the fact that (Subscript[T, n]) = n(n + 1)/2,

Triangular2[n_] := Table[i*(i + 1)/2, {i, n}]

(10)  Find the sum of the elements in a column of a matrix.

X = Table[i - j, {i, 3}, {j, 3}]

RowSum[x_] := Apply[Plus,  x]

RowSum[X]

(11)  Find the sum of the elements in a row of a matrix.

ColumnSum[x_] := Apply[Plus,  x,  2]

ColumnSum[X]

(12)  Heron's Formula for the Area of a Triangle:  If X = {a,  b,  c} represents the sides of a triangle then its area is given by (Sqrt[s(s - a) (s - b) (s - c)]) where s =  (a + b + c)/2.

As a check, lets compute the area of a triangle which divides the unit square in half.

X = {1, 1, Sqrt[2]};

Heron[x_] := Times@@((Plus@@X/2) - Join[{0}, X]) // Sqrt

Heron[X]

% // Simplify

(13)  Let Y = {a, b} and let X be an arbitrary vector.  Replace all occurences of a in X with b.

Y = {a, b}; X = {1, cat, dog, b, c, a};

X /. {
        Y[[1]] -> 
          Y[[2]]}

(14)  Remove every second element of the vector X without using the Table function.

DeleteEvery2ndElement[x_] := First[Transpose[Partition[x, 2]]]

DeleteEvery2ndElement[Range[10]]

(15)  AbsSort[x].  Sort the elements of X in ascending order of absolute value but leave their values unchanged.

AbsSort[x_] :=  Sort[x,  Abs[#1] < Abs[#2]&]

X = Table[Random[Integer, {-10, 10}], {10}]

AbsSort[X]

(16)  Square each element of a vector X but keep its sign.

Sign[X]*X*X

Alternatively, this solution uses less memory,

Sign[#] #^2&/@X

(17)  Find the trace of a matrix

MatrixTrace[x_] := 
      Sum[x[[i, i]], {i, Length[x]}]

(18)  Test if vector X is a row in the matrix Y

X = {2, 4, 6}; Y = Table[i*j,  {i, 3}, {j, 3}]

MemberQ[Y, X]

(19) Round[x, n].  Round a floating point number x to n decimal places.

We want to call our function Round but since Round is a builtin also a builtin function we must unprotect it and the re-protect after we finish defining.  Since the builtin function takes only one agrument and our new function will take two arguments there will be no confusion.

Unprotect[Round]

Round[x_,  n_] := N[x, n + If[x > 0, IntegerPart[Log[10, x]], 0]]

Protect[Round]

Round[22/7, 8]

The builtin function still works.

Round[22/7]

Another solution,

SetPrecision[22/7, 4]

(20)  CoerceBoolean[x].  Change of True and False in a vector or matrix to 1 and 0.

CoerceBoolean[x_] := x /. {True -> 1,  False -> 0};

(21) NumberVectorQ.  Test if X is a numeric vector.

NumberVectorQ[x_]  :=  
      VectorQ[x]  &&  And @@ NumberQ /@ x;

NumberVectorQ[{1, 2/3, 0.5}]

(22) TSDifference. Form the d-th difference of a vector.

\(TSDifference[z_, \ d_\  /; \ d\  > \ 0, \ s_:  1]\  := \ 
\ \ 
      With[{w\  = \ TSDifference[z, \ d\  - \ 1, \ s]}, \ 
        Drop[w, \ s]\  - \ Drop[w, \ \(-s\)]]; 
\ 
    TSDifference[z_, \ 0, \ s_]\  := \ z; \)

TSDifference[Table[i + 3  i^2, {i, 10}], 2]

(23) SquareMatrixQ.  Test if X is a square matrix.

SquareMatrixQ[x_]  :=  
      MatrixQ[x]  &&  Apply[Equal,  Dimensions[x]];

SquareMatrixQ[{{1, 0}, {0, 1}}]

(24) Diagonal[x].  Find the diagonal elements of a square matrix.

Diagonal[x_] := Transpose[x, {1, 1}]

Diagonal[IdentityMatrix[5]]

(25) Toeplitz[x].  Write a function for the Toeplitz matrix of a vector x which is formed by taking the (i,j)-entry as x[[1+Abs[i-j]].

Toeplitz[x_]  :=  
      Table[x[[1  +  Abs[i  -  j]]],  {i,  Length[x]}, 
         {j,  Length[x]}]

(26) SquareMatrixQ[x].  Test if a matrix is a square matrix.

SquareMatrixQ[x_]  :=  
      MatrixQ[x]  &&  Apply[Equal,  Dimensions[x]]

(27) SymmetricMatrixQ[x].  Test if a matrix is symmetric.

SymmetricMatrixQ[x_]  :=  x  ==  Transpose[x]

(28) PersymmetricMatrixQ[x].  Test if a matrix is persymmetric, that is symmetric about the diagonal at a right angle to the main diagonal.

PersymmetricMatrixQ[x_]  :=    
          x  == Table[
              x[[Length[x]  +  1  -  j, Length[x]  +  1  -  i]], 
               i,  Length[x]},  {j,  Length[x]}]

(29) DoublySymmetricMatrixQ[x].  Test if a matrix is symmetric about the main diagnonal and the diagonal at right angles to the main diagonal.

DoublySymmetricMatrixQ[x_]  :=  
      SquareMatrixQ[x]  &&  SymmetricMatrixQ[x]  &&  
        PersymmetricMatrixQ[x]

(30) ToeplitzMatrixQ[x].  Test if a matrix is a Toeplitz matrix.

ToeplitzMatrixQ[x_]  :=  
      SquareMatrixQ[x]  &&  x  ==  Toeplitz[x[[1]]]

Harder Problems

(1)  RemoveDups[x].  Remove all duplicate elements from the an unordered vector X.  Leave X unordered.

X = {4, 2, 1, 6, 5, 5, 2, 3, 3, 4, 4, 4, 5};

\(FindDups[x_] := 
      Module[{n = Length[x]}, 
        \(GreaterEqual[#, 2]&\)/@
          Apply[Plus, 
            Table[\(CoerceBoolean[Outer[Equal, x, x, 1]]
                  \)[[i, j]], {i, n}, {
                j, i}], 2]]; 

    CoerceBoolean[x_] := x /. {True -> 1, \ False -> 0}; 

    RemoveDups[x_] := 
      With[{λ = Not/@FindDups[x]}, 
        x[[Select[Range[Length[x]], λ[\([#1]\)]&]
            ]]]\)

RemoveDups[X]

(2)  PermutationQ[x].  Test if X is a permutation of the set {1, 2,   ...  ,  Length(X)}

PermutationQ[x_] := Sort[x] === Range[Length[x]]

PermutationQ[{3, 2, 1}]

(3)  LowerTriangularQ[x].  Test if a matrix X is lower triangular.

X = Table[If[i ≥ j, i*j, 0], {i, 3}, {j, 3}]

LowerTriangularQ[x_] := 
      And@@(SameQ[#, 0]&/@
            (With[{n = Dimensions[x] // First}, 
                  Table[If[i < j, 
                      x[[i, j]], 0], {i, 
                      n}, {j, n}]] // Flatten))

{LowerTriangularQ[X], LowerTriangularQ[Transpose[X]]}

(4)  SaddlePoints[x].  Find the value of a saddle point of a vector X  For example, if X = {3, 7, 8, 8, 9, 2}, the saddlepoint is 8.

X = {3, 7, 8, 8, 8, 9, 2, 2, 3, 1, 1, 0, 3};

FindInflexionPoints[x_] := 
      Position[Drop[MapThread[Equal, {x, RotateLeft[x]}], -1], True] // 
        Flatten

FindInflexionPoints[X]

SaddleQ[x_, i_] := 
      With[{s = 
            Sign[Drop[x, i - 2] - 
                x[[i]]]}, 
        SameQ[0, 
          s[[1]] + 
            RemoveDups[Drop[s, 1]][[2
              ]]]]

WhereTrue[λ_] := 
      Select[Range[Length[λ]], 
        λ[[#]]&]

SaddlePoints[x_] := 
      With[{p = FindInflexionPoints[x]}, 
        p[[WhereTrue[SaddleQ[x, #]&/@p]
            ]]]

SaddlePoints[X]

SaddlePointValues[x_] := 
      x[[SaddlePoints[x]]]

SaddlePointValues[X]

(5)  Rank[x].  Find the upward ranks corresponding to each element of a vector X, ie. rank 1 corresponds to the smallest X, etc.

Rank[x_] := 
      With[{n = Range[Length[x]]}, 
        Last/@Sort[
            Transpose[{
                Last[Transpose[
                    Sort[Transpose[{x, 
                          n}], #1[[1
                            ]] < #2[[1
                            ]]&]]], 
                n}], #1[[1]] < #2
                  [[1]]&]]

x = Table[Random[Integer, {1, 100}], {5}]

Rank[x]

(6) Rank[x, Ties->Average]. Find the upward ranks corresponding to each element of a vector X and replace tied values with their average rank.

x = Table[Random[Integer, {1, 4}], {10}]

TiedGroups[x_] := 
      With[{a = Length/@Split[Sort[x]]}, 
        (Drop[#, 1]&/@(FoldList[Plus, 0, Table[1, {#}]]&/@a) + 
            Drop[FoldList[Plus, 0, a], -1])]

TiedGroups[x]

MeanTiedGroups[x_] := 
      With[{i = TiedGroups[x]}, (Mean/@i)*(i/i) // Flatten]

Mean[x_] := Plus@@x/Length[x]

MeanTiedGroups[x]

Rankties[x_] := 
      With[{n = MeanTiedGroups[x]}, 
        Last/@Sort[
            Transpose[{
                Last[Transpose[
                    Sort[Transpose[{x, 
                          n}], #1[[1
                            ]] < #2[[1
                            ]]&]]], 
                n}], #1[[1]] < #2
                  [[1]]&]]

Rankties[x]

(7) Rank[x, Ties->Low].  Upward ranks of a vector, with tied values being given the lowest possible rank.

x = Table[Random[Integer, {1, 4}], {10}]

TiedGroups[x_] := 
      With[{a = Length/@Split[Sort[x]]}, 
        (Drop[#, 1]&/@(FoldList[Plus, 0, Table[1, {#}]]&/@a) + 
            Drop[FoldList[Plus, 0, a], -1])]

TiedGroups[x]

MinTiedGroups[x_] := 
      With[{i = TiedGroups[x]}, (Min/@i)*(i/i) // Flatten]

MinTiedGroups[x]

Ranktiesmin[x_] := 
      With[{n = MinTiedGroups[x]}, 
        Last/@Sort[
            Transpose[{
                Last[Transpose[
                    Sort[Transpose[{x, 
                          n}], #1[[1
                            ]] < #2[[1
                            ]]&]]], 
                n}], #1[[1]] < #2
                  [[1]]&]]

Ranktiesmin[x]

(8)  Set all elements of the vector X to 0 which occur after the first 0.

X = {4,  6,  0,  2,  3, 0};

ZeroOut[x_] := 
      With[{firstzero = First[Position[X, 0] // Flatten]}, 
        Table[If[i > firstzero, 0, 
            x[[i]]], {i, Length[x]}]]

ZeroOut[X]

(9)  Replicate[x,  y].   Let Y be a vector of N nonnegative numbers and let X be any vector of length N.   Form the vector comprised of each element of X replicated according to the corresponding value of the element of Y.  For example, if Y={2,1,3} and X={dog, b, 7} then {dog, dog, b, 7,7,7}.

Y = {2, 1, 3}; X = {dog, b, 7};

\(\(	Replicate[x_, \ y_] := 
      Flatten[MapThread[Table[#1, {#2}]&, \ {x, y}]]\)\)

Replicate[X, Y]

(10)  Let X be a matrix and let Y be a vector with length equal to the number of columns of X.  Add Y to each column of X.

X = Table[i + j, {i, 3}, {j, 3}]; Y = {1000, 1000, 1000};

AddVectorToMatrix[x_,  y_] := 
      Map[Plus[y, #]&, x // Transpose] // Transpose

AddVectorToMatrix[X, Y]

(11)  Let X be a matrix and let Y be a vector with length equal to the number of columns of X.  Add Y to the i-th column of X.

AddVectorToColumn[x_,  y_, i_] := 
      MapAt[Plus[y, #]&, x // Transpose, i] // Transpose

AddVectorToColumn[X, Y,  2]

Other functions for manipulating columns of data matricies are included in the standard addon package Statistics`DataManipulation`.

(12) RemoveRowDups[x].  Remove duplicate rows of a matrix.

X = {{1, 2}, {3, 4}, {1, 2}, {3, 3}, {3, 4}};

In this approach we use a several one-liners.  First, here is a function which tests if rows are equal.

VectorEqualQ[x_,  y_]  := And@@MapThread[SameQ, {x, y}]

Next we use this function to build up a lower-triangular list whose i-th entry indicates if the ith row is duplicated in any of the previous rows,

i = 
      Table[Outer[VectorEqualQ, X, X, 1][[i, j
          ]], {i, 5}, {j, i}]

CoerceBoolean[x_] := x /. {True -> 1,  False -> 0}

Now we convert this to a boolean vector which tell us which rows are duplicates,

SameQ[#, 2]&/@Apply[Plus, CoerceBoolean[i], 2]

The above two-lines of code are summarized in the following oneliner which finds the duplicate rows which should be deleted.

FindRowDups[x_] := 
      With[{n = Dimensions[x] // First}, 
        SameQ[#, 2]&/@
          Apply[Plus, 
            Table[CoerceBoolean[Outer[VectorEqualQ, X, X, 1]]
                  [[i, j]], {i, n}, {
                j, i}], 2]]

Finally, here is our function to remove duplicate rows,

RemoveRowDups[x_] := 
      Module[{r = {}, λ = FindRowDups[x]}, 
        Do[If[Not[λ[[i]]], 
            AppendTo[r, x[[i]]]], {i, 
            Length[λ]}]; r]

RemoveRowDups[X]

(13)  VectorEqualQ[x, y].  Test if two vectors X and Y are the same.

VectorEqualQ[x_,  y_]  := And@@MapThread[SameQ, {x, y}]

(14)  SubvectorSum[x, y].  Sum over the subvectors of vector X by taking subvectors whose lengths are specified in the vector Y.  For example if X = {1, 2, 3, 4, 5} and Y = {2, 3} then the result is {3, 12}.

X = Table[Random[Integer, {1, 10}], {10}]

Y = {3, 2, 5};

The solution can be built up in 3 easy stages.

SubListPosition[y_] := 
      With[{t = FoldList[Plus, 1, y]}, 
        Transpose[{Drop[t, -1], Drop[t - 1, 1]}]]

SubListPosition[Y]

SubVectors[x_,  y_] := Take[x, #]&/@SubListPosition[y]

SubVectors[X, Y]

SubVectorSums[x_, y_] := Apply[Plus, SubVectors[x, y], 2]

SubVectorSums[X, Y]

(15)  RandomPerm[x] and RandomPerm[x, k].  RandomPerm[x]  generates a random permutation of the elements of the list x.  RandomPerm[x, k] generates a random permutation of k elements from the list x.";

RandomPerm[x_, k_] := 
      Take[x[[First[
            Transpose[
              With[{n = Length[x], y = Range[Length[x]]}, 
                Sort[Transpose[{y, 
                      Table[Random[], {n}]}], #1[[2
                        ]] < #2[[2
                        ]]&]]]]]], k]

Timing[RandomPerm[Range[1000]]; ]

(16) APLDeal.  Select a random sample of size r from the integers 1, ..., n

\(APLDeal[n_Integer?Positive, \ r_Integer?Positive]\  := \ 
\ \ 
      Module[{jPosition}, \ 
\ \ \ \ \ \ \ 
          LastJPosition[x_]\  := \ Last[Position[jPosition, \ x]]; 

          \ \ \ \ \ \ \ 
          jPosition\  = \ 
\ \ \ \ \ \ \ \ \ 
            Join[Range[n], \ 
              Drop[Ceiling[Table[Random[], \ {r}]*Range[r]], \ n]]; \ 

          \ \ \ \ \ \ \ Flatten[LastJPosition\ /@\ Range[n]]

          \ \ \ \ \ \ \ \ ]\  /; \ n\  <= \ r\)

APLDeal[5, 52]

(17)  Use simulation to determine the probability of getting exactly one pair in 5 cards dealt at random from a standard card deck.

Cards are labelled 1, ... ,52 and a poker hand is a random sample of 5 cards without replacement.  Modulo with respect to 13 indicates the card denomination.

CountOnePair[x_]  :=  
      Count[Length /@ Union /@ Mod[x,  13],  4]

CountOnePair[{{1, 14, 3, 4, 5}, {1, 2, 3, 4, 5}}]

The empirical probability of getting exactly one pair determined from (10^3) simulations is:

CountOnePair[Table[APLDeal[5,  52],  {1000}]]/1000

The exact probability is:

(((({{13}, {1}}))(({{4}, {2}}))(({{12}, {3}}))(((({{4}, {1}})))^3))/((({{52}, {5}}))))=(352/833) = 0.422469

A 95% confidence interval for this probability is:

(#  +  {-1, 1} 1.96 Sqrt[#  (1 -  #) / 1000])&
            [%]   // N

(18). Game of 26.  Martin Gardiner, the columnist for Scientific American tried to solve this problem by combinatorial probability methods but was not able to. The Game of 26 used to be played in the bars of Chicago.In this game, thirteen die are rolled ten times. If your chosen number (from one to six) occurs 26 or more times, you win and your payoff is 4 to 1. Find the probability of winning and hence the fair betting odds. Verify your answer by simulation.

Definition of Odds: The odds in favour of an event 𝔈 are Pr{𝔈}/(1-Pr{𝔈}). In gambling, the odds of losing are quoted. So for example, if the probability of winning is 1/5 the gambling odds are quoted as 4-to-1. In this case if you bet $1 and you win, you will receive back your original $1 plus another $4.

We could also use (∑_(i = 26)^130)(({{130}, {i}}))(((1/6))^i)(((5/6))^(130 - i)) to compute this probability:

Needs["Statistics`DiscreteDistributions`"];

1 - 
      Apply[Plus, 
        Table[Binomial[130, i]*((1/6)^i)*
            ((5/6)^(130 - i)), {i, 25}]]

% // N

Hence the fair betting odds are:

(1 - %)/%

Choosing either number from one to six, we have the same probability of 
winning. Now we choose number 3 and will have:

n = 10000; samp[] := Table[Table[Random[Integer, {1, 6}], {13}], {10}]; 
    Count[Table[Count[Flatten[samp[]], 3] >= 26, {n}], True]/n // N

(19). InternalRateOfReturn[x, t].  In return for a payment of $7 now you will receive payments at the end of each for 7 years in the following amounts:  {1, 1.25, 1.35, 1.45, 1.5, 1.5,2}.  Compute the internal annualized rate of return.

As another example with an actuarial flavor consider the computation of the internal rate of return of an investment.  Consider suppose that for a payment of X now you can buy an investment which will make a given series of payments (Subscript[x, 1]),  (Subscript[x, 2]),  ... ,  (Subscript[x, n]) at the end of each year for the next n years.  Then the internal rate of return, i, is determined by a solution to the equation,

(∑_(l = 1)^n) (Subscript[x, l]) (v^l) = X,

where v = 1/(1 + i ).  Using the Mathematica function NSolve we can obtain a numerical solution.  For example, suppose for an immediate payment of 16 you can receive the following payments at the end of each year,

With[{x = {1, 1.25, 1.35, 1.45, 1.5, 1.5, 2}}, 
      ((v^(-1)) - 1) /. 
        FindRoot[x.Table[(v^i), {i, 1, Length[x]}]  ==  7, {v, 1/1.1, 0, 1}]]

So we see the annual internal rate of return is about 9%.

InternalRateOfReturn[x_, t_] := 
        ((v^(-1)) - 1) /. 
          FindRoot[
            x.Table[(v^t)[[i]], {i, 1, 
                    Length[x]}]  ==  7, {v, 1/1.1, 0, 1}]]

(20) Generate the next n terms in the Fibonacci sequence, (Subscript[y, n]) = (Subscript[y, n - 1]) + (Subscript[y, n - 2])  starting with (Subscript[y, -1]) = (Subscript[y, 0]) = 1.

Fib[n_] := 
      Transpose[
          NestList[{
                Apply[Plus, #], #[[1
                  ]]}&, {1, 0}, n + 1]]
          [[1]]

(21) Freedman's nonlinear white noise chaos is defined by (Subscript[z, t]) = f((Subscript[z, t - 1])), where
f(x)={({{2  x, , x < 0.5}, {2 - 2  x, , x ≥ 0.5}})
and initial value (Subscript[z, 0])  ϵ (0, 1).  In order to avoid the effect of roundoff error in the recursion to calculate (Subscript[z, t]) it is necessary to use exact arthimetic -- not floating-point.  Write a function to calculate n values in the sequence starting with an arbitrary (Subscript[z, 0]).

Freedman[n_,  z0_:  0.177221] := 
      With[{XSTART = Rationalize[z0]}, 
          NestList[If[# < 1/2, 2  #, 2 - 2  #]&, XSTART, n]] // N

(22) Generate a sequence of uniform(0,1) pseudo-random numbers using a random number generator, developed P.A.W. Lewis (1967),  (Subscript[X, n]) = (7^5) (Subscript[X, n - 1]), mod((2^31) - 1) starting with initial seed, (Subscript[X, 0]) = (2^29) + 1.

Lewis[n_,  x0_: ((2^29) + 1)] := 
      Drop[NestList[Mod[(7^5) #, (2^31) - 1]&, x0,  10], 1]/
          ((2^31) - 1) // N

References

FinnAPL (1982).  Finn APL Pocket Idiom Library.  Helsinki: Finnish APL Association.  ISBN: 951-99398-0-6.

Iverson, K.E. (1980).  Notation as a tool of thought.  Communications of the Association of Computing Machinery 23(8), 444-465.

Thomson, N. (1989). APL Programs for the Mathematics Classroom. New York: Springer-Verlag