September 2017 Update

Task/Matrix-arithmetic/Forth/matrix-arithmetic.fth

@@ -0,0 +1,38 @@
+S" fsl-util.fs" REQUIRED
+S" fsl/dynmem.seq" REQUIRED
+[UNDEFINED] defines [IF] SYNONYM defines IS [THEN]
+S" fsl/structs.seq" REQUIRED
+S" fsl/lufact.seq" REQUIRED
+S" fsl/dets.seq" REQUIRED
+S" permute.fs" REQUIRED
+
+VARIABLE the-mat
+: add-perm ( p0 p1 p2 ... pn n s -- )
+  DROP  \ sign
+  1E
+  1 DO
+    the-mat @ SWAP 1- I 1- }} F@ F*
+  LOOP
+  DROP  \ Dummy element because we're using 1-based indexing
+  F+ ;
+: permanent ( len mat -- ) ( F: -- perm )
+  the-mat !
+  0E
+  ['] add-perm perms ;
+
+3 SET-PRECISION
+2 2 float matrix m2{{
+1e 2e  3e 4e  2 2 m2{{ }}fput
+lumatrix lmat
+3 3 float matrix m3{{
+2e 9e 4e  7e 5e 3e  6e 1e 8e  3 3 m3{{ }}fput
+
+lmat 2 lu-malloc
+m2{{ lmat lufact
+lmat det F. 2 m2{{ permanent F. CR
+lmat lu-free
+
+lmat 3 lu-malloc
+m3{{ lmat lufact
+lmat det F. 3 m3{{ permanent F. CR
+lmat lu-free

Task/Matrix-arithmetic/Go/matrix-arithmetic-2.go

@@ -0,0 +1,44 @@
+package main
+
+import "fmt"
+
+func main() {
+    fmt.Println(ryser([][]float64{
+        {1, 2},
+        {3, 4}}))
+    fmt.Println(ryser([][]float64{
+        {2, 9, 4},
+        {7, 5, 3},
+        {6, 1, 8}}))
+}
+
+func ryser(m [][]float64) (d float64) {
+    gray := 0
+    csum := make([]float64, len(m))
+    sgn := float64(len(m)&1<<1 - 1)
+    n2 := uint32(1) << uint(len(m))
+    for i := uint32(1); i < n2; i++ {
+        r := [...]byte{
+            0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8,
+            31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9,
+        }[i&-i*0x077CB531>>27]
+        b := 1 << r
+        if gray&b == 0 {
+            for c, e := range m[r] {
+                csum[c] += e
+            }
+        } else {
+            for c, e := range m[r] {
+                csum[c] -= e
+            }
+        }
+        gray ^= b
+        p := sgn
+        for _, e := range csum {
+            p *= e
+        }
+        d += p
+        sgn = -sgn
+    }
+    return
+}

Task/Matrix-arithmetic/Go/matrix-arithmetic-3.go

@@ -0,0 +1,17 @@
+package main
+
+import (
+    "fmt"
+
+    "github.com/skelterjohn/go.matrix"
+)
+
+func main() {
+    fmt.Println(matrix.MakeDenseMatrixStacked([][]float64{
+        {1, 2},
+        {3, 4}}).Det())
+    fmt.Println(matrix.MakeDenseMatrixStacked([][]float64{
+        {2, 9, 4},
+        {7, 5, 3},
+        {6, 1, 8}}).Det())
+}

Task/Matrix-arithmetic/Go/matrix-arithmetic-4.go

@@ -0,0 +1,17 @@
+package main
+
+import (
+    "fmt"
+
+    "github.com/gonum/matrix/mat64"
+)
+
+func main() {
+    fmt.Println(mat64.Det(mat64.NewDense(2, 2, []float64{
+        1, 2,
+        3, 4})))
+    fmt.Println(mat64.Det(mat64.NewDense(3, 3, []float64{
+        2, 9, 4,
+        7, 5, 3,
+        6, 1, 8})))
+}

Task/Matrix-arithmetic/Haskell/matrix-arithmetic.hs

@@ -1,39 +1,59 @@
-s_permutations :: [a] -> [([a], Int)]
-s_permutations = flip zip (cycle [1, -1]) . (foldl aux [[]])
-  where aux items x = do
-          (f,item) <- zip (cycle [reverse,id]) items
-          f (insertEv x item)
-        insertEv x [] = [[x]]
-        insertEv x l@(y:ys) = (x:l) :  map (y:) (insertEv x ys)
+sPermutations :: [a] -> [([a], Int)]
+sPermutations = flip zip (cycle [1, -1]) . foldl aux [[]]
+  where
+    aux items x = do
+      (f, item) <- zip (cycle [reverse, id]) items
+      f (insertEv x item)
+    insertEv x [] = [[x]]
+    insertEv x l@(y:ys) = (x : l) : ((y :) <$>) (insertEv x ys)
 
-elemPos::[[a]] -> Int -> Int -> a
+elemPos :: [[a]] -> Int -> Int -> a
 elemPos ms i j = (ms !! i) !! j
 
-prod:: Num a => ([[a]] -> Int -> Int -> a) -> [[a]] -> [Int] -> a
-prod f ms = product.zipWith (f ms) [0..]
+prod
+  :: Num a
+  => ([[a]] -> Int -> Int -> a) -> [[a]] -> [Int] -> a
+prod f ms = product . zipWith (f ms) [0 ..]
 
-s_determinant:: Num a => ([[a]] -> Int -> Int -> a) -> [[a]] -> [([Int],Int)] -> a
-s_determinant f ms = sum.map (\(is,s) -> fromIntegral s * prod f ms is)
+sDeterminant
+  :: Num a
+  => ([[a]] -> Int -> Int -> a) -> [[a]] -> [([Int], Int)] -> a
+sDeterminant f ms = sum . fmap (\(is, s) -> fromIntegral s * prod f ms is)
 
-determinant:: Num a => [[a]] -> a
-determinant ms = s_determinant elemPos ms.s_permutations $ [0..pred.length $ ms]
+determinant
+  :: Num a
+  => [[a]] -> a
+determinant ms =
+  sDeterminant elemPos ms . sPermutations $ [0 .. pred . length $ ms]
 
-permanent:: Num a => [[a]] -> a
-permanent ms = sum.map (prod elemPos ms.fst).s_permutations $ [0..pred.length $ ms]
+permanent
+  :: Num a
+  => [[a]] -> a
+permanent ms =
+  sum . fmap (prod elemPos ms . fst) . sPermutations $ [0 .. pred . length $ ms]
 
-result ms = do
-  putStrLn "Matrice:"
-  mapM_ print ms
-  putStrLn "Determinant:"
-  print $ determinant ms
-  putStrLn "Permanent:"
-  print $ permanent ms
+-- TEST -----------------------------------------------------------------------
+result
+  :: (Num a, Show a)
+  => [[a]] -> String
+result ms =
+  unlines
+    [ "Matrix:"
+    , unlines (show <$> ms)
+    , "Determinant:"
+    , show (determinant ms)
+    , "Permanent:"
+    , show (permanent ms)
+    ]
 
-main = do
-  let m1 = [[5]]
-  let m2 = [[1,0,0],[0,1,0],[0,0,1]]
-  let m3 = [[0,0,1],[0,1,0],[1,0,0]]
-  let m4 = [[4,3],[2,5]]
-  let m5 = [[2,5],[4,3]]
-  let m6 = [[4,4],[2,2]]
-  mapM_ result [m1,m2,m3,m4,m5,m6]
+main :: IO ()
+main =
+  mapM_
+    (putStrLn . result)
+    [ [[5]]
+    , [[1, 0, 0], [0, 1, 0], [0, 0, 1]]
+    , [[0, 0, 1], [0, 1, 0], [1, 0, 0]]
+    , [[4, 3], [2, 5]]
+    , [[2, 5], [4, 3]]
+    , [[4, 4], [2, 2]]
+    ]

Task/Matrix-arithmetic/Kotlin/matrix-arithmetic.kotlin

@@ -0,0 +1,87 @@
+// version 1.1.2
+
+typealias Matrix = Array<DoubleArray>
+
+fun johnsonTrotter(n: Int): Pair<List<IntArray>, List<Int>> {
+    val p = IntArray(n) { it }  // permutation
+    val q = IntArray(n) { it }  // inverse permutation
+    val d = IntArray(n) { -1 }  // direction = 1 or -1
+    var sign = 1
+    val perms = mutableListOf<IntArray>()
+    val signs = mutableListOf<Int>()
+
+    fun permute(k: Int) {
+        if (k >= n) {
+            perms.add(p.copyOf())
+            signs.add(sign)
+            sign *= -1
+            return
+        }
+        permute(k + 1)
+        for (i in 0 until k) {
+            val z = p[q[k] + d[k]]
+            p[q[k]] = z
+            p[q[k] + d[k]] = k
+            q[z] = q[k]
+            q[k] += d[k]
+            permute(k + 1)
+        }
+        d[k] *= -1
+    }
+
+    permute(0)
+    return perms to signs
+}
+
+fun determinant(m: Matrix): Double {
+    val (sigmas, signs) = johnsonTrotter(m.size)
+    var sum = 0.0
+    for ((i, sigma) in sigmas.withIndex()) {
+        var prod = 1.0
+        for ((j, s) in sigma.withIndex()) prod *= m[j][s]
+        sum += signs[i] * prod
+    }
+    return sum
+}
+
+fun permanent(m: Matrix) : Double {
+    val (sigmas, _) = johnsonTrotter(m.size)
+    var sum = 0.0
+    for (sigma in sigmas) {
+        var prod = 1.0
+        for ((i, s) in sigma.withIndex()) prod *= m[i][s]
+        sum += prod
+    }
+    return sum
+}
+
+fun main(args: Array<String>) {
+    val m1 = arrayOf(
+        doubleArrayOf(1.0)
+    )
+
+    val m2 = arrayOf(
+        doubleArrayOf(1.0, 2.0),
+        doubleArrayOf(3.0, 4.0)
+    )
+
+    val m3 = arrayOf(
+        doubleArrayOf(2.0, 9.0, 4.0),
+        doubleArrayOf(7.0, 5.0, 3.0),
+        doubleArrayOf(6.0, 1.0, 8.0)
+    )
+
+    val m4 = arrayOf(
+        doubleArrayOf( 1.0,  2.0,  3.0,  4.0),
+        doubleArrayOf( 4.0,  5.0,  6.0,  7.0),
+        doubleArrayOf( 7.0,  8.0,  9.0, 10.0),
+        doubleArrayOf(10.0, 11.0, 12.0, 13.0)
+    )
+
+    val matrices = arrayOf(m1, m2, m3, m4)
+    for (m in matrices) {
+        println("m${m.size} -> ")
+        println("  determinant = ${determinant(m)}")
+        println("  permanent   = ${permanent(m)}\n")
+    }
+}

Task/Matrix-arithmetic/PARI-GP/matrix-arithmetic-4.pari

@@ -0,0 +1 @@
+matpermanent(M)

Task/Matrix-arithmetic/Phix/matrix-arithmetic.phix

@@ -0,0 +1,88 @@
+function minor(sequence a, integer x, integer y)
+integer l = length(a)-1
+sequence result = repeat(repeat(0,l),l)
+    for i=1 to l do
+        for j=1 to l do
+            result[i][j] = a[i+(i>=x)][j+(j>=y)]
+        end for
+    end for
+    return result
+end function
+
+function det(sequence a)
+    if length(a)=1 then
+        return a[1][1]
+    end if
+    integer sgn = 1
+    integer res = 0
+    for i=1 to length(a) do
+        res += sgn*a[1][i]*det(minor(a,1,i))
+        sgn *= -1
+    end for
+    return res
+end function
+
+function perm(sequence a)
+    if length(a)=1 then
+        return a[1][1]
+    end if
+    integer res = 0
+    for i=1 to length(a) do
+        res += a[1][i]*perm(minor(a,1,i))
+    end for
+    return res
+end function
+
+constant tests = {
+{{1,  2},
+ {3,  4}},
+--Determinant: -2, permanent: 10
+{{2, 9, 4},
+ {7, 5, 3},
+ {6, 1, 8}},
+--Determinant: -360, permanent: 900
+{{ 1,  2,  3,  4},
+ { 4,  5,  6,  7},
+ { 7,  8,  9, 10},
+ {10, 11, 12, 13}},
+--Determinant: 0, permanent: 29556
+{{ 0,  1,  2,  3,  4},
+ { 5,  6,  7,  8,  9},
+ {10, 11, 12, 13, 14},
+ {15, 16, 17, 18, 19},
+ {20, 21, 22, 23, 24}},
+--Determinant: 0, permanent: 6778800
+{{5}},
+--Determinant: 5, permanent: 5
+{{1,0,0},
+ {0,1,0},
+ {0,0,1}},
+--Determinant: 1, permanent: 1
+{{0,0,1},
+ {0,1,0},
+ {1,0,0}},
+--Determinant: -1, Permanent: 1
+{{4,3},
+ {2,5}},
+--Determinant: 14, Permanent: 26
+{{2,5},
+ {4,3}},
+--Determinant: -14, Permanent: 26
+{{4,4},
+ {2,2}},
+--Determinant: 0, Permanent: 16
+{{7,    2,      -2,     4},
+ {4,    4,      1,      7},
+ {11,   -8,     9,      10},
+ {10,   5,      12,     13}},
+--det:  -4319   permanent:      10723
+
+{{-2,   2,      -3},
+ {-1,   1,      3},
+ {2 ,   0,      -1}}
+--det:  18      permanent:      10
+}
+for i=1 to length(tests) do
+    sequence ti = tests[i]
+    ?{det(ti),perm(ti)}
+end for

Task/Matrix-arithmetic/Simula/matrix-arithmetic.simula

@@ -0,0 +1,99 @@
+! MATRIX ARITHMETIC ;
+BEGIN
+
+    INTEGER PROCEDURE LENGTH(A); REAL ARRAY A;
+        LENGTH := UPPERBOUND(A, 1) - LOWERBOUND(A, 1) + 1;
+
+    PROCEDURE MINOR(A, X, Y, MAT); REAL ARRAY A, MAT; INTEGER X, Y;
+    BEGIN
+        INTEGER I, J, M; M := LENGTH(A) - 1;
+        FOR I := 1 STEP 1 UNTIL M DO
+            FOR J := 1 STEP 1 UNTIL M DO
+            BEGIN
+                IF I < X AND J < Y THEN
+                    MAT(I, J) := A(I, J)
+                ELSE IF I >= X AND J < Y THEN
+                    MAT(I, J) := A(I + 1, J)
+                ELSE IF I < X AND J >= Y THEN
+                    MAT(I, J) := A(I, J + 1)
+                ELSE ! I > X AND J > Y ;
+                    MAT(I, J) := A(I + 1, J + 1)
+            END
+    END MINOR;
+
+    REAL PROCEDURE DET(A); REAL ARRAY A;
+    BEGIN
+        INTEGER N; N := LENGTH(A);
+        IF N = 1 THEN
+            DET := A(1, 1)
+        ELSE
+        BEGIN
+            INTEGER I, SIGN;
+            REAL SUM;
+            SIGN := 1;
+            FOR I := 1 STEP 1 UNTIL N DO
+            BEGIN
+                REAL ARRAY MAT(1:N-1, 1:N-1);
+                MINOR(A, 1, I, MAT);
+                SUM := SUM + SIGN * A(1, I) * DET(MAT);
+                SIGN := SIGN * -1
+            END;
+            DET := SUM
+        END
+    END DET;
+
+    REAL PROCEDURE PERM(A); REAL ARRAY A;
+    BEGIN
+        INTEGER N; N := LENGTH(A);
+        IF N = 1 THEN
+            PERM := A(1, 1)
+        ELSE
+        BEGIN
+            REAL SUM;
+            INTEGER I;
+
+            FOR I := 1 STEP 1 UNTIL N DO
+            BEGIN
+                REAL ARRAY MAT(1:N-1, 1:N-1);
+                MINOR(A, 1, I, MAT);
+                SUM := SUM  + A(1, I) * PERM(MAT)
+            END;
+            PERM := SUM
+        END
+    END PERM;
+
+    INTEGER SIZE;
+    SIZE := ININT;
+    BEGIN
+        REAL ARRAY A(1:SIZE, 1:SIZE);
+        INTEGER I, J;
+
+        FOR I := 1 STEP 1 UNTIL SIZE DO
+            FOR J := 1 STEP 1 UNTIL SIZE DO
+                A(I, J) := INREAL;
+
+        OUTTEXT("DETERMINANT ... : "); OUTREAL(DET (A), 10, 20); OUTIMAGE;
+        OUTTEXT("PERMANENT ..... : "); OUTREAL(PERM(A), 10, 20); OUTIMAGE;
+    END
+
+    ! NOTE THAT THE FIRST INPUT IS THE SIZE OF THE MATRIX.
+    ! FOR EXAMPLE:
+
+    COMMENT
+    ! 2
+    ! 1 2
+    ! 3 4
+    ! DETERMINANT: -2.0
+    ! PERMANENT: 10.0 ;
+
+    COMMENT
+    ! 5
+    ! 0 1 2 3 4
+    ! 5 6 7 8 9
+    ! 10 11 12 13 14
+    ! 15 16 17 18 19
+    ! 20 21 22 23 24
+    ! DETERMINANT: 0.0
+    ! PERMANENT: 6778800.0 ;
+
+END

Task/Matrix-arithmetic/Zkl/matrix-arithmetic-1.zkl

@@ -0,0 +1,11 @@
+var [const] GSL=Import("zklGSL");	// libGSL (GNU Scientific Library)
+fcn perm(A){  // should verify A is square
+   numRows:=A.rows;
+   Utils.Helpers.permute(numRows.toList()).reduce(  // permute(0,1,..numRows)
+      'wrap(s,pm){ s + numRows.reduce('wrap(x,i){ x*A[i,pm[i]] },1.0) },
+      0.0)
+}
+test:=fcn(A){
+   println(A.format());
+   println("Permanent: %.2f, determinant: %.2f".fmt(perm(A),A.det()));
+};

Task/Matrix-arithmetic/Zkl/matrix-arithmetic-2.zkl

@@ -0,0 +1,5 @@
+A:=GSL.Matrix(2,2).set(1,2, 3,4);
+B:=GSL.Matrix(4,4).set(1,2,3,4, 4,5,6,7, 7,8,9,10, 10,11,12,13);
+C:=GSL.Matrix(5,5).set( 0, 1, 2, 3, 4,  5, 6, 7, 8, 9, 10,11,12,13,14,
+		       15,16,17,18,19, 20,21,22,23,24);
+T(A,B,C).apply2(test);