From 4350bcbfcdc39b8bee3ca3ddcbba8904eec39caf Mon Sep 17 00:00:00 2001 From: Cat Stevens Date: Sun, 4 Feb 2018 00:00:21 -0500 Subject: [PATCH 01/22] math.matrices: rewrite, modernize and overhaul math.matrices.elimination: move to extra math.matrices.extras: expand with esoteric, less-used and unfinished code from basis - math.matrices and .extras receive more words, tests, and docs - matrix has become a predicate class - 94% of matrices words have complete docs - 77% of matrices.extras words have complete docs - much more consistent naming for constructors etc - added missing words / features such as main-diagonal and anti-transpose - optimizations - lots of documentation --- .../compression/run-length/run-length.factor | 4 +- basis/math/matrices/authors.txt | 3 + basis/math/matrices/matrices-docs.factor | 1204 ++++++++++++++++- basis/math/matrices/matrices-tests.factor | 982 +++++++++----- basis/math/matrices/matrices.factor | 472 ++++--- basis/math/vectors/vectors-docs.factor | 4 +- basis/math/vectors/vectors-tests.factor | 8 + basis/math/vectors/vectors.factor | 16 + .../3d-matrix-scalar/3d-matrix-scalar.factor | 12 +- .../3d-matrix-vector/3d-matrix-vector.factor | 5 +- .../matrix-exponential-scalar.factor | 4 +- extra/game/debug/tests/tests.factor | 7 +- extra/gml/geometry/geometry.factor | 6 +- extra/gpu/demos/raytrace/raytrace.factor | 8 +- extra/gpu/util/wasd/wasd.factor | 18 +- .../math/matrices/elimination/authors.txt | 0 .../elimination/elimination-docs.factor | 5 +- .../elimination/elimination-tests.factor | 0 .../matrices/elimination/elimination.factor | 4 +- .../math/matrices/elimination/summary.txt | 0 extra/math/matrices/extras/authors.txt | 4 + extra/math/matrices/extras/extras-docs.factor | 641 +++++++++ .../math/matrices/extras/extras-tests.factor | 362 +++++ extra/math/matrices/extras/extras.factor | 338 +++++ extra/math/matrices/extras/summary.txt | 1 + extra/rosetta-code/bitmap/bitmap.factor | 2 +- .../conjugate-transpose.factor | 2 +- 27 files changed, 3462 insertions(+), 650 deletions(-) rename {basis => extra}/math/matrices/elimination/authors.txt (100%) rename {basis => extra}/math/matrices/elimination/elimination-docs.factor (86%) rename {basis => extra}/math/matrices/elimination/elimination-tests.factor (100%) rename {basis => extra}/math/matrices/elimination/elimination.factor (96%) rename {basis => extra}/math/matrices/elimination/summary.txt (100%) create mode 100644 extra/math/matrices/extras/authors.txt create mode 100644 extra/math/matrices/extras/extras-docs.factor create mode 100644 extra/math/matrices/extras/extras-tests.factor create mode 100644 extra/math/matrices/extras/extras.factor create mode 100644 extra/math/matrices/extras/summary.txt diff --git a/basis/compression/run-length/run-length.factor b/basis/compression/run-length/run-length.factor index 8faaaffc1e..401024ffce 100644 --- a/basis/compression/run-length/run-length.factor +++ b/basis/compression/run-length/run-length.factor @@ -13,7 +13,7 @@ IN: compression.run-length :: run-length-uncompress-bitmap4 ( byte-array m n -- byte-array' ) byte-array :> sp - m 1 + n zero-matrix :> matrix + m 1 + n :> matrix n 4 mod n + :> stride 0 :> i! 0 :> j! @@ -45,7 +45,7 @@ IN: compression.run-length :: run-length-uncompress-bitmap8 ( byte-array m n -- byte-array' ) byte-array :> sp - m 1 + n zero-matrix :> matrix + m 1 + n :> matrix n 4 mod n + :> stride 0 :> i! 0 :> j! diff --git a/basis/math/matrices/authors.txt b/basis/math/matrices/authors.txt index 1901f27a24..26ec2689aa 100644 --- a/basis/math/matrices/authors.txt +++ b/basis/math/matrices/authors.txt @@ -1 +1,4 @@ Slava Pestov +Joe Groff +Doug Coleman +Cat Stevens diff --git a/basis/math/matrices/matrices-docs.factor b/basis/math/matrices/matrices-docs.factor index 2242715c93..e7832d73a1 100644 --- a/basis/math/matrices/matrices-docs.factor +++ b/basis/math/matrices/matrices-docs.factor @@ -1,76 +1,1174 @@ -USING: help.markup help.syntax math sequences ; +! Copyright (C) 2005, 2010, 2018 Slava Pestov, Joe Groff, and Cat Stevens. +USING: accessors arrays assocs generic.single formatting locals help.markup help.markup.private help.syntax io +kernel math math.functions math.order math.ratios math.vectors opengl.gl prettyprint +sequences sequences.generalizations urls ; IN: math.matrices -HELP: zero-matrix -{ $values { "m" integer } { "n" integer } { "matrix" sequence } } -{ $description "Creates a matrix of size " { $snippet "m x n" } ", filled with zeroes." } ; + which have an array of inputs +: $finite-input-note ( children -- ) + [ "Only the first " ] dip + first2 + " values in " swap + [ { $snippet } ] dip suffix + " are used." + 5 narray print-element ; + +! a note for when a word assumes a 2d matrix +: $2d-only-note ( children -- ) + drop { "This word is intended for use with \"flat\" (2-dimensional) matrices. " + ! "Using it with matrices of 3 or more dimensions may lead to unexpected results." + } + print-element ; + +! a note for numeric-specific operations +: $matrix-scalar-note ( children -- ) + \ $subs-nobl prefix + "This word assumes that elements of the input matrix are compatible with the following words:" + swap 2array + print-element ; + +: $keep-shape-note ( children -- ) + drop { "The shape of the input matrix is preserved in the output." } print-element ; + +: $link2 ( children -- ) + first2 swap [ write-link ] topic-span ; + +! so that we don't end up with multiple $notes calls leading to multiple Notes sections +: $notelist ( children -- ) + \ $list prefix $notes ; +PRIVATE> + +ABOUT: "math.matrices" + +ARTICLE: "math.matrices" "Matrix operations" + +"The " { $vocab-link "math.matrices" } " vocabulary implements many ways of working with " { $emphasis "matrices" } " — sequences which have a minimum of 2 dimensions. Operations on 1-dimensional numeric vectors are implemented in " { $vocab-link "math.vectors" } ", upon which this vocabulary relies." +$nl +"In this vocabulary's documentation, " { $snippet "m" } " and " { $snippet "matrix" } " are the conventional names used for a given matrix object. " { $snippet "m" } " may also refer to a number." +$nl +"The " { $vocab-link "math.matrices.extras" } "vocabulary implements extensions to this one." +$nl +"Matrices are classified their mathematical properties, and by predicate words:" +$nl +! split up intentionally +{ $subsections + matrix + irregular-matrix + square-matrix + zero-matrix + zero-square-matrix + null-matrix + +} { $subsections + matrix? + irregular-matrix? + square-matrix? + zero-matrix? + zero-square-matrix? + null-matrix? + +} + +"There are many ways to create 2-dimensional matrices:" +{ $subsections + + + + +} { $subsections + + + + + + + + +} { $subsections + + + + + + +} + +"By-element mathematical operations on a matrix:" +{ $subsections mneg m+n m-n m*n m/n n+m n-m n*m n/m } + +"By-element mathematical operations of two matricess:" +{ $subsections m+ m- m* m/ m~ } + +"Dot product (multiplication) of vectors and matrices:" +{ $subsections v.m m.v m. } + +"Transformations and elements of matrices:" +{ $subsections + dimension + transpose anti-transpose + matrix-nth matrix-nths + matrix-set-nth matrix-set-nths + +} { $subsections + row rows rows-except + col cols cols-except + +} { $subsections + matrix-except matrix-except-all + +} { $subsections + matrix-map column-map stitch + +} { $subsections + main-diagonal + anti-diagonal -HELP: m.v -{ $values { "m" sequence } { "v" sequence } } -{ $description "Computes the dot product between a matrix and a vector." } -{ $examples - { $example - "USING: math.matrices prettyprint ;" - "{ { 1 -1 2 } { 0 -3 1 } } { 2 1 0 } m.v ." - "{ 1 -3 }" - } } ; -HELP: m. -{ $values { "m" sequence } } -{ $description "Computes the dot product between two matrices, i.e multiplies them." } +! PREDICATE CLASSES + +HELP: matrix +{ $class-description "The class of regular, rectangular matrices. In mathematics and linear algebra, a matrix is a rectangular collection of scalar elements for the purpose of the uniform application of algorithms." } +{ $notes "In Factor, any sequence with two or more dimensions (one or more layers of subsequences) can be a " { $link matrix } ", and the elements may be any " { $link object } "." +$nl "A regular matrix is a sequence with two or more dimensions, whose subsequences are all of equal length. See " { $link regular-matrix? } "." } +$nl "Irregular matrices are classified by " { $link irregular-matrix } "." ; + +HELP: irregular-matrix +{ $class-description "The most common matrix, and most easily manipulated by this vocabulary, is rectangular. This predicate classifies irregular (non-rectangular) matrices." } ; + +HELP: square-matrix +{ $class-description "The class of square matrices. A square matrix is a " { $link matrix } " which has the same number of rows and columns. In other words, its outermost two dimensions are of equal size." } ; + +HELP: zero-matrix +{ $class-description "The class of zero matrices. A zero matrix is a matrix whose only elements are the scalar " { $snippet "0" } "." } +{ $notes "In mathematics, a zero-filled matrix is called a null matrix. In Factor, a "{ $link null-matrix } " is an empty matrix." } ; + +HELP: zero-square-matrix +{ $class-description "The class of square zero matrices. This predicate is a composition of " { $link zero-matrix } " and " { $link square-matrix } "." } ; + +HELP: null-matrix +{ $class-description "The class of null matrices. A null matrix is an empty sequence, or a sequence which consists only of empty sequences." } +{ $notes "In mathematics, a null matrix is a matrix full of zeroes. In Factor, such a matrix is called a " { $link zero-matrix } "." } ; + +{ matrix irregular-matrix square-matrix zero-matrix null-matrix zero-square-matrix null-matrix } related-words + +! NON-PREDICATE TESTS + +HELP: regular-matrix? +{ $values { "object" object } { "?" boolean } } +{ $description "Tests if the object is a regular (well-formed, rectangular, etc) " { $link matrix } ". A regular matrix is a sequence with an equal number of elements in every row, and an equal number of elements in every column, such that there are no empty slots." } +{ $notes "The " { $link null-matrix } " is considered regular, because of semantic requirements of the matrix implementation." } { $examples - { $example - "USING: math.matrices prettyprint ;" - "{ { 1 -1 2 } { 0 -3 1 } } { { 3 7 } { 9 12 } } m. ." - "{ { -6 -5 } { -27 -36 } }" - } + "The example is an irregular matrix, because the rows have an unequal number of elements." + { $example + "USING: math.matrices prettyprint ;" + "{ { 1 } { } } regular-matrix? ." + "f" + } + "The example is a regular matrix, because the rows have an equal number of elements." + { $example + "USING: math.matrices prettyprint ;" + "{ { 1 } { 2 } } regular-matrix? ." + "t" + } +} ; + +! BUILDERS +HELP: +{ $values { "m" integer } { "n" integer } { "element" object } { "matrix" matrix } } +{ $description "Creates a matrix of size " { $snippet "m x n" } ", filled with " { $snippet "element" } "." } +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "3 2 10 ." + "{ { 10 10 } { 10 10 } { 10 10 } }" + } + { $example + "USING: math.matrices prettyprint ;" + "4 1 \"¢\" ." + "{ { \"¢\" } { \"¢\" } { \"¢\" } { \"¢\" } }" + } +} ; + +HELP: +{ $values { "m" integer } { "n" integer } { "quot" { $quotation ( ... -- elt ) } } { "matrix" matrix } } +{ $description "Creates a matrix of size " { $snippet "m x n" } " using elements given by " { $snippet "quot" } ", a quotation called to create each element." } +{ $notes "The following are equivalent:" + { $code "m n [ 2drop foo ] " } + { $code "m n [ foo ] " } +} +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "4 5 [ 5 ] ." + "{ { 5 5 5 5 5 } { 5 5 5 5 5 } { 5 5 5 5 5 } { 5 5 5 5 5 } }" + } +} ; + +HELP: +{ $values { "m" integer } { "n" integer } { "quot" { $quotation ( ... m' n' -- ... elt ) } } { "matrix" matrix } } +{ $description "Creates an " { $snippet "m x n" } " " { $link matrix } " using elements given by " { $snippet "quot" } " . This word differs from " { $link } " in that the indices are placed on the stack (in the same order) before " { $snippet "quot" } " runs. The output of the quotation will be the element at the given position in the matrix." } +{ $notes "The following are equivalent:" + { $code "m n [ 2drop foo ] " } + { $code "m n [ foo ] " } +} +{ $examples + { $example + "USING: math math.matrices prettyprint ;" + "3 4 [ * ] ." + "{ { 0 0 0 0 } { 0 1 2 3 } { 0 2 4 6 } }" + } +} ; + +HELP: +{ $values { "m" integer } { "n" integer } { "matrix" matrix } } +{ $description "Creates a matrix of size " { $snippet "m x n" } ", filled with zeroes." } +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "2 3 ." + "{ { 0 0 0 } { 0 0 0 } }" + } +} ; + +HELP: +{ $values { "n" integer } { "matrix" matrix } } +{ $description "Creates a matrix of size " { $snippet "n x n" } ", filled with zeroes. Shorthand for " { $code "n n " } "." } +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "2 ." + "{ { 0 0 } { 0 0 } }" + } +} ; + +HELP: +{ $values { "diagonal-seq" sequence } { "matrix" matrix } } +{ $description "Creates a matrix with the specified main diagonal. This word has the opposite effect of " { $link anti-diagonal } "." } +{ $notes "To use a diagonal starting in the lower right, reverse the input sequence before calling this word." } +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "{ 1 2 3 } ." + "{ { 1 0 0 } { 0 2 0 } { 0 0 3 } }" + } +} ; + +HELP: +{ $values { "diagonal-seq" sequence } { "matrix" matrix } } +{ $description "Creates a matrix with the specified anti-diagonal. This word has the opposite effect of " { $link main-diagonal } "." } +{ $notes "To use a diagonal starting in the lower left, reverse the input sequence before calling this word." } +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "{ 1 2 3 } ." + "{ { 0 0 1 } { 0 2 0 } { 3 0 0 } }" + } +} ; + +HELP: +{ $values { "n" integer } { "matrix" matrix } } +{ $description "Creates an " { $url URL" http://enwp.org/Identity_matrix" "identity matrix" } " of size " { $snippet "n x n" } ", where the diagonal values are all ones." } +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "4 ." + "{ { 1 0 0 0 } { 0 1 0 0 } { 0 0 1 0 } { 0 0 0 1 } }" + } +} ; + +HELP: +{ $values { "m" integer } { "n" integer } { "k" integer } { "z" object } { "matrix" matrix } } +{ $description "Creates an " { $snippet "m x n" } " matrix with a diagonal of " { $snippet "z" } " offset by " { $snippet "k" } " from the main diagonal. A positive value of " { $snippet "k" } " gives a diagonal above the main diagonal, whereas a negative value of " { $snippet "k" } " gives a diagonal below the main diagonal." } +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "5 6 0 4 ." + "{ + { 4 0 0 0 0 0 } + { 0 4 0 0 0 0 } + { 0 0 4 0 0 0 } + { 0 0 0 4 0 0 } + { 0 0 0 0 4 0 } +}" + } + { $example + "USING: math.matrices prettyprint ;" + "5 5 2 2 ." + "{ + { 0 0 2 0 0 } + { 0 0 0 2 0 } + { 0 0 0 0 2 } + { 0 0 0 0 0 } + { 0 0 0 0 0 } +}" + } +} ; + +HELP: +{ $values { "m" integer } { "n" integer } { "k" integer } { "matrix" matrix } } +{ $description + "Creates an " { $snippet "m x n" } " matrix with a diagonal of ones offset by " { $snippet "k" } " from the main diagonal." + "The following are equivalent for any " { $snippet "m n k" } ":" { $code "m n k 1 " } { $code "m n k " } + $nl + "Specify a different diagonal value with " { $link } "." +} +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "4 5 2 ." + "{ { 0 0 1 0 0 } { 0 0 0 1 0 } { 0 0 0 0 1 } { 0 0 0 0 0 } }" + } +} ; + +HELP: +{ $values { "dim" pair } { "coordinates" matrix } } +{ $description "Create a matrix in which each element is its own coordinate pair, also called a " { $link cartesian-product } "." } +{ $notelist + { $equiv-word-note "non-square" } + { $finite-input-note "two" "dim" } +} +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "{ 2 4 } ." +"{ + { { 0 0 } { 0 1 } { 0 2 } { 0 3 } } + { { 1 0 } { 1 1 } { 1 2 } { 1 3 } } +}" + } +} ; + +HELP: +{ $values { "dim" pair } { "coordinates" matrix } } +{ $description "An alias for " { $link } " which serves as the logical non-square companion to " { $link } "." } +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "{ 2 4 } ." +"{ + { { 0 0 } { 0 1 } { 0 2 } { 0 3 } } + { { 1 0 } { 1 1 } { 1 2 } { 1 3 } } +}" + } +} ; + +HELP: +{ $values { "n" integer } { "matrix" square-matrix } } +{ $description "Create a " { $link square-matrix } " full of " { $link cartesian-product } "s. See " { $url URL" https://en.wikipedia.org/wiki/Cartesian_product" "cartesian product" } "." } +{ $notes + { $equiv-word-note "square" } +} +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "1 ." + "{ { { 0 0 } } }" + } + { $example + "USING: math.matrices prettyprint ;" + "3 ." +"{ + { { 0 0 } { 0 1 } { 0 2 } } + { { 1 0 } { 1 1 } { 1 2 } } + { { 2 0 } { 2 1 } { 2 2 } } +}" + } +} ; + +HELP: +{ $values { "desc" { $or sequence integer matrix } } { "matrix" matrix } } +{ $contract "Generate a " { $link square-matrix } " from a descriptor." } +{ $description "If the descriptor is an " { $link integer } ", it is used to generate square rows within that range." $nl "If it is a 1-dimensional sequence, it is " { $link replicate } "d to create each row." $nl "If it is a " { $link matrix } ", it is cropped into a " { $link square-matrix } "." $nl "If it is a " { $link square-matrix } ", it is returned unchanged." } +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "3 ." + "{ { 0 1 2 } { 0 1 2 } { 0 1 2 } }" + } + { $example + "USING: math.matrices prettyprint ;" + "{ 2 3 5 } ." + "{ { 2 3 5 } { 2 3 5 } { 2 3 5 } }" + } +} ; + +HELP: +{ $values { "desc" { $or sequence integer matrix } } { "matrix" matrix } } +{ $contract "Generate a " { $link square-matrix } " from a descriptor." } +{ $description "If the descriptor is an " { $link integer } ", it is used to generate square columns within that range." $nl "If it is a 1-dimensional sequence, it is " { $link replicate } "d to create each column." $nl "If it is a " { $link matrix } ", it is cropped into a " { $link square-matrix } "." $nl "If it is a " { $link square-matrix } ", it is returned unchanged." } +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "3 ." + "{ { 0 0 0 } { 1 1 1 } { 2 2 2 } }" + } + { $example + "USING: math.matrices prettyprint ;" + "{ 2 3 5 } ." + "{ { 2 2 2 } { 3 3 3 } { 5 5 5 } }" + } +} ; + +HELP: +{ $values { "object" object } { "m" integer } { "n" integer } { "matrix" matrix } } +{ $description "Make a lower triangular matrix, where all the values above the main diagonal are " { $snippet "0" } ". " { $snippet "object" } " will be used as the value for the nonzero part of the matrix, while " { $snippet "m" } " and " { $snippet "n" } " are used as the dimensions. The inverse of this word is " { $link } ". See " { $url URL" https://en.wikipedia.org/wiki/Triangular_matrix" "triangular matrix" } "." } +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "1 5 5 ." +"{ + { 1 0 0 0 0 } + { 1 1 0 0 0 } + { 1 1 1 0 0 } + { 1 1 1 1 0 } + { 1 1 1 1 1 } +}" + } +} ; + +HELP: +{ $values { "object" object } { "m" integer } { "n" integer } { "matrix" matrix } } +{ $description "Make an upper triangular matrix, where all the values below the main diagonal are " { $snippet "0" } ". " { $snippet "object" } " will be used as the value for the nonzero part of the matrix, while " { $snippet "m" } " and " { $snippet "n" } " are used as the dimensions. The inverse of this word is " { $link } ". See " { $url URL" https://en.wikipedia.org/wiki/Triangular_matrix" "triangular matrix" } "." } +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "1 5 5 ." +"{ + { 1 1 1 1 1 } + { 0 1 1 1 1 } + { 0 0 1 1 1 } + { 0 0 0 1 1 } + { 0 0 0 0 1 } +}" + } +} ; + +HELP: stitch +{ $values { "m" matrix } { "m'" matrix } } +{ $description "Folds an " { $snippet "n>2" } "-dimensional matrix onto itself." } +{ $examples + { $unchecked-example + "USING: math.matrices prettyprint ;" +"{ + { { 0 5 } { 6 7 } { 0 15 } { 18 21 } } + { { 0 10 } { 12 14 } { 0 20 } { 24 28 } } +} stitch ." +"{ + { 0 5 0 10 } + { 6 7 12 14 } + { 0 15 0 20 } + { 18 21 24 28 } +}" + } +} ; + +HELP: row +{ $values { "n" integer } { "matrix" matrix } { "row" sequence } } +{ $description "Get the nth row of the matrix." } +{ $notes "Like most Factor sequences, indexing is 0-based. The first row is given by " { $snippet "m 0 row" } "." } +{ $examples + { $example + "USING: kernel math.matrices prettyprint ;" + "{ { 1 2 } { 3 4 } } 1 swap row ." + "{ 3 4 }" + } +} ; + +HELP: rows +{ $values { "seq" sequence } { "matrix" matrix } { "rows" sequence } } +{ $description "Get the rows from " { $snippet "matrix" } " listed by " { $snippet "seq" } "." } +{ $notelist { $equiv-word-note "multiplexing" row } } +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "{ 0 1 } { { 1 2 } { 3 4 } } rows ." + "{ { 1 2 } { 3 4 } }" + } +} ; + +HELP: col +{ $values { "n" integer } { "matrix" matrix } { "col" sequence } } +{ $description "Get the " { $snippet "n" } "th column of the matrix." } +{ $notes "Like most Factor sequences, indexing is 0-based. The first column is given by " { $snippet "m 0 col" } "." } +{ $examples + { $example + "USING: kernel math.matrices prettyprint ;" + "{ { 1 2 } { 3 4 } } 1 swap col ." + "{ 2 4 }" + } +} ; + +HELP: cols +{ $values { "seq" sequence } { "matrix" matrix } { "cols" sequence } } +{ $description "Get the columns from " { $snippet "matrix" } " listed by " { $snippet "seq" } "." } +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "{ 0 1 } { { 1 2 } { 3 4 } } cols ." + "{ { 1 3 } { 2 4 } }" + } +} ; + +HELP: matrix-map +{ $values { "matrix" matrix } { "quot" { $quotation ( ... elt -- ... elt' ) } } { "matrix'" matrix } } +{ $description "Apply the quotation to every element of the matrix." } +{ $notelist $2d-only-note } +{ $examples + { $example + "USING: math.matrices kernel math prettyprint ;" + "3 [ zero? 15 -8 ? ] matrix-map ." + "{ { -8 15 15 } { 15 -8 15 } { 15 15 -8 } }" + } +} ; + +HELP: column-map +{ $values { "matrix" matrix } { "quot" { $quotation ( ... col -- ... col' ) } } { "matrix'" { $maybe sequence matrix } } } +{ $description "Apply the quotation to every column of the matrix. The output of the quotation must be a sequence." } +{ $notelist $2d-only-note { $equiv-word-note "transpose" map } } +{ $examples + { $example + "USING: sequences math.matrices prettyprint ;" + "3 [ reverse ] column-map ." + "{ { 0 0 1 } { 0 1 0 } { 1 0 0 } }" + } +} ; + +HELP: matrix-nth +{ $values { "pair" pair } { "matrix" matrix } { "elt" object } } +{ $description "Retrieve the element in the matrix at the zero-indexed " { $snippet "row, column" } " pair." } +{ $notelist { $equiv-word-note "two-dimensional" nth } $2d-only-note } +{ $errors { $list + { { $link bounds-error } " if the first element in " { $snippet "pair" } " is greater than the maximum row index in " { $snippet "matrix" } } + { { $link bounds-error } " if the second element in " { $snippet "pair" } " is greater than the maximum column index in " { $snippet "matrix" } } +} } +{ $examples + "Get the entry at row 1, column 0." + { $example + "USING: math.matrices prettyprint ;" + "{ 1 0 } { { 0 1 } { 2 3 } } matrix-nth ." + "2" + } +} ; + +HELP: matrix-nths +{ $values { "pairs" assoc } { "matrix" matrix } { "elts" sequence } } +{ $description "Retrieve all the elements in the matrix at each of the zero-indexed " { $snippet "row, column" } " pairs in " { $snippet "pairs" } "." } +{ $notelist { $equiv-word-note "two-dimensional" nths } $2d-only-note } +{ $errors { $list + { { $link bounds-error } " if the first element of a pair in " { $snippet "pairs" } " is greater than the maximum row index in " { $snippet "matrix" } } + { { $link bounds-error } " if the second element of a pair in " { $snippet "pairs" } " is greater than the maximum column index in " { $snippet "matrix" } } +} } +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "{ { 1 0 } { 1 1 } } { { 0 1 } { 2 3 } } matrix-nths ." + "{ 2 3 }" + } +} ; + +HELP: matrix-set-nth +{ $values { "obj" object } { "pair" pair } { "matrix" matrix } } +{ $description "Set the element in the matrix at the 2D index given by " { $snippet "pair" } " to " { $snippet "obj" } ". This operation is destructive." } +{ $side-effects "matrix" } +{ $notelist { $equiv-word-note "two-dimensional" set-nth } $2d-only-note } +{ $errors { $list + { { $link bounds-error } " if the first element of a pair in " { $snippet "pairs" } " is greater than the maximum row index in " { $snippet "matrix" } } + { { $link bounds-error } " if the second element of a pair in " { $snippet "pairs" } " is greater than the maximum column index in " { $snippet "matrix" } } + "Throws an error if the sequence cannot hold elements of the given type." +} } +{ $examples + "Change the entry at row 1, column 0." + { $example + "USING: math.matrices kernel prettyprint ;" + "{ { 0 1 } { 2 3 } } \"a\" { 1 0 } pick matrix-set-nth ." + "{ { 0 1 } { \"a\" 3 } }" + } +} ; + +HELP: matrix-set-nths +{ $values { "obj" object } { "pairs" assoc } { "matrix" matrix } } +{ $description "Applies " { $link matrix-set-nth } " to " { $snippet "matrix" } " for each " { $snippet "row, column" } " pair in " { $snippet "pairs" } ", setting the elements to " { $snippet "obj" } "." } +{ $side-effects "matrix" } +{ $notelist { $equiv-word-note "multiplexing" matrix-set-nth } $2d-only-note } +{ $errors { $list + { { $link bounds-error } " if the first element of a pair in " { $snippet "pairs" } " is greater than the maximum row index in " { $snippet "matrix" } } + { { $link bounds-error } " if the second element of a pair in " { $snippet "pairs" } " is greater than the maximum column index in " { $snippet "matrix" } } + "Throws an error if the sequence cannot hold elements of the given type." +} } +{ $examples + "Change both entries on row 0." + { $example + "USING: math.matrices kernel prettyprint ;" + "{ { 0 1 } { 2 3 } } \"a\" { { 1 0 } { 1 1 } } pick matrix-set-nths ." + "{ { 0 1 } { \"a\" \"a\" } }" + } +} ; + + +HELP: mneg +{ $values { "m" matrix } { "m'" matrix } } +{ $description "Negate (invert the sign) of every element in the matrix. The resulting matrix is called the " { $emphasis "additive inverse" } " of the input matrix." } +{ $notelist + { $equiv-word-note "companion" mabs } + $2d-only-note + { $matrix-scalar-note neg } +} +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "{ { 5 9 } { 15 -17 } } mneg ." + "{ { -5 -9 } { -15 17 } }" + } +} ; + +HELP: mabs +{ $values { "m" matrix } { "m'" matrix } } +{ $description "Compute the absolute value (" { $link abs } ") of each element in the matrix." } +{ $notelist + { $equiv-word-note "companion" mneg } + $2d-only-note + { $matrix-scalar-note abs } +} +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "{ { -5 -9 } { -15 17 } } mabs ." + "{ { 5 9 } { 15 17 } }" + } +} ; + +HELP: n+m +{ $values { "n" object } { "m" matrix } } +{ $description { $snippet "n" } " is treated as a scalar and added to each element of the matrix " { $snippet "m" } "." } +{ $notelist + { $equiv-word-note "swapped" m+n } + $2d-only-note + { $matrix-scalar-note + } +} +{ $examples + { $example + "USING: kernel math.matrices prettyprint ;" + "1 3 n+m ." + "{ { 2 1 1 } { 1 2 1 } { 1 1 2 } }" + } +} ; + +HELP: m+n +{ $values { "m" matrix } { "n" object } } +{ $description { $snippet "n" } " is treated as a scalar and added to each element of the matrix " { $snippet "m" } "." } +{ $notelist + { $equiv-word-note "swapped" n+m } + $2d-only-note + { $matrix-scalar-note + } +} +{ $examples + { $example + "USING: kernel math.matrices prettyprint ;" + "3 1 m+n ." + "{ { 2 1 1 } { 1 2 1 } { 1 1 2 } }" + } +} ; + +HELP: n-m +{ $values { "n" object } { "m" matrix } } +{ $description { $snippet "n" } " is treated as a scalar and subtracted from each element of the matrix " { $snippet "m" } "." } +{ $notelist + { $equiv-word-note "swapped" m-n } + $2d-only-note + { $matrix-scalar-note - } +} +{ $examples + { $example + "USING: kernel math.matrices prettyprint ;" + "1 3 n-m ." + "{ { 0 1 1 } { 1 0 1 } { 1 1 0 } }" + } +} ; + +HELP: m-n +{ $values { "m" matrix } { "n" object } } +{ $description { $snippet "n" } " is treated as a scalar and subtracted from each element of the matrix " { $snippet "m" } "." } +{ $notelist + { $equiv-word-note "swapped" n-m } + $2d-only-note + { $matrix-scalar-note - } +} +{ $examples + { $example + "USING: kernel math.matrices prettyprint ;" + "3 1 m-n ." + "{ { 0 -1 -1 } { -1 0 -1 } { -1 -1 0 } }" + } +} ; + +HELP: n*m +{ $values { "n" object } { "m" matrix } } +{ $description "Every element in the input matrix " { $snippet "m" } " is multiplied by the scalar "{ $snippet "n" } "." } +{ $notelist + $keep-shape-note + { $equiv-word-note "swapped" m*n } + $2d-only-note + { $matrix-scalar-note * } +} +{ $examples + { $example + "USING: kernel math.matrices prettyprint ;" + "3 3 n*m ." + "{ { 3 0 0 } { 0 3 0 } { 0 0 3 } }" + } +} ; + +HELP: m*n +{ $values { "m" matrix } { "n" object } } +{ $description "Every element in the input matrix " { $snippet "m" } " is multiplied by the scalar "{ $snippet "n" } "." } +{ $notelist + $keep-shape-note + { $equiv-word-note "swapped" n*m } + $2d-only-note + { $matrix-scalar-note * } +} + +{ $examples + { $example + "USING: kernel math.matrices prettyprint ;" + "3 3 m*n ." + "{ { 3 0 0 } { 0 3 0 } { 0 0 3 } }" + } +} ; + +HELP: n/m +{ $values { "n" object } { "m" matrix } } +{ $description "Every element in the input matrix " { $snippet "m" } " is divided by the scalar "{ $snippet "n" } "." } +{ $notelist + $keep-shape-note + { $equiv-word-note "swapped" m/n } + $2d-only-note + { $matrix-scalar-note / } +} +{ $examples + { $example + "USING: kernel math.matrices prettyprint ;" + "2 { { 4 5 } { 2 1 } } n/m ." + "{ { 1/2 2/5 } { 1 2 } }" + } +} ; + +HELP: m/n +{ $values { "m" matrix } { "n" object } } +{ $description "Every element in the input matrix " { $snippet "m" } " is divided by the scalar "{ $snippet "n" } "." } +{ $notelist + $keep-shape-note + { $equiv-word-note "swapped" n/m } + $2d-only-note + { $matrix-scalar-note / } +} +{ $examples + { $example + "USING: kernel math.matrices prettyprint ;" + "{ { 4 5 } { 2 1 } } 2 m/n ." + "{ { 2 2+1/2 } { 1 1/2 } }" + } } ; HELP: m+ -{ $values { "m" sequence } } -{ $description "Adds the matrices component-wise." } +{ $values { "m1" matrix } { "m2" matrix } { "m" matrix } } +{ $description "Adds two matrices element-wise." } +{ $notelist + $2d-only-note + { $matrix-scalar-note + } +} { $examples - { $example - "USING: math.matrices prettyprint ;" - "{ { 1 2 } { 3 4 } } { { 5 6 } { 7 8 } } m+ ." - "{ { 6 8 } { 10 12 } }" - } + { $example + "USING: math.matrices prettyprint ;" + "{ { 1 2 3 } { 3 2 1 } } { { 4 5 6 } { 6 5 4 } } m+ ." + "{ { 5 7 9 } { 9 7 5 } }" + } } ; HELP: m- -{ $values { "m" sequence } } -{ $description "Subtracts the matrices component-wise." } +{ $values { "m1" matrix } { "m2" matrix } { "m" matrix } } +{ $description "Subtracts two matrices element-wise." } +{ $notelist + $2d-only-note + { $matrix-scalar-note - } +} { $examples - { $example - "USING: math.matrices prettyprint ;" - "{ { 5 9 } { 15 17 } } { { 3 2 } { 4 9 } } m- ." - "{ { 2 7 } { 11 8 } }" - } + { $example + "USING: math.matrices prettyprint ;" + "{ { 4 5 6 } { 6 5 4 } } { { 1 2 3 } { 3 2 1 } } m- ." + "{ { 3 3 3 } { 3 3 3 } }" + } } ; -HELP: kron -{ $values { "m1" sequence } { "m2" sequence } { "m" sequence } } -{ $description "Calculates the Kronecker product of two matrices." } +HELP: m* +{ $values { "m1" matrix } { "m2" matrix } { "m" matrix } } +{ $description "Multiplies two matrices element-wise." } +{ $notelist + $2d-only-note + { $matrix-scalar-note * } +} { $examples - { $example "USING: math.matrices prettyprint ;" - "{ { 1 2 } { 3 4 } } { { 0 5 } { 6 7 } } kron ." - "{ { 0 5 0 10 } { 6 7 12 14 } { 0 15 0 20 } { 18 21 24 28 } }" } + { $example + "USING: math.matrices prettyprint ;" + "{ { 5 9 } { 15 17 } } { { 3 2 } { 4 9 } } m* ." + "{ { 15 18 } { 60 153 } }" + } } ; -HELP: outer -{ $values { "u" sequence } { "v" sequence } { "m" sequence } } -{ $description "Computers the outer product of " { $snippet "u" } " and " { $snippet "v" } "." } +HELP: m/ +{ $values { "m1" matrix } { "m2" matrix } { "m" matrix } } +{ $description "Divides two matrices element-wise." } +{ $notelist + $2d-only-note + { $matrix-scalar-note / } +} { $examples - { $example "USING: math.matrices prettyprint ;" - "{ 5 6 7 } { 1 2 3 } outer ." - "{ { 5 10 15 } { 6 12 18 } { 7 14 21 } }" } + { $example + "USING: math.matrices prettyprint ;" + "{ { 5 9 } { 15 17 } } { { 3 2 } { 4 9 } } m/ ." + "{ { 1+2/3 4+1/2 } { 3+3/4 1+8/9 } }" + } +} ; + +HELP: m.v +{ $values { "m" matrix } { "v" sequence } { "p" matrix } } +{ $description "Computes the dot product of a matrix and a vector." } +{ $notelist + { $equiv-word-note "swapped" v.m } + $2d-only-note + { $matrix-scalar-note * + } +} +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "{ { 1 -1 2 } { 0 -3 1 } } { 2 1 0 } m.v ." + "{ 1 -3 }" + } +} ; + +HELP: v.m +{ $values { "v" sequence } { "m" matrix } { "p" matrix } } +{ $description "Computes the dot product of a vector and a matrix." } +{ $notelist + { $equiv-word-note "swapped" m.v } + $2d-only-note + { $matrix-scalar-note * + } +} +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "{ 2 1 0 } { { 1 -1 2 } { 0 -3 1 } } v.m ." + "{ 2 -5 5 }" + } +} ; + +HELP: m. +{ $values { "m" matrix } } +{ $description "Computes the dot product of two matrices, i.e multiplies them." } +{ $notelist + $2d-only-note + { $matrix-scalar-note * + } +} +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "{ { 1 -1 2 } { 0 -3 1 } } { { 3 7 } { 9 12 } } m. ." + "{ { -6 -5 } { -27 -36 } }" + } +} ; + +HELP: m~ +{ $values { "m1" matrix } { "m2" matrix } { "epsilon" number } { "?" boolean } } +{ $description "Compares the matrices like " { $link ~ } ", using the " { $snippet "epsilon" } "." } +{ $notelist + $2d-only-note + { $matrix-scalar-note ~ } +} +{ $examples + { "In the example, only " { $snippet ".01" } " was added to each element, so the new matrix is within the epsilon " { $snippet ".1" } "of the original." } + { $example + "USING: kernel math math.matrices prettyprint ;" + "{ { 5 9 } { 15 17 } } dup [ .01 + ] matrix-map .1 m~ ." + "t" + } +} ; + +HELP: mmin +{ $values { "m" matrix } { "n" object } } +{ $description "Determine the minimum value of the matrix." } +{ $notelist + $2d-only-note + { $matrix-scalar-note min } +} +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "{ { 5 9 } { 15 17 } } mmin ." + "5" + } +} ; + +HELP: mmax +{ $values { "m" matrix } { "n" object } } +{ $description "Determine the maximum value of the matrix." } +{ $notelist + $2d-only-note + { $matrix-scalar-note max } +} +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "{ { 5 9 } { 15 17 } } mmax ." + "17" + } +} ; + +HELP: mnorm +{ $values { "m" matrix } { "m'" matrix } } +{ $description "Normalize a matrix. Each element from the input matrix is computed as a fraction of the maximum element. The maximum element becomes " { $snippet "1/1" } "." } +{ $notelist + $2d-only-note + { $matrix-scalar-note max abs / } +} +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "{ { 5 9 } { 15 17 } } mnorm ." + "{ { 5/17 9/17 } { 15/17 1 } }" + } +} ; + +HELP: m-infinity-norm +{ $values { "m" matrix } { "n" number } } ; + +HELP: m-1norm +{ $values { "m" matrix } { "n" number } } ; + +HELP: frobenius-norm +{ $values { "m" matrix } { "n" number } } +{ $notes "Also known as the Hilbert-Schmidt norm." } ; + +HELP: >square-matrix +{ $values { "m" matrix } { "subset" square-matrix } } +{ $description "Find only the " { $link2 square-matrix "square" } " subset of the input matrix." } +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "{ { 0 2 4 6 } { 1 3 5 7 } } >square-matrix ." + "{ { 0 2 } { 1 3 } }" + } +} ; + +HELP: main-diagonal +{ $values { "matrix" matrix } { "seq" sequence } } +{ $description "Find the main diagonal of a matrix." $nl "This diagonal begins in the upper left of the matrix at index " { $snippet "{ 0 0 }" } ", continuing downward and rightward for all indices " { $snippet "{ n n }" } " in the " { $link square-matrix } " subset of the input (see " { $link } ")." } +{ $notelist + { "If the number of rows in the square subset of the input is even, then this diagonal will not contain elements found in the " { $link anti-diagonal } ". However, if the size of the square subset is odd, then this diagonal will share at most one element with " { $link anti-diagonal } "." } + { "This diagonal is sometimes called the " { $emphasis "first diagonal" } "." } + { $equiv-word-note "opposite" anti-diagonal } +} +{ $examples + { "The operation is simple on a " { $link square-matrix } ":" } + { $example + "USING: math.matrices prettyprint ;" +"{ + { 7 2 11 } + { 9 7 7 } + { 1 8 0 } +} main-diagonal ." + "{ 7 7 0 }" + } + "The square subset of the following input matrix consists of all rows but the last. The main diagonal does not include the last row because it has no fourth element." + { $example + "USING: math.matrices prettyprint ;" +"{ + { 6 5 0 } + { 7 2 6 } + { 4 3 9 } + { 3 3 3 } +} main-diagonal ." + "{ 6 2 9 }" + } +} ; + +HELP: anti-diagonal +{ $values { "matrix" matrix } { "seq" sequence } } +{ $description "Find the anti-diagonal of a matrix." $nl "This diagonal begins in the upper right of the matrix, continuing downward and leftward for all indices in the " { $link square-matrix } " subset of the input (see " { $link } ")." } +{ $notelist + { "If the number of rows in the square subset of the input is even, then this diagonal will not contain elements found in the " { $link main-diagonal } ". However, if the size of the square subset is odd, then this diagonal will share at most one element with " { $link main-diagonal } "." } + { "This diagonal is sometimes called the " { $emphasis "second diagonal" } "." } + { $equiv-word-note "opposite" main-diagonal } +} +{ $examples + { "The operation is simple on a " { $link square-matrix } ":" } + { $example + "USING: math.matrices prettyprint ;" +"{ + { 7 2 11 } + { 9 7 7 } + { 1 8 0 } +} anti-diagonal ." + "{ 11 7 1 }" + } + "The square subset of the following input matrix consists of all rows but the last. The anti-diagonal does not include the last row because it has no fourth element." + { $example + "USING: math.matrices prettyprint ;" +"{ + { 6 5 0 } + { 7 2 6 } + { 4 3 9 } + { 3 3 3 } +} anti-diagonal ." + "{ 0 2 4 }" + } +} ; + + +HELP: transpose +{ $values { "matrix" matrix } { "newmatrix" matrix } } +{ $description "Transpose the input matrix over its " { $link main-diagonal } ". The main diagonal itself is preserved, whereas the anti-diagonal is reversed." } +{ $notelist + { "This word is an alias for " { $link flip } ", so that it may be recognised as the common mathematical operation." } + { $equiv-word-note "opposite" anti-transpose } +} +{ $examples + { $example + "USING: math.matrices sequences prettyprint ;" + "5 transpose ." +"{ + { 0 0 0 0 4 } + { 0 0 0 3 0 } + { 0 0 2 0 0 } + { 0 1 0 0 0 } + { 0 0 0 0 0 } +}" + } +} ; + +HELP: anti-transpose +{ $values { "matrix" matrix } { "newmatrix" matrix } } +{ $description "Like " { $link transpose } " except that the matrix is transposed over the " { $link anti-diagonal } ", so that the anti-diagonal itself is preserved and the " { $link main-diagonal } " is reversed." } +{ $notes { $equiv-word-note "opposite" transpose } } +{ $examples + { $example + "USING: math.matrices sequences prettyprint ;" + "5 anti-transpose ." +"{ + { 4 0 0 0 0 } + { 0 3 0 0 0 } + { 0 0 2 0 0 } + { 0 0 0 1 0 } + { 0 0 0 0 0 } +}" + } +} ; + +HELP: rows-except +{ $values { "matrix" matrix } { "desc" { $or integer sequence } } { "others" matrix } } +{ $contract "Get all the rows from " { $snippet "matrix" } " " { $emphasis "not" } " described by " { $snippet "desc" } "." } +{ $examples + { $example + "USING: math.matrices prettyprint ;" +"{ + { 2 7 12 2 } + { 8 9 10 0 } + { 1 3 3 5 } + { 8 13 7 12 } +} { 1 3 } rows-except ." + "{ { 2 7 12 2 } { 1 3 3 5 } }" + } +} ; + +HELP: cols-except +{ $values { "matrix" matrix } { "desc" { $or integer sequence } } { "others" matrix } } +{ $contract "Get all the columns from " { $snippet "matrix" } " " { $emphasis "not" } " described by " { $snippet "desc" } "." } +{ $examples + { $example + "USING: math.matrices prettyprint ;" +"{ + { 2 7 12 2 } + { 8 9 10 0 } + { 1 3 3 5 } + { 8 13 7 12 } +} { 1 3 } cols-except . " + "{ { 2 12 } { 8 10 } { 1 3 } { 8 7 } }" + } +} ; +HELP: matrix-except +{ $values { "matrix" matrix } { "exclude-pair" pair } { "submatrix" matrix } } +{ $description "Get all the rows and columns from " { $snippet "matrix" } " except the row and column given in " { $snippet "exclude-pair" } ". The result is the " { $snippet "submatrix" } " containing no values from the given row and column." } +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "{ { 0 1 } { 2 3 } } { 0 1 } matrix-except ." + "{ { 2 } }" + } +} ; + +HELP: submatrix-excluding +{ $values { "matrix" matrix } { "exclude-pair" pair } { "submatrix" matrix } } +{ $description "A possibly more obvious word for " { $link matrix-except } "." } ; + +HELP: matrix-except-all +{ $values { "matrix" matrix } { "submatrices" { $sequence matrix } } } +{ $description "Find every possible submatrix of " { $snippet "matrix" } " by using " { $link matrix-except } " for every value's row-column pair." } +{ $examples + "There are 9 possible 2x2 submatrices of a 3x3 matrix with 9 indices, because there are 9 indices to exclude creating a new submatrix." + { $example + "USING: math.matrices prettyprint ;" + "{ { 0 1 2 } { 3 4 5 } { 6 7 8 } } matrix-except-all ." + "{ + { + { { 4 5 } { 7 8 } } + { { 3 5 } { 6 8 } } + { { 3 4 } { 6 7 } } + } + { + { { 1 2 } { 7 8 } } + { { 0 2 } { 6 8 } } + { { 0 1 } { 6 7 } } + } + { + { { 1 2 } { 4 5 } } + { { 0 2 } { 3 5 } } + { { 0 1 } { 3 4 } } + } +}" + } +} ; + +HELP: all-submatrices +{ $values { "matrix" matrix } { "submatrices" { $sequence matrix } } } +{ $description "A possibly more obvious name for " { $link matrix-except-all } "." } ; + +HELP: dimension +{ $values { "matrix" matrix } { "dimension" pair } } +{ $description "Find the dimension of the input matrix, in the order of " { $snippet "{ rows cols }"} "." } +{ $notelist $2d-only-note "Not to be confused with dimensionality, or the number of dimension scalars needed to describe a matrix." } +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "4 30 1 dimension ." + "{ 4 30 }" + } + { $example + "USING: math.matrices prettyprint ;" + "{ } dimension ." + "{ 0 0 }" + } } ; diff --git a/basis/math/matrices/matrices-tests.factor b/basis/math/matrices/matrices-tests.factor index f82fef7c85..02139fb856 100644 --- a/basis/math/matrices/matrices-tests.factor +++ b/basis/math/matrices/matrices-tests.factor @@ -1,382 +1,326 @@ -USING: math.matrices math.vectors tools.test math kernel ; -IN: math.matrices.tests +! Copyright (C) 2005, 2010, 2018 Slava Pestov, Joe Groff, and Cat Stevens. +USING: arrays combinators.short-circuit grouping kernel math math.matrices math.matrices.private +math.statistics math.vectors sequences sequences.deep sets tools.test ; +IN: math.matrices -{ - { { 0 } { 0 } { 0 } } -} [ - 3 1 zero-matrix + +! ------------------------ +! predicates + +{ t } [ { } regular-matrix? ] unit-test +{ t } [ { { } } regular-matrix? ] unit-test +{ t } [ { { 1 2 } } regular-matrix? ] unit-test +{ t } [ { { 1 2 } { 3 4 } } regular-matrix? ] unit-test +{ t } [ { { 1 } { 3 } } regular-matrix? ] unit-test +{ f } [ { { 1 2 } { 3 } } regular-matrix? ] unit-test +{ f } [ { { 1 } { 3 2 } } regular-matrix? ] unit-test + + +{ t } [ { } square-matrix? ] unit-test +{ t } [ { { 1 } } square-matrix? ] unit-test +{ t } [ { { 1 2 } { 3 4 } } square-matrix? ] unit-test +{ f } [ { { 1 } { 2 3 } } square-matrix? ] unit-test +{ f } [ { { 1 2 } } square-matrix? ] unit-test + +! any deep-empty matrix is null +! it doesn't make any sense for { } to be null while { { } } to be considered nonnull +{ t } [ { + { } + { { } } + { { { } } } + { { } { } { } } + { { { } } { { { } } } } +} [ null-matrix? ] map [ ] all? ] unit-test -{ - { { 1 0 0 } - { 0 1 0 } - { 0 0 1 } } -} [ - 3 identity-matrix +{ f } [ { + { 1 2 } + { { 1 2 } } + { { 1 } { 2 } } + { { { 1 } } { 2 } { } } +} [ null-matrix? ] map [ ] any? ] unit-test -{ - { { 1 0 0 } - { 0 2 0 } - { 0 0 3 } } -} [ - { 1 2 3 } diagonal-matrix +{ t } [ 10 dup zero-matrix? ] unit-test +{ t } [ 10 10 15 zero-matrix? ] unit-test +{ t } [ 0 dup null-matrix? ] unit-test +{ f } [ 0 dup zero-matrix? ] unit-test +{ f } [ 4 zero-matrix? ] unit-test +! make sure we're not using the sum-to-zero strategy +{ f } [ { { 0 -2 } { 1 -1 } } zero-matrix? ] unit-test +{ f } [ { { 0 0 } { 1 -1 } } zero-matrix? ] unit-test +{ f } [ { { 0 1 } { 0 -1 } } zero-matrix? ] unit-test + +! nth etc + +{ 3 } [ { 1 2 3 } 0 swap nth-end ] unit-test +{ 2 } [ { 1 2 3 } 1 swap nth-end ] unit-test +{ 1 } [ { 1 2 3 } 2 swap nth-end ] unit-test + +[ { 1 2 3 } -1 swap nth-end ] [ bounds-error? ] must-fail-with +[ { 1 2 3 } 3 swap nth-end ] [ bounds-error? ] must-fail-with +[ { 1 2 3 } 4 swap nth-end ] [ bounds-error? ] must-fail-with + +{ { 0 0 1 } } [ { 0 0 0 } dup 1 0 rot set-nth-end ] unit-test +{ { 0 2 0 } } [ { 0 0 0 } dup 2 1 rot set-nth-end ] unit-test +{ { 3 0 0 } } [ { 0 0 0 } dup 3 2 rot set-nth-end ] unit-test + +[ { 0 0 0 } dup 1 -1 rot set-nth-end ] [ bounds-error? ] must-fail-with +[ { 0 0 0 } dup 2 3 rot set-nth-end ] [ bounds-error? ] must-fail-with +[ { 0 0 0 } dup 3 4 rot set-nth-end ] [ bounds-error? ] must-fail-with + +! constructors + +{ { + { 5 5 } + { 5 5 } +} } [ 2 2 5 ] unit-test +! a matrix-matrix +{ { { + { { -1 -1 } { -1 -1 } } + { { -1 -1 } { -1 -1 } } + { { -1 -1 } { -1 -1 } } +} { + { { -1 -1 } { -1 -1 } } + { { -1 -1 } { -1 -1 } } + { { -1 -1 } { -1 -1 } } +} } } [ 2 3 2 2 -1 ] unit-test + +{ { + { 5 5 } + { 5 5 } +} } [ 2 2 [ 5 ] ] unit-test +{ { + { 6 6 } + { 6 6 } +} } [ 2 2 [ 3 2 * ] ] unit-test + +{ { + { 0 1 2 } + { 1 2 3 } +} } [ 2 3 [ + ] ] unit-test +{ { + { 0 0 0 } + { 0 1 2 } + { 0 2 4 } +} } [ 3 3 [ * ] ] unit-test + +{ t } [ 3 3 zero-square-matrix? ] unit-test +{ t } [ 3 zero-square-matrix? ] unit-test +{ t f } [ 3 1 [ zero-matrix? ] [ square-matrix? ] bi ] unit-test + +{ { + { 1 0 0 } + { 0 2 0 } + { 0 0 3 } +} } [ + { 1 2 3 } ] unit-test -{ - { { 1 1 1 } - { 4 2 1 } - { 9 3 1 } - { 25 5 1 } } -} [ - { 1 2 3 5 } 3 vandermonde-matrix +{ { + { -11 0 0 0 } + { 0 -12 0 0 } + { 0 0 -33 0 } + { 0 0 0 -14 } +} } [ { -11 -12 -33 -14 } ] unit-test + +{ { + { 0 0 1 } + { 0 2 0 } + { 3 0 0 } +} } [ { 1 2 3 } ] unit-test + +{ { + { 0 0 0 -11 } + { 0 0 -12 0 } + { 0 -33 0 0 } + { -14 0 0 0 } +} } [ { -11 -12 -33 -14 } ] unit-test + +{ { + { 1 0 0 } + { 0 1 0 } + { 0 0 1 } +} } [ + 3 ] unit-test -{ - { - { 1 0 0 } - { 0 1 0 } - { 0 0 1 } - } -} [ - 3 3 0 eye +{ { + { 2 0 0 } + { 0 2 0 } + { 0 0 2 } +} } [ + 3 3 0 2 ] unit-test -{ - { - { 0 1 0 } - { 0 0 1 } - { 0 0 0 } - } -} [ - 3 3 1 eye +{ { + { 0 2 0 } + { 0 0 2 } + { 0 0 0 } +} } [ + 3 3 1 2 ] unit-test -{ - { - { 0 0 0 } - { 1 0 0 } - { 0 1 0 } - } -} [ - 3 3 -1 eye +{ { + { 0 0 0 0 } + { 2 0 0 0 } + { 0 2 0 0 } +} } [ + 3 4 -1 2 ] unit-test -{ - { - { 1 0 0 0 } - { 0 1 0 0 } - { 0 0 1 0 } - } -} [ - 3 4 0 eye + +{ { + { 1 0 0 } + { 0 1 0 } + { 0 0 1 } +} } [ + 3 3 0 ] unit-test -{ - { - { 0 1 0 } - { 0 0 1 } - { 0 0 0 } - { 0 0 0 } - } -} [ - 4 3 1 eye +{ { + { 0 1 0 } + { 0 0 1 } + { 0 0 0 } +} } [ + 3 3 1 ] unit-test -{ - { - { 0 0 0 } - { 1 0 0 } - { 0 1 0 } - { 0 0 1 } - } -} [ - 4 3 -1 eye +{ { + { 0 0 0 } + { 1 0 0 } + { 0 1 0 } +} } [ + 3 3 -1 ] unit-test -{ - { { 1 1/2 1/3 1/4 } - { 1/2 1/3 1/4 1/5 } - { 1/3 1/4 1/5 1/6 } - } -} [ 3 4 hilbert-matrix ] unit-test +{ { + { 1 0 0 0 } + { 0 1 0 0 } + { 0 0 1 0 } +} } [ + 3 4 0 +] unit-test -{ - { { 1 2 3 4 } - { 2 1 2 3 } - { 3 2 1 2 } - { 4 3 2 1 } } -} [ 4 toeplitz-matrix ] unit-test +{ { + { 0 1 0 } + { 0 0 1 } + { 0 0 0 } + { 0 0 0 } +} } [ + 4 3 1 +] unit-test -{ - { { 1 2 3 4 } - { 2 3 4 0 } - { 3 4 0 0 } - { 4 0 0 0 } } -} [ 4 hankel-matrix ] unit-test +{ { + { 0 0 0 } + { 1 0 0 } + { 0 1 0 } + { 0 0 1 } +} } [ + 4 3 -1 +] unit-test -{ - { { 1 0 4 } - { 0 7 0 } - { 6 0 3 } } -} [ - { { 1 0 0 } - { 0 2 0 } - { 0 0 3 } } +{ { + { { 0 0 } { 0 1 } { 0 2 } } + { { 1 0 } { 1 1 } { 1 2 } } + { { 2 0 } { 2 1 } { 2 2 } } + { { 3 0 } { 3 1 } { 3 2 } } +} } [ { 4 3 } ] unit-test - { { 0 0 4 } - { 0 5 0 } - { 6 0 0 } } +{ { + { 0 1 } + { 0 1 } +} } [ 2 ] unit-test +{ { + { 0 0 } + { 1 1 } +} } [ 2 ] unit-test + +{ { + { 5 6 } + { 5 6 } +} } [ { 5 6 } ] unit-test + +{ { + { 5 5 } + { 6 6 } +} } [ { 5 6 } ] unit-test + +{ { + { 1 } +} } [ { + { 1 2 } +} ] unit-test + +{ { + { 1 2 } + { 3 4 } +} } [ { + { 1 2 5 } + { 3 4 6 } +} ] unit-test + +{ { + { 1 2 } + { 3 4 } +} } [ { + { 1 2 } + { 3 4 } + { 5 6 } +} ] unit-test + +{ { + { 1 0 4 } + { 0 7 0 } + { 6 0 3 } } +} [ { + { 1 0 0 } + { 0 2 0 } + { 0 0 3 } +} { + { 0 0 4 } + { 0 5 0 } + { 6 0 0 } +} m+ ] unit-test -{ - { { 1 0 4 } - { 0 7 0 } - { 6 0 3 } } -} [ - { { 1 0 0 } - { 0 2 0 } - { 0 0 3 } } - - { { 0 0 -4 } - { 0 -5 0 } - { -6 0 0 } } - +{ { + { 1 0 4 } + { 0 7 0 } + { 6 0 3 } +} } [ { + { 1 0 0 } + { 0 2 0 } + { 0 0 3 } +} { + { 0 0 -4 } + { 0 -5 0 } + { -6 0 0 } +} m- ] unit-test -{ - { 10 20 30 } -} [ - 10 { 1 2 3 } n*v -] unit-test +{ { 3 4 } } [ { { 1 0 } { 0 1 } } { 3 4 } m.v ] unit-test +{ { 4 3 } } [ { { 0 1 } { 1 0 } } { 3 4 } m.v ] unit-test -{ - { 3 4 } -} [ - { { 1 0 } - { 0 1 } } +{ { { 6 } } } [ { { 3 } } { { 2 } } m. ] unit-test +{ { { 11 } } } [ { { 1 3 } } { { 5 } { 2 } } m. ] unit-test - { 3 4 } - - m.v -] unit-test - -{ - { 4 3 } -} [ - { { 0 1 } - { 1 0 } } - - { 3 4 } - - m.v -] unit-test - -{ - { { 6 } } -} [ - { { 3 } } { { 2 } } m. -] unit-test - -{ - { { 11 } } -} [ - { { 1 3 } } { { 5 } { 2 } } m. -] unit-test - -{ - { { 28 } } -} [ +{ { { 28 } } } [ { { 2 4 6 } } - - { { 1 } - { 2 } - { 3 } } - + { { 1 } { 2 } { 3 } } m. ] unit-test -{ { 0 0 1 } } [ { 1 0 0 } { 0 1 0 } cross ] unit-test -{ { 1 0 0 } } [ { 0 1 0 } { 0 0 1 } cross ] unit-test -{ { 0 1 0 } } [ { 0 0 1 } { 1 0 0 } cross ] unit-test -{ { 0.0 -0.707 0.707 } } [ { 1.0 0.0 0.0 } { 0.0 0.707 0.707 } cross ] unit-test -{ { 0 -2 2 } } [ { -1 -1 -1 } { 1 -1 -1 } cross ] unit-test -{ { 1 0 0 } } [ { 1 1 0 } { 1 0 0 } proj ] unit-test -{ { { 4181 6765 } { 6765 10946 } } } -[ { { 0 1 } { 1 1 } } 20 m^n ] unit-test -[ { { 0 1 } { 1 1 } } -20 m^n ] [ negative-power-matrix? ] must-fail-with - -{ - { { 0 5 0 10 } { 6 7 12 14 } { 0 15 0 20 } { 18 21 24 28 } } -} -[ { { 1 2 } { 3 4 } } { { 0 5 } { 6 7 } } kron ] unit-test - -{ - { - { 1 1 1 1 } - { 1 -1 1 -1 } - { 1 1 -1 -1 } - { 1 -1 -1 1 } - } -} [ { { 1 1 } { 1 -1 } } dup kron ] unit-test - -{ - { - { 1 1 1 1 1 1 1 1 } - { 1 -1 1 -1 1 -1 1 -1 } - { 1 1 -1 -1 1 1 -1 -1 } - { 1 -1 -1 1 1 -1 -1 1 } - { 1 1 1 1 -1 -1 -1 -1 } - { 1 -1 1 -1 -1 1 -1 1 } - { 1 1 -1 -1 -1 -1 1 1 } - { 1 -1 -1 1 -1 1 1 -1 } - } -} [ { { 1 1 } { 1 -1 } } dup dup kron kron ] unit-test - -{ - { - { 1 1 1 1 1 1 1 1 } - { 1 -1 1 -1 1 -1 1 -1 } - { 1 1 -1 -1 1 1 -1 -1 } - { 1 -1 -1 1 1 -1 -1 1 } - { 1 1 1 1 -1 -1 -1 -1 } - { 1 -1 1 -1 -1 1 -1 1 } - { 1 1 -1 -1 -1 -1 1 1 } - { 1 -1 -1 1 -1 1 1 -1 } - } -} [ { { 1 1 } { 1 -1 } } dup dup kron swap kron ] unit-test - - -! kron is not generally commutative, make sure we have the right order -{ - { - { 1 2 3 4 5 1 2 3 4 5 } - { 6 7 8 9 10 6 7 8 9 10 } - { 1 2 3 4 5 -1 -2 -3 -4 -5 } - { 6 7 8 9 10 -6 -7 -8 -9 -10 } - } -} -[ - { { 1 1 } { 1 -1 } } - { { 1 2 3 4 5 } { 6 7 8 9 10 } } kron -] unit-test - -{ - { - { 1 1 2 2 3 3 4 4 5 5 } - { 1 -1 2 -2 3 -3 4 -4 5 -5 } - { 6 6 7 7 8 8 9 9 10 10 } - { 6 -6 7 -7 8 -8 9 -9 10 -10 } - } -} -[ - { { 1 1 } { 1 -1 } } - { { 1 2 3 4 5 } { 6 7 8 9 10 } } swap kron -] unit-test - -{ - { { 5 10 15 } - { 6 12 18 } - { 7 14 21 } } -} [ { 5 6 7 } { 1 2 3 } outer ] unit-test - - -CONSTANT: test-points { - { 80 27 89 } { 80 27 88 } { 75 25 90 } - { 62 24 87 } { 62 22 87 } { 62 23 87 } - { 62 24 93 } { 62 24 93 } { 58 23 87 } - { 58 18 80 } { 58 18 89 } { 58 17 88 } - { 58 18 82 } { 58 19 93 } { 50 18 89 } - { 50 18 86 } { 50 19 72 } { 50 19 79 } - { 50 20 80 } { 56 20 82 } { 70 20 91 } -} - -{ - { - { 84+2/35 22+23/35 24+4/7 } - { 22+23/35 9+104/105 6+87/140 } - { 24+4/7 6+87/140 28+5/7 } - } -} [ - test-points sample-cov-matrix -] unit-test - -{ - { - { 80+8/147 21+85/147 23+59/147 } - { 21+85/147 9+227/441 6+15/49 } - { 23+59/147 6+15/49 27+17/49 } - } -} [ - test-points population-cov-matrix -] unit-test - -{ - { - { 5 5 } - { 5 5 } - } -} [ - 2 2 5 -] unit-test - -{ - { - { 5 5 } - { 5 5 } - } -} [ - 2 2 [ 5 ] make-matrix -] unit-test - -{ - { - { 0 1 2 } - { 1 2 3 } - } -} [ - 2 3 [ + ] make-matrix-with-indices -] unit-test - -{ - { - { 0 1 } - { 0 1 } - } -} [ - 2 square-rows -] unit-test - -{ - { - { 0 0 } - { 1 1 } - } -} [ - 2 square-cols -] unit-test - -{ - { - { 5 6 } - { 5 6 } - } -} [ - { 5 6 } square-rows -] unit-test - -{ - { - { 5 5 } - { 6 6 } - } -} [ - { 5 6 } square-cols -] unit-test +! TODO: note: merge conflict from HEAD contained the following +! ------------------------ +! predicates { t } [ { } square-matrix? ] unit-test { t } [ { { 1 } } square-matrix? ] unit-test @@ -392,3 +336,361 @@ CONSTANT: test-points { { 2.0 } [ { { 1 1 } { 1 1 } } frobenius-norm ] unit-test +! from "intermediate commit" +! any deep-empty matrix is null +! it doesn't make any sense for { } to be null while { { } } to be considered nonnull +{ t } [ { + { } + { { } } + { { { } } } + { { } { } { } } + { { { } } { { { } } } } +} [ null-matrix? ] map [ ] all? +] unit-test + +{ f } [ { + { 1 2 } + { { 1 2 } } + { { 1 } { 2 } } + { { { 1 } } { 2 } { } } +} [ null-matrix? ] map [ ] any? +] unit-test + +{ t } [ 10 dup zero-matrix? ] unit-test +{ t } [ 10 10 15 zero-matrix? ] unit-test +{ t } [ 0 dup null-matrix? ] unit-test +{ f } [ 0 dup zero-matrix? ] unit-test +{ f } [ 4 zero-matrix? ] unit-test + +{ t } [ { } regular-matrix? ] unit-test +{ t } [ { { } } regular-matrix? ] unit-test +{ t } [ { { 1 2 } } regular-matrix? ] unit-test +{ t } [ { { 1 2 } { 3 4 } } regular-matrix? ] unit-test +{ t } [ { { 1 } { 3 } } regular-matrix? ] unit-test +{ f } [ { { 1 2 } { 3 } } regular-matrix? ] unit-test +{ f } [ { { 1 } { 3 2 } } regular-matrix? ] unit-test +! TODO: note: lines since last HEAD comment were deleted in "fix more code and add more rigorous tests" + +! diagonals + +! diagonal getters +{ { 1 1 1 1 } } [ 4 main-diagonal ] unit-test +{ { 0 0 0 0 } } [ 4 anti-diagonal ] unit-test +{ { 4 8 } } [ { { 4 6 } { 3 8 } } main-diagonal ] unit-test +{ { 6 3 } } [ { { 4 6 } { 3 8 } } anti-diagonal ] unit-test +{ { 1 2 3 } } [ { { 0 0 1 } { 0 2 0 } { 3 0 0 } } anti-diagonal ] unit-test +{ { 1 2 3 4 } } [ { 1 2 3 4 } main-diagonal ] unit-test + +! transposition +{ { 1 2 3 4 } } [ { 1 2 3 4 } transpose main-diagonal ] unit-test +{ t } [ 50 dup transpose = ] unit-test +{ { 4 3 2 1 } } [ { 1 2 3 4 } transpose anti-diagonal ] unit-test + +{ { + { 1 4 7 } + { 2 5 8 } + { 3 6 9 } +} } [ { + { 1 2 3 } + { 4 5 6 } + { 7 8 9 } +} transpose ] unit-test + +! anti transposition +{ { 1 2 3 4 } } [ { 1 2 3 4 } anti-transpose anti-diagonal ] unit-test +{ t } [ 50 dup anti-transpose = ] unit-test +{ { 4 3 2 1 } } [ { 1 2 3 4 } anti-transpose main-diagonal ] unit-test + +{ { + { 9 6 3 } + { 8 5 2 } + { 7 4 1 } +} } [ { + { 1 2 3 } + { 4 5 6 } + { 7 8 9 } +} anti-transpose ] unit-test + + +{ { { + { E F G H } + { I J K L } + { M N O P } +} { + { A B C D } + { I J K L } + { M N O P } +} { + { A B C D } + { E F G H } + { M N O P } +} { + { A B C D } + { E F G H } + { I J K L } +} } } [ + 4 { + { A B C D } + { E F G H } + { I J K L } + { M N O P } + } + [ rows-except ] map-index +] unit-test + +{ { { 2 } } } [ { { 1 } { 2 } } 0 rows-except ] unit-test +{ { { 1 } } } [ { { 1 } { 2 } } 1 rows-except ] unit-test +{ { } } [ { { 1 } } 0 rows-except ] unit-test +{ { { 1 } } } [ { { 1 } } 1 rows-except ] unit-test +{ { + { 2 7 12 2 } ! 0 + { 1 3 3 5 } ! 2 +} } [ { + { 2 7 12 2 } + { 8 9 10 0 } + { 1 3 3 5 } + { 8 13 7 12 } +} { 1 3 } rows-except ] unit-test + +{ { { + { B C D } + { F G H } + { J K L } + { N O P } +} { + { A C D } + { E G H } + { I K L } + { M O P } +} { + { A B D } + { E F H } + { I J L } + { M N P } +} { + { A B C } + { E F G } + { I J K } + { M N O } +} } } [ + 4 { + { A B C D } + { E F G H } + { I J K L } + { M N O P } + } + [ cols-except ] map-index +] unit-test + +{ { } } [ { { 1 } { 2 } } 0 cols-except ] unit-test +{ { { 1 } { 2 } } } [ { { 1 } { 2 } } 1 cols-except ] unit-test +{ { } } [ { { 1 } } 0 cols-except ] unit-test +{ { { 1 } } } [ { { 1 } } 1 cols-except ] unit-test +{ { { 2 } { 4 } } } [ { { 1 2 } { 3 4 } } 0 cols-except ] unit-test +{ { { 1 } { 3 } } } [ { { 1 2 } { 3 4 } } 1 cols-except ] unit-test +{ { + { 2 12 } + { 8 10 } + { 1 3 } + { 8 7 } +} } [ { + { 2 7 12 2 } + { 8 9 10 0 } + { 1 3 3 5 } + { 8 13 7 12 } +} { 1 3 } cols-except ] unit-test + +{ { { + { F G H } + { J K L } + { N O P } +} { + { A C D } + { I K L } + { M O P } +} { + { A B D } + { E F H } + { M N P } +} { + { A B C } + { E F G } + { I J K } +} } } [ + 4 { + { A B C D } + { E F G H } + { I J K L } + { M N O P } + } + [ dup 2array matrix-except ] map-index +] unit-test + +! prepare for bracket hell +! going to test the Matrix of Minors permutation strategy + +! going to test 1x2 inputs +! the input had 2 elements, the output has 2 0-matrices across 2 arrays ;) +{ { { { } { } } } } [ { { 1 2 } } matrix-except-all ] unit-test + +! any matrix with a 1 in its dimensions will give a void matrix output +{ t } [ { { 1 2 } } matrix-except-all null-matrix? ] unit-test +{ t } [ { { 1 } { 2 } } matrix-except-all null-matrix? ] unit-test + +! going to test 2x2 inputs +! these 1x1 output matrices have omitted a row and column from the 2x2 input + +! the input had 4 elements, the output has 4 1-matrices across 2 arrays +! the permutations of indices 0 1 are: 0 0, 0 1, 1 0, 1 1 +{ + { ! output array + { ! item #1: excluding row 0... + { { 3 } } ! and col 0 = 0 0 + { { 2 } } ! and col 1 = 0 1 + } + { ! item #2: excluding row 1... + { { 1 } } ! and col 0 = 1 0 + { { 0 } } ! and col 1 = 1 1 + } + } +} [ + ! the input to the function is a simple 2x2 + { { 0 1 } { 2 3 } } matrix-except-all +] unit-test + +! we are going to ensure that "duplicate" matrices are not omitted in the output +{ + { + { ! item 1 + { { 0 } } + { { 0 } } + } + { ! item 2 + { { 0 } } + { { 0 } } + } + } +} [ { { 0 0 } { 0 0 } } matrix-except-all ] unit-test +! the output only has elements from the input +{ t } [ 44 matrix-except-all zero-matrix? ] unit-test + +! going to test 2x3 and 3x2 inputs +{ + { ! output array + { ! excluding row 0 + { { 2 } { 3 } } ! and col 0 + { { 1 } { 2 } } ! and col 1 + } + { ! excluding row 1 + { { 1 } { 3 } } ! and col 0 + { { 0 } { 2 } } ! and col 1 + } + { ! excluding row 2 + { { 1 } { 2 } } ! col 0 + { { 0 } { 1 } } ! col 1 + } + } +} [ { + { 0 1 } + { 1 2 } + { 2 3 } +} matrix-except-all ] unit-test + +{ + { ! output array + { ! excluding row 0 + { { 2 3 } } ! col 0 + { { 1 3 } } ! col 1 + { { 1 2 } } ! col 2 + } + { ! row 1 + { { 1 2 } } ! col 0 + { { 0 2 } } ! col 1 + { { 0 1 } } ! col 2 + } + } +} [ { + { 0 1 2 } + { 1 2 3 } +} matrix-except-all ] unit-test + +! going to test 3x3 inputs + +! the input had 9 elements, the output has 9 2-matrices across 3 arrays +! every element from the input is represented 4 times in the output +! the number of copies of each element found in the output is the side length of the next smaller square matrix +! 3x3 input gives 4 copies of each element; (N-1) ^ 2 = 4 where N=3 +! the permutations of indices 0 1 2 are: 0 0, 0 1, 0 2; 1 0, 1 1, 1 2; 2 0, 2 1, 2 2 +{ + { ! output array + { ! item #1: excluding row 0... + { ! and col 0 = 0 0 + { 4 5 } + { 7 8 } + } + { ! and col 1 = 0 1 + { 3 5 } + { 6 8 } + } + { ! and col 2 = 0 2 + { 3 4 } + { 6 7 } + } + } + + { ! item #2: excluding row 1... + { ! and col 0 = 1 0 + { 1 2 } + { 7 8 } + } + { ! and col 1 = 1 1 + { 0 2 } + { 6 8 } + } + { ! and col 2 = 1 2 + { 0 1 } + { 6 7 } + } + } + + { ! item #2: excluding row 2... + { ! and col 0 = 2 0 + { 1 2 } + { 4 5 } + } + { ! and col 1 = 2 1 + { 0 2 } + { 3 5 } + } + { ! and col 2 = 2 2 + { 0 1 } + { 3 4 } + } + } + } + t ! note this +} [ { + { 0 1 2 } + { 3 4 5 } + { 6 7 8 } +} matrix-except-all dup flatten sorted-histogram [ second ] map + { [ length 9 = ] [ [ 4 = ] all? ] } + 1&& +] unit-test + +! going to test 4x4 inputs + +! don't feel like handwriting this right now, so a sanity check test instead +! the input contains 4 rows and 4 columns for 16 elements +! 4x4 input gives 9 copies of each element; (N-1) ^ 2 = 9 where N = 4 +{ t } [ { + { 0 1 2 3 } + { 4 5 6 7 } + { 8 9 10 11 } + { 12 13 14 15 } +} matrix-except-all flatten sorted-histogram [ second ] map + { [ length 16 = ] [ [ 9 = ] all? ] } + 1&& +] unit-test diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor index ef5a06a22f..1090c2af5c 100644 --- a/basis/math/matrices/matrices.factor +++ b/basis/math/matrices/matrices.factor @@ -1,197 +1,159 @@ -! Copyright (C) 2005, 2010 Slava Pestov, Joe Groff. +! Copyright (C) 2005, 2010, 2018 Slava Pestov, Joe Groff, and Cat Stevens. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays columns kernel locals math math.bits -math.functions math.order math.vectors sequences -sequences.private fry math.statistics grouping -combinators.short-circuit math.ranges combinators.smart ; +USING: accessors arrays classes.singleton columns combinators +combinators.short-circuit combinators.smart formatting fry +grouping kernel locals math math.bits math.functions math.order +math.private math.ranges math.statistics math.vectors +math.vectors.private sequences sequences.deep sequences.private +slots.private summary ; IN: math.matrices -! Matrices -: make-matrix ( m n quot -- matrix ) - '[ _ _ replicate ] replicate ; inline +! defined here because of issue #1943 +DEFER: regular-matrix? +: regular-matrix? ( object -- ? ) + [ t ] [ + dup first-unsafe length + '[ length _ = ] all? + ] if-empty ; +! the MRO (class linearization) is performed in the order the predicates appear here +! except that null-matrix is last (but it is relied upon by zero-matrix) +! in other words: +! sequence > matrix > zero-matrix > square-matrix > zero-square-matrix > null-matrix + +! Factor bug that's hard to repro: using `bi and` in these predicates +! instead of 1&& will cause spirious no-method and bounds-error errors in +! and the tests/docs for no apparent reason +PREDICATE: matrix < sequence + { [ [ sequence? ] all? ] [ regular-matrix? ] } 1&& ; + +PREDICATE: irregular-matrix < sequence + { [ [ sequence? ] all? ] [ regular-matrix? not ] } 1&& ; + +DEFER: dimension +! can't define dim using this predicate for this reason, +! unless we are going to write two versions of dim, one of which is generic +PREDICATE: square-matrix < matrix + dimension first2-unsafe = ; + +PREDICATE: null-matrix < matrix + flatten empty? ; + +PREDICATE: zero-matrix < matrix + dup null-matrix? [ drop f ] [ flatten [ zero? ] all? ] if ; + +PREDICATE: zero-square-matrix < square-matrix + { [ zero-matrix? ] [ square-matrix? ] } 1&& ; + +! Benign matrix constructors : ( m n element -- matrix ) '[ _ _ ] replicate ; inline -: zero-matrix ( m n -- matrix ) +: ( m n quot: ( ... -- elt ) -- matrix ) + '[ _ _ replicate ] replicate ; inline + +: ( ... m n quot: ( ... m' n' -- ... elt ) -- ... matrix ) + [ [ ] bi@ ] dip cartesian-map ; inline + +: ( m n -- matrix ) 0 ; inline -: diagonal-matrix ( diagonal-seq -- matrix ) - dup length dup zero-matrix - [ '[ dup _ nth set-nth ] each-index ] keep ; inline +: ( n -- matrix ) + dup ; inline -: identity-matrix ( n -- matrix ) - 1 diagonal-matrix ; inline + ] bi@ ] dip neg '[ _ + = 1 0 ? ] cartesian-map ; +: nth-end ( n seq -- elt ) + [ (nth-from-end) ] keep nth ; inline flushable -: hilbert-matrix ( m n -- matrix ) - [ ] bi@ [ + 1 + recip ] cartesian-map ; +: nth-end-unsafe ( n seq -- elt ) + [ (nth-from-end) ] keep nth-unsafe ; inline flushable -: toeplitz-matrix ( n -- matrix ) - dup [ - abs 1 + ] cartesian-map ; +: array-nth-end-unsafe ( n seq -- elt ) + [ (nth-from-end) ] keep swap 2 fixnum+fast slot ; inline flushable -: hankel-matrix ( n -- matrix ) - [ dup ] keep '[ + abs 1 + dup _ > [ drop 0 ] when ] cartesian-map ; +: set-nth-end ( elt n seq -- ) + [ (nth-from-end) ] keep set-nth ; inline -: box-matrix ( r -- matrix ) - 2 * 1 + dup '[ _ 1 ] replicate ; +: set-nth-end-unsafe ( elt n seq -- ) + [ (nth-from-end) ] keep set-nth-unsafe ; inline +PRIVATE> -: vandermonde-matrix ( u n -- matrix ) - [ v^n ] with map reverse flip ; +! main-diagonal matrix +: ( diagonal-seq -- matrix ) + [ length ] keep over + '[ dup _ nth set-nth-unsafe ] each-index ; inline -:: rotation-matrix3 ( axis theta -- matrix ) - theta cos :> c - theta sin :> s - axis first3 :> ( x y z ) - x sq 1.0 x sq - c * + x y * 1.0 c - * z s * - x z * 1.0 c - * y s * + 3array - x y * 1.0 c - * z s * + y sq 1.0 y sq - c * + y z * 1.0 c - * x s * - 3array - x z * 1.0 c - * y s * - y z * 1.0 c - * x s * + z sq 1.0 z sq - c * + 3array - 3array ; +! could also be written slower as: [ reverse ] map +: ( diagonal-seq -- matrix ) + [ length ] keep over + '[ dup _ nth set-nth-end-unsafe ] each-index ; inline -:: rotation-matrix4 ( axis theta -- matrix ) - theta cos :> c - theta sin :> s - axis first3 :> ( x y z ) - x sq 1.0 x sq - c * + x y * 1.0 c - * z s * - x z * 1.0 c - * y s * + 0 4array - x y * 1.0 c - * z s * + y sq 1.0 y sq - c * + y z * 1.0 c - * x s * - 0 4array - x z * 1.0 c - * y s * - y z * 1.0 c - * x s * + z sq 1.0 z sq - c * + 0 4array - { 0.0 0.0 0.0 1.0 } 4array ; +: ( n -- matrix ) + 1 ; inline -:: translation-matrix4 ( offset -- matrix ) - offset first3 :> ( x y z ) - { - { 1.0 0.0 0.0 x } - { 0.0 1.0 0.0 y } - { 0.0 0.0 1.0 z } - { 0.0 0.0 0.0 1.0 } - } ; +: ( m n k z -- matrix ) + [ [ ] bi@ ] 2dip + '[ _ neg + = _ 0 ? ] + cartesian-map ; inline -: >scale-factors ( number/sequence -- x y z ) - dup number? [ dup dup ] [ first3 ] if ; +! if m = n and k = 0 then is (possibly) more efficient +:: ( m n k -- matrix ) + m n = k 0 = and + [ n ] + [ m n k 1 ] if ; inline -:: scale-matrix3 ( factors -- matrix ) - factors >scale-factors :> ( x y z ) - { - { x 0.0 0.0 } - { 0.0 y 0.0 } - { 0.0 0.0 z } - } ; +: ( dim -- coordinates ) + first2 [ ] bi@ cartesian-product ; inline -:: scale-matrix4 ( factors -- matrix ) - factors >scale-factors :> ( x y z ) - { - { x 0.0 0.0 0.0 } - { 0.0 y 0.0 0.0 } - { 0.0 0.0 z 0.0 } - { 0.0 0.0 0.0 1.0 } - } ; +ALIAS: -: ortho-matrix4 ( dim -- matrix ) - [ recip ] map scale-matrix4 ; +: ( n -- matrix ) + dup 2array ; inline -:: frustum-matrix4 ( xy-dim near far -- matrix ) - xy-dim first2 :> ( x y ) - near x /f :> xf - near y /f :> yf - near far + near far - /f :> zf - 2 near far * * near far - /f :> wf +ALIAS: transpose flip - { - { xf 0.0 0.0 0.0 } - { 0.0 yf 0.0 0.0 } - { 0.0 0.0 zf wf } - { 0.0 0.0 -1.0 0.0 } - } ; + zf +: matrix-cols-iota ( matrix -- cols-iota ) + first-unsafe length ; inline - { - { 1.0 0.0 0.0 0.0 } - { 0.0 1.0 0.0 0.0 } - { 0.0 zf 1.0 0.0 } - { 0.0 0.0 0.0 1.0 } - } ; +: unshaped-cols-iota ( matrix -- cols-iota ) + [ first-unsafe length 1 ] keep + [ length min ] (each) (each-integer) ; inline -! Matrix operations -: mneg ( m -- m ) [ vneg ] map ; +: generic-anti-transpose-unsafe ( cols-iota matrix -- newmatrix ) + [ [ nth-end-unsafe ] with { } map-as ] curry { } map-as ; inline -: n+m ( n m -- m ) [ n+v ] with map ; -: m+n ( m n -- m ) [ v+n ] curry map ; -: n-m ( n m -- m ) [ n-v ] with map ; -: m-n ( m n -- m ) [ v-n ] curry map ; -: n*m ( n m -- m ) [ n*v ] with map ; -: m*n ( m n -- m ) [ v*n ] curry map ; -: n/m ( n m -- m ) [ n/v ] with map ; -: m/n ( m n -- m ) [ v/n ] curry map ; +: array-anti-transpose-unsafe ( cols-iota matrix -- newmatrix ) + [ [ array-nth-end-unsafe ] with map ] curry map ; inline +PRIVATE> -: m+ ( m m -- m ) [ v+ ] 2map ; -: m- ( m m -- m ) [ v- ] 2map ; -: m* ( m m -- m ) [ v* ] 2map ; -: m/ ( m m -- m ) [ v/ ] 2map ; +! much faster than [ reverse ] map flip [ reverse ] map +: anti-transpose ( matrix -- newmatrix ) + dup empty? [ ] [ + [ dup regular-matrix? + [ matrix-cols-iota ] [ unshaped-cols-iota ] if + ] keep -: v.m ( v m -- v ) flip [ v. ] with map ; -: m.v ( m v -- v ) [ v. ] curry map ; -: m. ( m m -- m ) flip [ swap m.v ] curry map ; + dup array-matrix? [ + array-anti-transpose-unsafe + ] [ + generic-anti-transpose-unsafe + ] if + ] if ; -: m~ ( m m epsilon -- ? ) [ v~ ] curry 2all? ; +ALIAS: anti-flip anti-transpose -: mmin ( m -- n ) [ 1/0. ] dip [ [ min ] each ] each ; -: mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ; -: mnorm ( m -- n ) dup mmax abs m/n ; -: m-infinity-norm ( m -- n ) [ [ abs ] map-sum ] map supremum ; -: m-1norm ( m -- n ) flip m-infinity-norm ; -: frobenius-norm ( m -- n ) [ [ sq ] map-sum ] map-sum sqrt ; - -: cross ( vec1 vec2 -- vec3 ) - [ [ { 1 2 0 } vshuffle ] [ { 2 0 1 } vshuffle ] bi* v* ] - [ [ { 2 0 1 } vshuffle ] [ { 1 2 0 } vshuffle ] bi* v* ] 2bi v- ; inline - -:: normal ( vec1 vec2 vec3 -- vec4 ) - vec2 vec1 v- vec3 vec1 v- cross normalize ; inline - -: proj ( v u -- w ) - [ [ v. ] [ norm-sq ] bi / ] keep n*v ; - -: perp ( v u -- w ) - dupd proj v- ; - -: angle-between ( v u -- a ) - [ normalize ] bi@ h. acos ; - -: (gram-schmidt) ( v seq -- newseq ) - [ dupd proj v- ] each ; - -: gram-schmidt ( seq -- orthogonal ) - V{ } clone [ over (gram-schmidt) suffix! ] reduce ; - -: norm-gram-schmidt ( seq -- orthonormal ) - gram-schmidt [ normalize ] map ; - -ERROR: negative-power-matrix m n ; - -: (m^n) ( m n -- n ) - make-bits over first length identity-matrix - [ [ dupd m. ] when [ dup m. ] dip ] reduce nip ; - -: m^n ( m n -- n ) - dup 0 >= [ (m^n) ] [ negative-power-matrix ] if ; - -: stitch ( m -- m' ) - [ ] [ [ append ] 2map ] map-reduce ; - -: kron ( m1 m2 -- m ) - '[ [ _ n*m ] map ] map stitch stitch ; - -: outer ( u v -- m ) - [ n*v ] curry map ; - -: row ( n matrix -- col ) +: row ( n matrix -- row ) nth ; inline -: rows ( seq matrix -- cols ) +: rows ( seq matrix -- rows ) '[ _ row ] map ; inline : col ( n matrix -- col ) @@ -200,77 +162,151 @@ ERROR: negative-power-matrix m n ; : cols ( seq matrix -- cols ) '[ _ col ] map ; inline -: set-index ( object pair matrix -- ) - [ first2 swap ] dip nth set-nth ; inline +:: >square-matrix ( m -- subset ) + m dimension first2 :> ( x y ) { + { [ x y = ] [ m ] } + { [ x y < ] [ x m cols transpose ] } + { [ x y > ] [ y m rows ] } + } cond ; -: set-indices ( object sequence matrix -- ) - '[ _ set-index ] with each ; inline - -: matrix-map ( matrix quot -- ) - '[ _ map ] map ; inline - -: column-map ( matrix quot -- seq ) - [ [ first length ] keep ] dip '[ _ col @ ] map ; inline - -: cartesian-square-indices ( n -- matrix ) - dup cartesian-product ; inline - -: cartesian-matrix-map ( matrix quot -- matrix' ) - [ [ first length cartesian-square-indices ] keep ] dip - '[ _ @ ] matrix-map ; inline - -: cartesian-matrix-column-map ( matrix quot -- matrix' ) - [ cols first2 ] prepose cartesian-matrix-map ; inline - -: cov-matrix-ddof ( matrix ddof -- cov ) - '[ _ cov-ddof ] cartesian-matrix-column-map ; inline - -: population-cov-matrix ( matrix -- cov ) 0 cov-matrix-ddof ; inline - -: sample-cov-matrix ( matrix -- cov ) 1 cov-matrix-ddof ; inline - -GENERIC: square-rows ( object -- matrix ) -M: integer square-rows square-rows ; -M: sequence square-rows +GENERIC: ( desc -- matrix ) +M: integer + ; +M: sequence [ length ] keep >array '[ _ clone ] { } replicate-as ; -GENERIC: square-cols ( object -- matrix ) -M: integer square-cols square-cols ; -M: sequence square-cols - [ length ] keep [ ] with { } map-as ; +M: square-matrix ; +M: matrix >square-matrix ; ! coercing to square is more useful than no-method -: make-matrix-with-indices ( m n quot -- matrix ) - [ [ ] bi@ ] dip cartesian-map ; inline +GENERIC: ( desc -- matrix ) +M: integer + ; +M: sequence + flip ; -: null-matrix? ( matrix -- ? ) empty? ; inline - -: well-formed-matrix? ( matrix -- ? ) - [ t ] [ - [ ] [ first length ] bi - '[ length _ = ] all? - ] if-empty ; - -: dim ( matrix -- pair/f ) - [ 2 0 ] - [ [ length ] [ first length ] bi 2array ] if-empty ; - -: square-matrix? ( matrix -- ? ) - { [ well-formed-matrix? ] [ dim all-eq? ] } 1&& ; - -: matrix-coordinates ( dim -- coordinates ) - first2 [ ] bi@ cartesian-product ; inline +M: square-matrix ; +M: matrix + >square-matrix ; + and : dimension-range ( matrix -- dim range ) - dim [ matrix-coordinates ] [ first [1,b] ] bi ; + dimension [ ] [ first [1,b] ] bi ; : upper-matrix-indices ( matrix -- matrix' ) dimension-range [ tail-slice* >array ] 2map concat ; : lower-matrix-indices ( matrix -- matrix' ) dimension-range [ head-slice >array ] 2map concat ; +PRIVATE> -: make-lower-matrix ( object m n -- matrix ) - zero-matrix [ lower-matrix-indices ] [ set-indices ] [ ] tri ; +! triangulars +DEFER: matrix-set-nths +: ( object m n -- matrix ) + [ lower-matrix-indices ] [ matrix-set-nths ] [ ] tri ; -: make-upper-matrix ( object m n -- matrix ) - zero-matrix [ upper-matrix-indices ] [ set-indices ] [ ] tri ; +: ( object m n -- matrix ) + [ upper-matrix-indices ] [ matrix-set-nths ] [ ] tri ; + +! element- and sequence-wise operations, getters and setters +: stitch ( m -- m' ) + [ ] [ [ append ] 2map ] map-reduce ; + +: matrix-map ( matrix quot: ( ... elt -- ... elt' ) -- matrix' ) + '[ _ map ] map ; inline + +: column-map ( matrix quot: ( ... col -- ... col' ) -- matrix' ) + [ transpose ] dip map transpose ; inline + +: matrix-nth ( pair matrix -- elt ) + [ first2 swap ] dip nth nth ; inline + +: matrix-nths ( pairs matrix -- elts ) + '[ _ matrix-nth ] map ; inline + +: matrix-set-nth ( obj pair matrix -- ) + [ first2 swap ] dip nth set-nth ; inline + +: matrix-set-nths ( obj pairs matrix -- ) + '[ _ matrix-set-nth ] with each ; inline + +! ------------------------------------------- +! simple math of matrices follows +: mneg ( m -- m' ) [ vneg ] map ; +: mabs ( m -- m' ) [ vabs ] map ; + +: n+m ( n m -- m ) [ n+v ] with map ; +: m+n ( m n -- m ) [ v+n ] curry map ; +: n-m ( n m -- m ) [ n-v ] with map ; +: m-n ( m n -- m ) [ v-n ] curry map ; +: n*m ( n m -- m ) [ n*v ] with map ; +: m*n ( m n -- m ) [ v*n ] curry map ; +: n/m ( n m -- m ) [ n/v ] with map ; +: m/n ( m n -- m ) [ v/n ] curry map ; + +: m+ ( m1 m2 -- m ) [ v+ ] 2map ; +: m- ( m1 m2 -- m ) [ v- ] 2map ; +: m* ( m1 m2 -- m ) [ v* ] 2map ; +: m/ ( m1 m2 -- m ) [ v/ ] 2map ; + +: v.m ( v m -- p ) flip [ v. ] with map ; +: m.v ( m v -- p ) [ v. ] curry map ; +: m. ( m m -- m ) flip [ swap m.v ] curry map ; + +: m~ ( m1 m2 epsilon -- ? ) [ v~ ] curry 2all? ; + +: mmin ( m -- n ) [ 1/0. ] dip [ [ min ] each ] each ; +: mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ; +: mnorm ( m -- m' ) dup mmax abs m/n ; +: m-infinity-norm ( m -- n ) [ [ abs ] map-sum ] map supremum ; +: m-1norm ( m -- n ) flip m-infinity-norm ; +: frobenius-norm ( m -- n ) [ [ sq ] map-sum ] map-sum sqrt ; + +! well-defined for square matrices; but works on nonsquare too +: main-diagonal ( matrix -- seq ) + >square-matrix [ swap nth-unsafe ] map-index ; inline + +! top right to bottom left; reverse the result if you expected it to start in the lower left +: anti-diagonal ( matrix -- seq ) + >square-matrix [ swap nth-end-unsafe ] map-index ; inline + + ; +: (cols-iota) ( matrix -- cols-iota ) + dimension second-unsafe ; + +: simple-rows-except ( matrix desc quot -- others ) + curry [ dup (rows-iota) ] dip + pick reject-as swap rows ; inline + +: simple-cols-except ( matrix desc quot -- others ) + curry [ dup (cols-iota) ] dip + pick reject-as swap cols transpose ; inline ! need to un-transpose the result of cols + +CONSTANT: scalar-except-quot [ = ] +CONSTANT: sequence-except-quot [ member? ] +PRIVATE> + +GENERIC: rows-except ( matrix desc -- others ) +M: integer rows-except scalar-except-quot simple-rows-except ; +M: sequence rows-except sequence-except-quot simple-rows-except ; + +GENERIC: cols-except ( matrix desc -- others ) +M: integer cols-except scalar-except-quot simple-cols-except ; +M: sequence cols-except sequence-except-quot simple-cols-except ; + +! well-defined for any regular matrix +: matrix-except ( matrix exclude-pair -- submatrix ) + first2 [ rows-except ] dip cols-except ; + +ALIAS: submatrix-excluding matrix-except + +:: matrix-except-all ( matrix -- submatrices ) + matrix dimension [ ] map first2-unsafe cartesian-product + [ [ matrix swap matrix-except ] map ] map ; + +ALIAS: all-submatrices matrix-except-all + +: dimension ( matrix -- dimension ) + [ { 0 0 } ] + [ [ length ] [ first-unsafe length ] bi 2array ] if-empty ; diff --git a/basis/math/vectors/vectors-docs.factor b/basis/math/vectors/vectors-docs.factor index ddc0c45020..8912672bdc 100644 --- a/basis/math/vectors/vectors-docs.factor +++ b/basis/math/vectors/vectors-docs.factor @@ -315,11 +315,11 @@ HELP: vclamp } ; HELP: v. -{ $values { "u" { $sequence real } } { "v" { $sequence real } } { "x" "a real number" } } +{ $values { "u" { $sequence real } } { "v" { $sequence real } } { "x" real } } { $description "Computes the dot product of two vectors." } ; HELP: h. -{ $values { "u" { $sequence real } } { "v" { $sequence real } } { "x" "a real number" } } +{ $values { "u" { $sequence real } } { "v" { $sequence real } } { "x" real } } { $description "Computes the Hermitian inner product of two vectors." } ; HELP: vs+ diff --git a/basis/math/vectors/vectors-tests.factor b/basis/math/vectors/vectors-tests.factor index bf4e99ee5a..140fae23aa 100644 --- a/basis/math/vectors/vectors-tests.factor +++ b/basis/math/vectors/vectors-tests.factor @@ -2,6 +2,7 @@ USING: math.vectors tools.test kernel specialized-arrays compiler kernel.private alien.c-types math.functions ; SPECIALIZED-ARRAY: int +{ { 10 20 30 } } [ 10 { 1 2 3 } n*v ] unit-test { { 1 2 3 } } [ 1/2 { 2 4 6 } n*v ] unit-test { { 1 2 3 } } [ { 2 4 6 } 1/2 v*n ] unit-test { { 1 2 3 } } [ { 2 4 6 } 2 v/n ] unit-test @@ -49,3 +50,10 @@ SPECIALIZED-ARRAY: int { { 0 30 100 } } [ { -10 30 120 } { 0 0 0 } { 100 100 100 } vclamp ] unit-test + +{ { 0 0 1 } } [ { 1 0 0 } { 0 1 0 } cross ] unit-test +{ { 1 0 0 } } [ { 0 1 0 } { 0 0 1 } cross ] unit-test +{ { 0 1 0 } } [ { 0 0 1 } { 1 0 0 } cross ] unit-test +{ { 0.0 -0.707 0.707 } } [ { 1.0 0.0 0.0 } { 0.0 0.707 0.707 } cross ] unit-test +{ { 0 -2 2 } } [ { -1 -1 -1 } { 1 -1 -1 } cross ] unit-test +{ { 1 0 0 } } [ { 1 1 0 } { 1 0 0 } proj ] unit-test diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index 8ae3cc4fbf..a35b9696a9 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -279,3 +279,19 @@ PRIVATE> : vclamp ( v min max -- w ) rot vmin vmax ; inline + +: cross ( vec1 vec2 -- vec3 ) + [ [ { 1 2 0 } vshuffle ] [ { 2 0 1 } vshuffle ] bi* v* ] + [ [ { 2 0 1 } vshuffle ] [ { 1 2 0 } vshuffle ] bi* v* ] 2bi v- ; inline + +:: normal ( vec1 vec2 vec3 -- vec4 ) + vec2 vec1 v- vec3 vec1 v- cross normalize ; inline + +: proj ( v u -- w ) + [ [ v. ] [ norm-sq ] bi / ] keep n*v ; + +: perp ( v u -- w ) + dupd proj v- ; + +: angle-between ( v u -- a ) + [ normalize ] bi@ h. acos ; diff --git a/extra/benchmark/3d-matrix-scalar/3d-matrix-scalar.factor b/extra/benchmark/3d-matrix-scalar/3d-matrix-scalar.factor index 9515a330ef..1db2e013c5 100644 --- a/extra/benchmark/3d-matrix-scalar/3d-matrix-scalar.factor +++ b/extra/benchmark/3d-matrix-scalar/3d-matrix-scalar.factor @@ -1,15 +1,15 @@ -USING: kernel locals math math.matrices math.order math.vectors -prettyprint sequences ; +USING: kernel locals math math.matrices math.matrices.extras +math.order math.vectors prettyprint sequences ; IN: benchmark.3d-matrix-scalar :: p-matrix ( dim fov near far -- matrix ) dim dup first2 min v/n fov v*n near v*n - near far frustum-matrix4 ; + near far ; :: mv-matrix ( pitch yaw location -- matrix ) - { 1.0 0.0 0.0 } pitch rotation-matrix4 - { 0.0 1.0 0.0 } yaw rotation-matrix4 - location vneg translation-matrix4 m. m. ; + { 1.0 0.0 0.0 } pitch + { 0.0 1.0 0.0 } yaw + location vneg m. m. ; :: 3d-matrix-scalar-benchmark ( -- ) f :> result! diff --git a/extra/benchmark/3d-matrix-vector/3d-matrix-vector.factor b/extra/benchmark/3d-matrix-vector/3d-matrix-vector.factor index c489079bd4..218091cce4 100644 --- a/extra/benchmark/3d-matrix-vector/3d-matrix-vector.factor +++ b/extra/benchmark/3d-matrix-vector/3d-matrix-vector.factor @@ -1,5 +1,6 @@ -USING: kernel locals math math.matrices.simd math.order math.vectors -math.vectors.simd prettyprint sequences typed ; +USING: kernel locals math math.matrices math.matrices.simd +math.order math.vectors math.vectors.simd prettyprint sequences +typed ; QUALIFIED-WITH: alien.c-types c IN: benchmark.3d-matrix-vector diff --git a/extra/benchmark/matrix-exponential-scalar/matrix-exponential-scalar.factor b/extra/benchmark/matrix-exponential-scalar/matrix-exponential-scalar.factor index 8324f8266e..caee9bb773 100644 --- a/extra/benchmark/matrix-exponential-scalar/matrix-exponential-scalar.factor +++ b/extra/benchmark/matrix-exponential-scalar/matrix-exponential-scalar.factor @@ -1,4 +1,4 @@ -USING: locals math math.combinatorics math.matrices +USING: locals math math.combinatorics math.matrices math.matrices.extras prettyprint sequences typed ; IN: benchmark.matrix-exponential-scalar @@ -15,7 +15,7 @@ IN: benchmark.matrix-exponential-scalar :: matrix-exponential-scalar-benchmark ( -- ) f :> result! - 4 identity-matrix :> i4 + 4 :> i4 10000 [ i4 20 e^m result! ] times diff --git a/extra/game/debug/tests/tests.factor b/extra/game/debug/tests/tests.factor index 818b404534..15638156d0 100644 --- a/extra/game/debug/tests/tests.factor +++ b/extra/game/debug/tests/tests.factor @@ -2,8 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors colors.constants game.debug game.loop game.worlds gpu gpu.framebuffers gpu.util.wasd kernel literals -locals make math math.matrices math.parser math.trig sequences -specialized-arrays ui.gadgets.worlds ui.pixel-formats ; +locals make math math.matrices math.matrices.extras math.parser +math.trig sequences specialized-arrays ui.gadgets.worlds +ui.pixel-formats ; FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float IN: game.debug.tests @@ -21,7 +22,7 @@ IN: game.debug.tests { 0 0 0 } { 1 0 0 } COLOR: red debug-line { 0 0 0 } { 0 1 0 } COLOR: green debug-line { 0 0 0 } { 0 0 1 } COLOR: blue debug-line - { -1.2 0 0 } { 0 1 0 } 0 deg>rad rotation-matrix3 debug-axes + { -1.2 0 0 } { 0 1 0 } 0 deg>rad debug-axes { 3 5 -2 } { 3 2 1 } COLOR: white debug-box { 0 9 0 } 8 2 COLOR: blue debug-cylinder ] float-array{ } make diff --git a/extra/gml/geometry/geometry.factor b/extra/gml/geometry/geometry.factor index 0a1acff745..1197e99216 100644 --- a/extra/gml/geometry/geometry.factor +++ b/extra/gml/geometry/geometry.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2010 Slava Pestov. -USING: arrays kernel math.matrices math.vectors.simd.cords -math.trig gml.runtime ; +USING: arrays gml.runtime kernel math.matrices +math.matrices.extras math.trig math.vectors.simd.cords ; IN: gml.geometry GML: rot_vec ( v n alpha -- v ) ! Inefficient! - deg>rad rotation-matrix4 swap >array m.v >double-4 ; + deg>rad swap >array m.v >double-4 ; diff --git a/extra/gpu/demos/raytrace/raytrace.factor b/extra/gpu/demos/raytrace/raytrace.factor index fdffa86c9c..ced1af3816 100644 --- a/extra/gpu/demos/raytrace/raytrace.factor +++ b/extra/gpu/demos/raytrace/raytrace.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators.tuple game.loop game.worlds generalizations gpu gpu.render gpu.shaders gpu.util gpu.util.wasd -kernel literals math math.libm math.matrices math.order math.vectors -method-chains sequences ui ui.gadgets ui.gadgets.worlds -ui.pixel-formats audio.engine audio.loader locals ; +kernel literals math math.libm math.matrices math.matrices.extras +math.order math.vectors method-chains sequences ui ui.gadgets +ui.gadgets.worlds ui.pixel-formats audio.engine audio.loader locals ; IN: gpu.demos.raytrace GLSL-SHADER-FILE: raytrace-vertex-shader vertex-shader "raytrace.v.glsl" @@ -48,7 +48,7 @@ TUPLE: raytrace-world < wasd-world dup dtheta>> [ + ] curry change-theta drop ; : sphere-center ( sphere -- center ) - [ [ axis>> ] [ theta>> ] bi rotation-matrix4 ] + [ [ axis>> ] [ theta>> ] bi ] [ home>> ] bi m.v ; M: sphere audio-position sphere-center ; inline diff --git a/extra/gpu/util/wasd/wasd.factor b/extra/gpu/util/wasd/wasd.factor index 46f265e9e5..40c5f653f2 100644 --- a/extra/gpu/util/wasd/wasd.factor +++ b/extra/gpu/util/wasd/wasd.factor @@ -4,8 +4,8 @@ USING: accessors arrays combinators.smart game.input game.input.scancodes game.loop game.worlds gpu.render gpu.state kernel literals locals math math.constants math.functions math.matrices -math.order math.vectors opengl.gl sequences -ui ui.gadgets.worlds specialized-arrays audio.engine ; +math.matrices.extras math.order math.vectors opengl.gl +sequences ui ui.gadgets.worlds specialized-arrays audio.engine ; FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float IN: gpu.util.wasd @@ -38,14 +38,14 @@ GENERIC: wasd-fly-vertically? ( world -- ? ) M: wasd-world wasd-fly-vertically? drop t ; : wasd-mv-matrix ( world -- matrix ) - [ { 1.0 0.0 0.0 } swap pitch>> rotation-matrix4 ] - [ { 0.0 1.0 0.0 } swap yaw>> rotation-matrix4 ] - [ location>> vneg translation-matrix4 ] tri m. m. ; + [ { 1.0 0.0 0.0 } swap pitch>> ] + [ { 0.0 1.0 0.0 } swap yaw>> ] + [ location>> vneg ] tri m. m. ; : wasd-mv-inv-matrix ( world -- matrix ) - [ location>> translation-matrix4 ] - [ { 0.0 -1.0 0.0 } swap yaw>> rotation-matrix4 ] - [ { -1.0 0.0 0.0 } swap pitch>> rotation-matrix4 ] tri m. m. ; + [ location>> ] + [ { 0.0 -1.0 0.0 } swap yaw>> ] + [ { -1.0 0.0 0.0 } swap pitch>> ] tri m. m. ; : wasd-p-matrix ( world -- matrix ) p-matrix>> ; @@ -63,7 +63,7 @@ CONSTANT: fov 0.7 world wasd-far-plane :> far-plane world wasd-fov-vector near-plane v*n - near-plane far-plane frustum-matrix4 ; + near-plane far-plane ; :: wasd-pixel-ray ( world loc -- direction ) loc world dim>> [ /f 0.5 - 2.0 * ] 2map diff --git a/basis/math/matrices/elimination/authors.txt b/extra/math/matrices/elimination/authors.txt similarity index 100% rename from basis/math/matrices/elimination/authors.txt rename to extra/math/matrices/elimination/authors.txt diff --git a/basis/math/matrices/elimination/elimination-docs.factor b/extra/math/matrices/elimination/elimination-docs.factor similarity index 86% rename from basis/math/matrices/elimination/elimination-docs.factor rename to extra/math/matrices/elimination/elimination-docs.factor index 9ea3f607d6..d0de9d17fe 100644 --- a/basis/math/matrices/elimination/elimination-docs.factor +++ b/extra/math/matrices/elimination/elimination-docs.factor @@ -8,8 +8,9 @@ HELP: inverse { $examples "A matrix multiplied by its inverse is the identity matrix." { $example - "USING: kernel math.matrices math.matrices.elimination prettyprint ;" - "{ { 3 4 } { 7 9 } } dup inverse m. 2 identity-matrix = ." + "USING: kernel math.matrices prettyprint ;" + "FROM: math.matrices.elimination => inverse ;" + "{ { 3 4 } { 7 9 } } dup inverse m. 2 = ." "t" } } ; diff --git a/basis/math/matrices/elimination/elimination-tests.factor b/extra/math/matrices/elimination/elimination-tests.factor similarity index 100% rename from basis/math/matrices/elimination/elimination-tests.factor rename to extra/math/matrices/elimination/elimination-tests.factor diff --git a/basis/math/matrices/elimination/elimination.factor b/extra/math/matrices/elimination/elimination.factor similarity index 96% rename from basis/math/matrices/elimination/elimination.factor rename to extra/math/matrices/elimination/elimination.factor index 244cf2f42f..19af0a4965 100644 --- a/basis/math/matrices/elimination/elimination.factor +++ b/extra/math/matrices/elimination/elimination.factor @@ -93,7 +93,7 @@ SYMBOL: matrix : nullspace ( matrix -- seq ) echelon reduced dup empty? [ - dup first length identity-matrix [ + dup first length [ [ dup leading drop [ basis-vector ] [ drop ] if* @@ -109,5 +109,5 @@ SYMBOL: matrix : inverse ( matrix -- matrix ) ! Assumes an invertible matrix dup length - [ identity-matrix [ append ] 2map solution ] keep + [ [ append ] 2map solution ] keep [ tail ] curry map ; diff --git a/basis/math/matrices/elimination/summary.txt b/extra/math/matrices/elimination/summary.txt similarity index 100% rename from basis/math/matrices/elimination/summary.txt rename to extra/math/matrices/elimination/summary.txt diff --git a/extra/math/matrices/extras/authors.txt b/extra/math/matrices/extras/authors.txt new file mode 100644 index 0000000000..26ec2689aa --- /dev/null +++ b/extra/math/matrices/extras/authors.txt @@ -0,0 +1,4 @@ +Slava Pestov +Joe Groff +Doug Coleman +Cat Stevens diff --git a/extra/math/matrices/extras/extras-docs.factor b/extra/math/matrices/extras/extras-docs.factor new file mode 100644 index 0000000000..b16f015a0a --- /dev/null +++ b/extra/math/matrices/extras/extras-docs.factor @@ -0,0 +1,641 @@ +USING: arrays generic.single help.markup help.syntax kernel math +math.matrices math.matrices.private math.matrices.extras +math.order math.ratios math.vectors opengl.gl random sequences +urls ; +IN: math.matrices.extras + +ABOUT: "math.matrices.extras" + +ARTICLE: "math.matrices.extras" "Extra matrix operations" + +"These constructions have special mathematical properties:" +{ $subsections + + + + + +} + +"Common transformation matrices:" +{ $subsections + + + + + + + + + + + + +} + + +{ $subsections + invertible-matrix? + linearly-independent-matrix? +} + +"Common algorithms on matrices:" +{ $subsections + gram-schmidt + gram-schmidt-normalize + kronecker-product + outer-product +} + +"Matrix algebra:" +{ $subsections + mmin + mmax + mnorm + rank + nullity + +} { $subsections + determinant 1/det m*1/det + >minors >cofactors + multiplicative-inverse +} + +"Covariance in matrices:" +{ $subsections + covariance-matrix + covariance-matrix-ddof + sample-covariance-matrix +} + +"Errors thrown by this vocabulary:" +{ $subsections negative-power-matrix non-square-determinant undefined-inverse } ; + +HELP: invertible-matrix? +{ $values { "matrix" matrix } { "?" boolean } } +{ $description "Tests whether the input matrix has a " { $link multiplicative-inverse } ". In order for a matrix to be invertible, it must be a " { $link square-matrix } ", " { $emphasis "or" } ", if it is non-square, it must not be of " { $link +deficient-rank+ } "." } +{ $examples { $example "USING: math.matrices.extras prettyprint ;" "" } } ; + +HELP: linearly-independent-matrix? +{ $values { "matrix" matrix } { "?" boolean } } +{ $description "Tests whether the input matrix is linearly independent." } +{ $examples { $example "USING: math.matrices.extras prettyprint ;" "" } } ; + +! SINGLETON RANK TYPES +HELP: rank-kind +{ $class-description "The class of matrix rank quantifiers." } ; + +HELP: +full-rank+ +{ $class-description "A " { $link rank-kind } " describing a matrix of full rank." } ; +HELP: +half-rank+ +{ $class-description "A " { $link rank-kind } " describing a matrix of half rank." } ; +HELP: +zero-rank+ +{ $class-description "A " { $link rank-kind } " describing a matrix of zero rank." } ; +HELP: +deficient-rank+ +{ $class-description "A " { $link rank-kind } " describing a matrix of deficient rank." } ; +HELP: +uncalculated-rank+ +{ $class-description "A " { $link rank-kind } " describing a matrix whose rank is not (yet) known." } ; + +! ERRORS + +HELP: negative-power-matrix +{ $values { "m" matrix } { "n" integer } } +{ $description "Throws a " { $link negative-power-matrix } " error." } +{ $error-description "Given the semantics of " { $link m^n } ", negative exponents are not within the domain of the power matrix function." } ; + +HELP: non-square-determinant +{ $values { "m" integer } { "n" integer } } +{ $description "Throws a " { $link non-square-determinant } " error." } +{ $error-description { $link determinant } " was used with a non-square matrix whose dimensions are " { $snippet "m x n" } ". It is not generally possible to find the determinant of a non-square matrix." } ; + +HELP: undefined-inverse +{ $values { "m" integer } { "n" integer } { "r" rank-kind } } +{ $description "Throws an " { $link undefined-inverse } " error." } +{ $error-description { $link multiplicative-inverse } " was used with a non-square matrix of rank " { $snippet "rank" } " whose dimensions are " { $snippet "m x n" } ". It is not generally possible to find the inverse of a " { $link +deficient-rank+ } " non-square " { $link matrix } "." } ; + +HELP: +{ $values { "m" integer } { "n" integer } { "max" integer } { "matrix" matrix } } +{ $description "Creates a " { $snippet "m x n" } " " { $link matrix } " full of random, possibly signed " { $link integer } "s whose absolute values are less than or equal to " { $snippet "max" } ", as given by " { $link random-integers } "." } +{ $notelist + { "The signedness of the numbers in the resulting matrix will be randomized. Use " { $link mabs } " with this word to generate a matrix of random positive integers." } + { $equiv-word-note "integral" } +} +{ $errors { $link no-method } " if " { $snippet "max"} " is not an " { $link integer } "." } +{ $examples + { $unchecked-example + "USING: math.matrices.extras prettyprint ;" + "2 4 15 ." + "{ { -9 -9 1 3 } { -14 -8 14 10 } }" + } +} ; + +HELP: +{ $values { "m" integer } { "n" integer } { "max" number } { "matrix" matrix } } +{ $description "Creates a " { $snippet "m x n" } " " { $link matrix } " full of random, possibly signed " { $link float } "s as a fraction of " { $snippet "max" } "." } +{ $notelist + { "The signedness of the numbers in the resulting matrix will be randomized. Use " { $link mabs } " with this word to generate a matrix of random positive numbers." } + { $equiv-word-note "real" } + { "This word is implemented by generating sub-integral floats through " { $link random-units } " and multiplying by random integers less than or equal to " { $snippet "max" } "." } +} +{ $examples + { $unchecked-example + "USING: math.matrices.extras prettyprint ;" + "4 2 15 ." +"{ + { -3.713295909201797 3.815787135075961 } + { -2.460506890603817 1.535222788710546 } + { 3.692213981267878 -1.462963244399762 } + { 13.8967592095433 -6.688509969360172 } +}" + } +} ; + + + +HELP: +{ $values { "n" integer } { "matrix" matrix } } +{ $description + "A Hankel matrix is a symmetric, " { $link square-matrix } " in which each ascending skew-diagonal from left to right is constant. See " { $url URL" https://en.wikipedia.org/wiki/Hankel_matrix" "hankel matrix" } "." + $nl + "The following is true of any Hankel matrix" { $snippet "A" } ": " { $snippet "A[i][j] = A[j][i] = a[i+j-2]" } "." + $nl + "The " { $link } " is an upside-down Hankel matrix." + $nl + "The " { $link } " is a special case of the Hankel matrix." +} +{ $examples + { $example + "USING: math.matrices.extras prettyprint ;" + "4 ." + "{ { 1 2 3 4 } { 2 3 4 0 } { 3 4 0 0 } { 4 0 0 0 } }" + } +} ; + +HELP: +{ $values { "m" integer } { "n" integer } { "matrix" matrix } } +{ $description + "A Hilbert matrix is a " { $link square-matrix } " " { $snippet "A" } " in which entries are the unit fractions " + { $snippet "A[i][j] = 1/(i+j-1)" } + ". See " { $url URL" https://en.wikipedia.org/wiki/Hilbert_matrix" "hilbert matrix" } "." + $nl + "A Hilbert matrix is a special case of the " { $link } "." +} +{ $examples + { $example + "USING: math.matrices.extras prettyprint ;" + "1 2 ." + "{ { 1 1/2 } }" + } + { $example + "USING: math.matrices.extras prettyprint ;" + "3 6 ." +"{ + { 1 1/2 1/3 1/4 1/5 1/6 } + { 1/2 1/3 1/4 1/5 1/6 1/7 } + { 1/3 1/4 1/5 1/6 1/7 1/8 } +}" + } +} ; + +HELP: +{ $values { "n" integer } { "matrix" matrix } } +{ $description "A Toeplitz matrix is an upside-down " { $link } ". Unlike the Hankel matrix, a Toeplitz matrix can be non-square. See " { $url URL" https://en.wikipedia.org/wiki/Hankel_matrix" "hankel matrix" } "." +} +{ $examples + { $example + "USING: math.matrices.extras prettyprint ;" + "4 ." + "{ { 1 2 3 4 } { 2 1 2 3 } { 3 2 1 2 } { 4 3 2 1 } }" + } +} ; + +HELP: +{ $values { "r" integer } { "matrix" matrix } } +{ $description "Create a box matrix (a " { $link square-matrix } ") with the dimensions of " { $snippet "r x r" } ", filled with ones. The number of elements in the output scales linearly (" { $snippet "(r*2)+1" } ") with " { $snippet "r" } "." } +{ $examples + { $example + "USING: math.matrices.extras prettyprint ;" + "2 ." +"{ + { 1 1 1 1 1 } + { 1 1 1 1 1 } + { 1 1 1 1 1 } + { 1 1 1 1 1 } + { 1 1 1 1 1 } +}" + } + { $example + "USING: math.matrices.extras prettyprint ;" + "3 ." +"{ + { 1 1 1 1 1 1 1 } + { 1 1 1 1 1 1 1 } + { 1 1 1 1 1 1 1 } + { 1 1 1 1 1 1 1 } + { 1 1 1 1 1 1 1 } + { 1 1 1 1 1 1 1 } + { 1 1 1 1 1 1 1 } +}" + } + +} ; + +HELP: +{ $values { "factors" sequence } { "matrix" matrix } } +{ $description "Make a " { $snippet "3 x 3" } " scaling matrix, used to scale an object in 3 dimensions. See " { $url URL" https://en.wikipedia.org/wiki/Scaling_(geometry)#Matrix_representation" "scaling matrix on Wikipedia" } "." } +{ $notelist + { $finite-input-note "three" "factors" } + { $equiv-word-note "3-matrix" } +} +{ $examples + { $example + "USING: math.matrices.extras prettyprint ;" + "{ 22 33 -44 } ." +"{ + { 22 0.0 0.0 0.0 } + { 0.0 33 0.0 0.0 } + { 0.0 0.0 -44 0.0 } + { 0.0 0.0 0.0 1.0 } +}" + } +} ; + +HELP: +{ $values { "factors" sequence } { "matrix" matrix } } +{ $description "Make a " { $snippet "4 x 4" } " scaling matrix, used to scale an object in 3 or more dimensions. See " { $url URL" https://en.wikipedia.org/wiki/Scaling_(geometry)#Matrix_representation" "scaling matrix on Wikipedia" } "." } +{ $notelist + { $finite-input-note "three" "factors" } + { $equiv-word-note "4-matrix" } +} +{ $examples + { $example + "USING: math.matrices.extras prettyprint ;" + "{ 22 33 -44 } ." +"{ + { 22 0.0 0.0 0.0 } + { 0.0 33 0.0 0.0 } + { 0.0 0.0 -44 0.0 } + { 0.0 0.0 0.0 1.0 } +}" + } +} ; + +HELP: +{ $values { "factors" sequence } { "matrix" matrix } } +{ $description "Create a " { $link } ", with the scale factors inverted." } +{ $notelist + { $finite-input-note "three" "factors" } + { $equiv-word-note "inverse" } +} +{ $examples + { $example + "USING: math.matrices.extras prettyprint ;" + "{ -9.3 100 1/2 } ." +"{ + { -0.1075268817204301 0.0 0.0 0.0 } + { 0.0 1/100 0.0 0.0 } + { 0.0 0.0 2 0.0 } + { 0.0 0.0 0.0 1.0 } +}" + } +} ; + +HELP: +{ $values { "xy-dim" pair } { "near" number } { "far" number } { "matrix" matrix } } +{ $description "Make a " { $snippet "4 x 4" } " matrix suitable for representing an occlusion frustum. A viewing or occlusion frustum is the three-dimensional region of a three-dimensional object which is visible on the screen. See " { $url URL" https://en.wikipedia.org/wiki/Frustum" "frustum on Wikipedia" } "." } +{ $notes { $finite-input-note "two" "xy-dim" } } +{ $examples + { $example + "USING: math.matrices.extras prettyprint ;" + "{ 5 4 } 5 6 ." +"{ + { 1.0 0.0 0.0 0.0 } + { 0.0 1.25 0.0 0.0 } + { 0.0 0.0 -11.0 -60.0 } + { 0.0 0.0 -1.0 0.0 } +}" + } +} ; +{ glFrustum } related-words + +HELP: cartesian-matrix-map +{ $values { "matrix" matrix } { "quot" { $quotation ( ... pair matrix -- ... matrix' ) } } { "matrix-seq" { $sequence matrix } } } +{ $description "Calls the quotation with the matrix and the coordinate pair of the current element on the stack, with the matrix on the top of the stack." } +{ $examples + { $example + "USING: arrays math.matrices.extras prettyprint ;" + "{ { 21 22 } { 23 24 } } [ 2array ] cartesian-matrix-map ." +"{ + { + { { 0 0 } { { 21 22 } { 23 24 } } } + { { 0 1 } { { 21 22 } { 23 24 } } } + } + { + { { 1 0 } { { 21 22 } { 23 24 } } } + { { 1 1 } { { 21 22 } { 23 24 } } } + } +}" + } +} +{ $notelist + { $equiv-word-note "orthogonal" cartesian-column-map } + { $equiv-word-note "two-dimensional" map-index } + $2d-only-note +} ; + +HELP: cartesian-column-map +{ $values { "matrix" matrix } { "quot" { $quotation ( ... pair matrix -- ... matrix' ) } } { "matrix-seq" { $sequence matrix } } } +{ $notelist + { $equiv-word-note "orthogonal" cartesian-matrix-map } + $2d-only-note +} ; + +HELP: gram-schmidt +{ $values { "matrix" matrix } { "orthogonal" matrix } } +{ $description "Apply a Gram-Schmidt transform on the matrix." } +{ $examples + { $example + "USING: math.matrices.extras prettyprint ;" + "{ { 1 2 } { 3 4 } { 5 6 } } gram-schmidt ." + "{ { 1 2 } { 4/5 -2/5 } { 0 0 } }" + } +} ; + +HELP: gram-schmidt-normalize +{ $values { "matrix" matrix } { "orthonormal" matrix } } +{ $description "Apply a Gram-Schmidt transform on the matrix, and " { $link normalize } " each row of the result, resulting in an orthogonal and normalized matrix (orthonormal)." } +{ $examples + { $example + "USING: math.matrices.extras prettyprint ;" + "{ { 1 2 } { 3 4 } { 5 6 } } gram-schmidt-normalize ." +"{ + { 0.4472135954999579 0.8944271909999159 } + { 0.894427190999916 -0.447213595499958 } + { NAN: 8000000000000 NAN: 8000000000000 } +}" + } +} ; + +HELP: m^n +{ $values { "m" matrix } { "n" object } } +{ $description "Compute the " { $snippet "nth" } " power of the input matrix. If " { $snippet "n" } " is " { $snippet "-1" } ", the inverse of the matrix is calculated (but see " { $link multiplicative-inverse } " for pitfalls)." } +{ $errors + { $link negative-power-matrix } " if " { $snippet "n" } " is a negative number other than " { $snippet "-1" } "." + $nl + { $link undefined-inverse } " if " { $snippet "n" } " is " { $snippet "-1" } " and the " { $link multiplicative-inverse } " of " { $snippet "m" } " is undefined." +} +{ $notelist + { $equiv-word-note "swapped" n^m } + $2d-only-note + { $matrix-scalar-note max abs / } +} +{ $examples + { $example + "USING: math.matrices.extras prettyprint ;" + "{ { 1 2 } { 3 4 } } 2 m^n ." + "{ { 7 10 } { 15 22 } }" + } +} ; + +HELP: n^m +{ $values { "n" object } { "m" matrix } } +{ $description "Because it is nonsensical to raise a number to the power of a matrix, this word exists to save typing " { $snippet "swap m^n" } ". See " { $link m^n } " for more information." } +{ $errors + { $link negative-power-matrix } " if " { $snippet "n" } " is a negative number other than " { $snippet "-1" } "." + $nl + { $link undefined-inverse } " if " { $snippet "n" } " is " { $snippet "-1" } " and the " { $link multiplicative-inverse } " of " { $snippet "m" } " is undefined." +} +{ $notelist + { $equiv-word-note "swapped" m^n } + $2d-only-note + { $matrix-scalar-note max abs / } +} +{ $examples + { $example + "USING: math.matrices.extras prettyprint ;" + "2 { { 1 2 } { 3 4 } } n^m ." + "{ { 7 10 } { 15 22 } }" + } +} ; + +HELP: kronecker-product +{ $values { "m1" matrix } { "m2" matrix } { "m" matrix } } +{ $description "Calculates the " { $url URL" http://enwp.org/Kronecker_product" "Kronecker product" } " of two matrices. This product can be described as a generalization of the vector-based " { $link outer-product } " to matrices. The Kronecker product gives the matrix of the tensor product with respect to a standard choice of basis." } +{ $notelist + { $equiv-word-note "matrix" outer-product } + $2d-only-note + { $matrix-scalar-note * } +} +{ $examples + { $unchecked-example + "USING: math.matrices.extras prettyprint ;" +"{ + { 1 2 } + { 3 4 } +} { + { 0 5 } + { 6 7 } +} kronecker-product ." +"{ + { 0 5 0 10 } + { 6 7 12 14 } + { 0 15 0 20 } + { 18 21 24 28 } +}" } +} ; + +HELP: outer-product +{ $values { "u" sequence } { "v" sequence } { "matrix" matrix } } +{ $description "Computes the " { $url URL" http:// enwp.org/Outer_product" "outer-product product" } " of " { $snippet "u" } " and " { $snippet "v" } "." } +{ $examples + { $example + "USING: math.matrices.extras prettyprint ;" + "{ 5 6 7 } { 1 2 3 } outer-product ." + "{ { 5 10 15 } { 6 12 18 } { 7 14 21 } }" } +} ; + +HELP: rank +{ $values { "matrix" matrix } { "rank" rank-kind } } +{ $contract "The " { $emphasis "rank" } " of a " { $link matrix } " is how its number of linearly independent columns compare to the maximal number of linearly independent columns for a matrix with the same dimension." } +{ $notes "See " { $url "https://en.wikipedia.org/wiki/Rank_(linear_algebra)" } " for more information." } ; + +HELP: nullity +{ $values { "matrix" matrix } { "nullity" rank-kind } } +; + +HELP: determinant +{ $values { "matrix" square-matrix } { "determinant" number } } +{ $contract "Compute the determinant of the input matrix. Generally, the determinant of a matrix is a scaling factor of the transformation described by the matrix." } +{ $notelist + $2d-only-note + { $matrix-scalar-note max - * } +} +{ $errors { $link non-square-determinant } " if the input matrix is not a " { $link square-matrix } "." } +{ $examples + { $example + "USING: math.matrices.extras prettyprint ;" +"{ + { 3 0 -1 } + { -3 1 3 } + { 2 -5 4 } +} determinant ." + "44" + } + { $example + "USING: math.matrices.extras prettyprint ;" +"{ + { -8 -8 13 11 10 -5 -14 } + { 3 -11 -8 3 -7 -3 4 } + { 10 4 -5 3 0 -6 -12 } + { -14 0 -3 -8 10 0 10 } + { 3 -6 1 -10 -9 10 0 } + { 5 -12 -14 6 5 -1 -7 } + { -9 -14 -8 5 2 2 -2 } +} determinant ." + "-103488155" + } +} ; + +HELP: 1/det +{ $values { "matrix" square-matrix } { "1/det" number } } +{ $description "Find the inverse (" { $link recip } ") of the " { $link determinant } " of the input matrix." } +{ $notelist + $2d-only-note + { $matrix-scalar-note determinant recip } +} +{ $errors + { $link non-square-determinant } " if the input matrix is not a " { $link square-matrix } "." + $nl + { $link division-by-zero } " if the " { $link determinant } " of the input matrix is " { $snippet "0" } "." +} +{ $examples + { $example + "USING: math.matrices.extras prettyprint ;" +"{ + { 0 10 -12 4 } + { -9 6 -11 9 } + { -5 -10 0 2 } + { -7 -11 10 11 } +} 1/det ." + "-1/9086" + } +} ; + +HELP: m*1/det +{ $values { "matrix" square-matrix } { "matrix'" square-matrix } } +{ $description "Multiply the input matrix by the inverse (" { $link recip } ") of its " { $link determinant } "." } +{ $notelist + { "This word is used to implement " { $link recip } " for " { $link square-matrix } "." } + $2d-only-note + { $matrix-scalar-note determinant recip } +} +{ $examples + { $example + "USING: math.matrices.extras prettyprint ;" +"{ + { -14 0 -13 7 } + { -4 11 7 -12 } + { -3 2 9 -14 } + { 3 -5 10 -2 } +} m*1/det ." +"{ + { 7/6855 0 13/13710 -7/13710 } + { 2/6855 -11/13710 -7/13710 2/2285 } + { 1/4570 -1/6855 -3/4570 7/6855 } + { -1/4570 1/2742 -1/1371 1/6855 } +}" + } +} +; + +HELP: >minors +{ $values { "matrix" square-matrix } { "matrix'" square-matrix } } +{ $description "Calculate the " { $emphasis "matrix of minors" } " of the input matrix. See " { $url URL" https://en.wikipedia.org/wiki/Minor_(linear_algebra)" "minor on Wikipedia" } "." } +{ $notelist + $keep-shape-note + $2d-only-note + { $matrix-scalar-note determinant } +} +{ $errors { $link non-square-determinant } " if the input matrix is not a " { $link square-matrix } "." } +{ $examples + { $example + "USING: math.matrices.extras prettyprint ;" +"{ + { -8 0 7 -11 } + { 15 0 -3 -11 } + { 1 -10 -4 6 } + { 11 -15 3 -15 } +} >minors ." +"{ + { 1710 -130 2555 -1635 } + { -690 -286 -2965 1385 } + { 1650 -754 3795 -1215 } + { 1100 416 2530 -810 } +}" + } +} ; + +HELP: >cofactors +{ $values { "matrix" matrix } { "matrix'" matrix } } +{ $description "Calculate the " { $emphasis "matrix of cofactors" } " of the input matrix. See " { $url URL" https://en.wikipedia.org/wiki/Minor_(linear_algebra)#Inverse_of_a_matrix" "matrix of cofactors on Wikipedia" } ". Alternating elements of the input matrix have their signs inverted." $nl "On odd rows, the even elements have their signs inverted. On even rows, odd elements have their signs inverted." } +{ $notelist + $keep-shape-note + $2d-only-note + { $matrix-scalar-note neg } +} +{ $examples + { $example + "USING: math.matrices.extras prettyprint ;" +"{ + { 8 0 7 11 } + { 15 0 3 11 } + { 1 10 4 6 } + { 11 15 3 15 } +} >cofactors ." +"{ + { 8 0 7 -11 } + { -15 0 -3 11 } + { 1 -10 4 -6 } + { -11 15 -3 15 } +}" + } + { $example + "USING: math.matrices.extras prettyprint ;" +"{ + { -8 0 7 -11 } + { 15 0 -3 -11 } + { 1 -10 -4 6 } + { 11 -15 3 -15 } +} >cofactors ." +"{ + { -8 0 7 11 } + { -15 0 3 -11 } + { 1 10 -4 -6 } + { -11 -15 -3 -15 } +}" + } +} ; + +HELP: multiplicative-inverse +{ $values { "x" matrix } { "y" matrix } } +{ $description "Calculate the multiplicative inverse of the input." $nl "If the input is a " { $link square-matrix } ", this is done by multiplying the " { $link transpose } " of the " { $link2 >cofactors "cofactors" } " of the " { $link2 >minors "minors" } " of the input matrix by the " { $link2 1/det "inverse of the determinant" } " of the input matrix." } +{ $notelist + $keep-shape-note + $2d-only-note + { $matrix-scalar-note determinant >cofactors 1/det } +} +{ $errors { $link non-square-determinant } " if the input matrix is not a " { $link square-matrix } "." } ; + + +HELP: covariance-matrix-ddof +{ $values { "matrix" matrix } { "ddof" object } { "cov" matrix } } +; +HELP: covariance-matrix +{ $values { "matrix" matrix } { "cov" matrix } } +; +HELP: sample-covariance-matrix +{ $values { "matrix" matrix } { "cov" matrix } } +; +HELP: population-covariance-matrix +{ $values { "matrix" matrix } { "cov" matrix } } +; diff --git a/extra/math/matrices/extras/extras-tests.factor b/extra/math/matrices/extras/extras-tests.factor new file mode 100644 index 0000000000..86c65a1b40 --- /dev/null +++ b/extra/math/matrices/extras/extras-tests.factor @@ -0,0 +1,362 @@ +! Copyright (C) 2005, 2010, 2018 Slava Pestov, Joe Groff, and Cat Stevens. +USING: arrays combinators.short-circuit grouping kernel math +math.matrices math.matrices.extras math.matrices.extras.private +math.statistics math.vectors sequences sequences.deep sets +tools.test ; +IN: math.matrices.extras + + + +{ { + { 4181 6765 } + { 6765 10946 } +} } [ + { { 0 1 } { 1 1 } } 20 m^n +] unit-test + +[ { { 0 1 } { 1 1 } } -20 m^n ] [ negative-power-matrix? ] must-fail-with +[ { { 0 1 } { 1 1 } } -8 m^n ] [ negative-power-matrix? ] must-fail-with + +{ { 1 -2 3 -4 } } [ { 1 2 3 4 } t alternating-sign ] unit-test +{ { -1 2 -3 4 } } [ { 1 2 3 4 } f alternating-sign ] unit-test + + +{ t } [ 50 dup transpose = ] unit-test +{ t } [ 50 dup anti-transpose = ] unit-test +{ f } [ 4 zero-matrix? ] unit-test + +{ t } [ 2 4 15 mabs { + [ flatten [ 15 <= ] all? ] + [ regular-matrix? ] + [ length 2 = ] + [ first length 4 = ] +} 1&& ] unit-test + +{ t } [ 4 4 -45 mabs { + [ flatten [ 45 <= ] all? ] + [ regular-matrix? ] + [ length 4 = ] + [ first length 4 = ] +} 1&& ] unit-test + +{ t } [ 2 2 1 mabs { + [ flatten [ 1 <= ] all? ] + [ regular-matrix? ] + [ length 2 = ] + [ first length 2 = ] +} 1&& ] unit-test + +{ t } [ 2 4 .89 mabs { + [ flatten [ .89 <= ] all? ] + [ regular-matrix? ] + [ length 2 = ] + [ first length 4 = ] +} 1&& ] unit-test + +{ t } [ 2 4 -45.89 mabs { + [ flatten [ 45.89 <= ] all? ] + [ regular-matrix? ] + [ length 2 = ] + [ first length 4 = ] +} 1&& ] unit-test + +{ t } [ 4 4 .89 mabs { + [ flatten [ .89 <= ] all? ] + [ regular-matrix? ] + [ length 4 = ] + [ first length 4 = ] +} 1&& ] unit-test + +{ { + { 1 1/2 1/3 1/4 } + { 1/2 1/3 1/4 1/5 } + { 1/3 1/4 1/5 1/6 } +} } [ 3 4 ] unit-test + +{ { + { 1 2 3 4 } + { 2 1 2 3 } + { 3 2 1 2 } + { 4 3 2 1 } +} } [ 4 ] unit-test + +{ { + { 1 2 3 4 } + { 2 3 4 0 } + { 3 4 0 0 } + { 4 0 0 0 } } +} [ 4 ] unit-test + +{ { + { 1 1 1 } + { 4 2 1 } + { 9 3 1 } + { 25 5 1 } } +} [ + { 1 2 3 5 } 3 +] unit-test + +{ { + { 0 5 0 10 } + { 6 7 12 14 } + { 0 15 0 20 } + { 18 21 24 28 } +} } [ { + { 1 2 } + { 3 4 } +} { + { 0 5 } + { 6 7 } +} kronecker-product ] unit-test + +{ { + { 1 1 1 1 } + { 1 -1 1 -1 } + { 1 1 -1 -1 } + { 1 -1 -1 1 } +} } [ { + { 1 1 } + { 1 -1 } +} dup kronecker-product ] unit-test + +{ { + { 1 1 1 1 1 1 1 1 } + { 1 -1 1 -1 1 -1 1 -1 } + { 1 1 -1 -1 1 1 -1 -1 } + { 1 -1 -1 1 1 -1 -1 1 } + { 1 1 1 1 -1 -1 -1 -1 } + { 1 -1 1 -1 -1 1 -1 1 } + { 1 1 -1 -1 -1 -1 1 1 } + { 1 -1 -1 1 -1 1 1 -1 } +} } [ { + { 1 1 } + { 1 -1 } +} dup dup kronecker-product kronecker-product ] unit-test + +{ { + { 1 1 1 1 1 1 1 1 } + { 1 -1 1 -1 1 -1 1 -1 } + { 1 1 -1 -1 1 1 -1 -1 } + { 1 -1 -1 1 1 -1 -1 1 } + { 1 1 1 1 -1 -1 -1 -1 } + { 1 -1 1 -1 -1 1 -1 1 } + { 1 1 -1 -1 -1 -1 1 1 } + { 1 -1 -1 1 -1 1 1 -1 } +} } [ { + { 1 1 } + { 1 -1 } +} dup dup kronecker-product swap kronecker-product ] unit-test + + +! kronecker-product is not generally commutative, make sure we have the right order +{ { + { 1 2 3 4 5 1 2 3 4 5 } + { 6 7 8 9 10 6 7 8 9 10 } + { 1 2 3 4 5 -1 -2 -3 -4 -5 } + { 6 7 8 9 10 -6 -7 -8 -9 -10 } +} } [ { + { 1 1 } + { 1 -1 } +} { + { 1 2 3 4 5 } + { 6 7 8 9 10 } +} kronecker-product ] unit-test + +{ { + { 1 1 2 2 3 3 4 4 5 5 } + { 1 -1 2 -2 3 -3 4 -4 5 -5 } + { 6 6 7 7 8 8 9 9 10 10 } + { 6 -6 7 -7 8 -8 9 -9 10 -10 } +} } [ { + { 1 1 } + { 1 -1 } +} { + { 1 2 3 4 5 } + { 6 7 8 9 10 } +} swap kronecker-product ] unit-test + +{ { + { 5 10 15 } + { 6 12 18 } + { 7 14 21 } +} } [ + { 5 6 7 } + { 1 2 3 } + outer-product +] unit-test + + +CONSTANT: test-points { + { 80 27 89 } { 80 27 88 } { 75 25 90 } + { 62 24 87 } { 62 22 87 } { 62 23 87 } + { 62 24 93 } { 62 24 93 } { 58 23 87 } + { 58 18 80 } { 58 18 89 } { 58 17 88 } + { 58 18 82 } { 58 19 93 } { 50 18 89 } + { 50 18 86 } { 50 19 72 } { 50 19 79 } + { 50 20 80 } { 56 20 82 } { 70 20 91 } +} + +{ { + { 84+2/35 22+23/35 24+4/7 } + { 22+23/35 9+104/105 6+87/140 } + { 24+4/7 6+87/140 28+5/7 } +} } [ test-points sample-covariance-matrix ] unit-test + +{ { + { 80+8/147 21+85/147 23+59/147 } + { 21+85/147 9+227/441 6+15/49 } + { 23+59/147 6+15/49 27+17/49 } +} } [ test-points covariance-matrix ] unit-test + +{ + { + { 80+8/147 21+85/147 23+59/147 } + { 21+85/147 9+227/441 6+15/49 } + { 23+59/147 6+15/49 27+17/49 } + } +} [ + test-points population-covariance-matrix +] unit-test + +{ t } [ { { 1 } } + { [ drop 1 ] [ (1determinant) ] [ 1 swap (ndeterminant) ] [ determinant ] } + call-eq? +] unit-test + +{ 0 } [ { { 0 } } determinant ] unit-test + +{ t } [ { + { 4 6 } ! order is significant + { 3 8 } +} { [ drop 14 ] [ (2determinant) ] [ 2 swap (ndeterminant) ] [ determinant ] } + call-eq? +] unit-test + +{ t } [ { + { 3 8 } + { 4 6 } +} { [ drop -14 ] [ (2determinant) ] [ 2 swap (ndeterminant) ] [ determinant ] } + call-eq? +] unit-test + +{ t } [ { + { 2 5 } + { 1 -3 } +} { [ drop -11 ] [ (2determinant) ] [ 2 swap (ndeterminant) ] [ determinant ] } + call-eq? +] unit-test + +{ t } [ { + { 1 -3 } + { 2 5 } +} { [ drop 11 ] [ (2determinant) ] [ 2 swap (ndeterminant) ] [ determinant ] } + call-eq? +] unit-test + +{ t } [ { + { 3 0 -1 } + { 2 -5 4 } + { -3 1 3 } +} { [ drop -44 ] [ (3determinant) ] [ 3 swap (ndeterminant) ] [ determinant ] } + call-eq? +] unit-test + +{ t } [ { + { 3 0 -1 } + { -3 1 3 } + { 2 -5 4 } +} { [ drop 44 ] [ (3determinant) ] [ 3 swap (ndeterminant) ] [ determinant ] } + call-eq? +] unit-test + +{ t } [ { + { 2 -3 1 } + { 4 2 -1 } + { -5 3 -2 } +} { [ drop -19 ] [ (3determinant) ] [ 3 swap (ndeterminant) ] [ determinant ] } + call-eq? +] unit-test + +{ t } [ { + { 2 -3 1 } + { -5 3 -2 } + { 4 2 -1 } +} { [ drop 19 ] [ (3determinant) ] [ 3 swap (ndeterminant) ] [ determinant ] } + call-eq? +] unit-test + +{ t } [ { + { 4 2 -1 } + { 2 -3 1 } + { -5 3 -2 } +} { [ drop 19 ] [ (3determinant) ] [ 3 swap (ndeterminant) ] [ determinant ] } + call-eq? +] unit-test + +{ t } [ { + { 5 1 -2 } + { -1 0 4 } + { 2 -3 3 } +} { [ drop 65 ] [ (3determinant) ] [ 3 swap (ndeterminant) ] [ determinant ] } + call-eq? +] unit-test + +{ t } [ { + { 6 1 1 } + { 4 -2 5 } + { 2 8 7 } +} { [ drop -306 ] [ (3determinant) ] [ 3 swap (ndeterminant) ] [ determinant ] } + call-eq? +] unit-test + +{ t } [ { + { -5 4 -3 2 } + { -2 1 0 -1 } + { -2 -3 -4 -5 } + { 0 2 0 4 } +} { [ drop -24 ] [ 4 swap (ndeterminant) ] [ determinant ] } + call-eq? +] unit-test + +{ t } [ { + { 2 4 2 2 } + { 5 1 -6 10 } + { 4 3 -1 7 } + { 9 8 7 3 } +} { [ drop 272 ] [ 4 swap (ndeterminant) ] [ determinant ] } + call-eq? +] unit-test + +{ { + { 2 2 2 } + { -2 3 3 } + { 0 -10 0 } +} } [ { + { 3 0 2 } + { 2 0 -2 } + { 0 1 1 } +} >minors ] unit-test + +! i think this unit test is wrong +! { { +! { 1 -6 -13 } +! { 0 0 0 } +! { 1 -6 -13 } +! } } [ { +! { 1 2 1 } +! { 6 -1 0 } +! { 1 -2 -1 } +! } >minors ] unit-test + +{ { + { 1 6 -13 } + { 0 0 0 } + { 1 6 -13 } +} } [ { + { 1 -6 -13 } + { 0 0 0 } + { 1 -6 -13 } +} >cofactors ] unit-test diff --git a/extra/math/matrices/extras/extras.factor b/extra/math/matrices/extras/extras.factor new file mode 100644 index 0000000000..cdbef2416c --- /dev/null +++ b/extra/math/matrices/extras/extras.factor @@ -0,0 +1,338 @@ +! Copyright (C) 2005, 2010, 2018 Slava Pestov, Joe Groff, and Cat Stevens. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays combinators formatting fry kernel locals +math math.bits math.functions math.matrices +math.matrices.private math.order math.statistics math.text.english +math.vectors random sequences sequences.deep summary ; +IN: math.matrices.extras + +! this is a questionable implementation +SINGLETONS: +full-rank+ +half-rank+ +zero-rank+ +deficient-rank+ +uncalculated-rank+ ; +UNION: rank-kind +full-rank+ +half-rank+ +zero-rank+ +deficient-rank+ +uncalculated-rank+ ; + +ERROR: negative-power-matrix + { m matrix } { n integer } ; +ERROR: non-square-determinant + { m integer } { n integer } ; +ERROR: undefined-inverse + { m integer } { n integer } { r rank-kind initial: +uncalculated-rank+ } ; + +M: negative-power-matrix summary + n>> dup ordinal-suffix "%s%s power of a matrix is undefined" sprintf ; +M: non-square-determinant summary + [ m>> ] [ n>> ] bi "non-square %s x %s matrix has no determinant" sprintf ; +M: undefined-inverse summary + [ m>> ] [ n>> ] [ r>> name>> ] tri "%s x %s matrix of rank %s has no inverse" sprintf ; + + + +: ( m n max -- matrix ) + '[ _ _ 1 + random-integers ] replicate + finish-randomizing-matrix ; inline + +: ( m n max -- matrix ) + '[ _ random-units [ _ * ] map ] replicate + finish-randomizing-matrix ; inline + + + +: gram-schmidt ( matrix -- orthogonal ) + [ V{ } clone [ over (gram-schmidt) suffix! ] reduce ] keep like ; + +: gram-schmidt-normalize ( matrix -- orthonormal ) + gram-schmidt [ normalize ] map ; inline + +: kronecker-product ( m1 m2 -- m ) + '[ [ _ n*m ] map ] map stitch stitch ; + +: outer-product ( u v -- matrix ) + '[ _ n*v ] map ; + +! Special matrix constructors follow +: ( n -- matrix ) + [ dup ] keep '[ + abs 1 + dup _ > [ drop 0 ] when ] cartesian-map ; + +: ( m n -- matrix ) + [ ] bi@ [ + 1 + recip ] cartesian-map ; + +: ( n -- matrix ) + dup [ - abs 1 + ] cartesian-map ; + +: ( r -- matrix ) + 2 * 1 + dup '[ _ 1 ] replicate ; + +: ( u n -- matrix ) + [ v^n ] with map reverse flip ; + +! Transformation matrices +:: ( axis theta -- matrix ) + theta cos :> c + theta sin :> s + axis first3 :> ( x y z ) + x sq 1.0 x sq - c * + x y * 1.0 c - * z s * - x z * 1.0 c - * y s * + 3array + x y * 1.0 c - * z s * + y sq 1.0 y sq - c * + y z * 1.0 c - * x s * - 3array + x z * 1.0 c - * y s * - y z * 1.0 c - * x s * + z sq 1.0 z sq - c * + 3array + 3array ; + +:: ( axis theta -- matrix ) + theta cos :> c + theta sin :> s + axis first3 :> ( x y z ) + x sq 1.0 x sq - c * + x y * 1.0 c - * z s * - x z * 1.0 c - * y s * + 0 4array + x y * 1.0 c - * z s * + y sq 1.0 y sq - c * + y z * 1.0 c - * x s * - 0 4array + x z * 1.0 c - * y s * - y z * 1.0 c - * x s * + z sq 1.0 z sq - c * + 0 4array + { 0.0 0.0 0.0 1.0 } 4array ; + +:: ( offset -- matrix ) + offset first3 :> ( x y z ) + { + { 1.0 0.0 0.0 x } + { 0.0 1.0 0.0 y } + { 0.0 0.0 1.0 z } + { 0.0 0.0 0.0 1.0 } + } ; + +scale-factors ( object -- x y z ) +M: number >scale-factors + dup dup ; +M: sequence >scale-factors + first3 ; +PRIVATE> + +:: ( factors -- matrix ) + factors >scale-factors :> ( x y z ) + { + { x 0.0 0.0 } + { 0.0 y 0.0 } + { 0.0 0.0 z } + } ; + +:: ( factors -- matrix ) + factors >scale-factors :> ( x y z ) + { + { x 0.0 0.0 0.0 } + { 0.0 y 0.0 0.0 } + { 0.0 0.0 z 0.0 } + { 0.0 0.0 0.0 1.0 } + } ; + +: ( factors -- matrix ) + [ recip ] map ; + +:: ( xy-dim near far -- matrix ) + xy-dim first2 :> ( x y ) + near x /f :> xf + near y /f :> yf + near far + near far - /f :> zf + 2 near far * * near far - /f :> wf + + { + { xf 0.0 0.0 0.0 } + { 0.0 yf 0.0 0.0 } + { 0.0 0.0 zf wf } + { 0.0 0.0 -1.0 0.0 } + } ; + +:: ( theta -- matrix ) + theta tan :> zf + { + { 1.0 0.0 0.0 0.0 } + { 0.0 1.0 0.0 0.0 } + { 0.0 zf 1.0 0.0 } + { 0.0 0.0 0.0 1.0 } + } ; + +! a simpler verison of this, like matrix-map -except, but map-index, should be possible +: cartesian-matrix-map ( matrix quot: ( ... pair matrix -- ... matrix' ) -- matrix-seq ) + [ [ first length ] keep ] dip + '[ _ @ ] matrix-map ; inline + +: cartesian-column-map ( matrix quot: ( ... pair matrix -- ... matrix' ) -- matrix-seq ) + [ cols first2 ] prepose cartesian-matrix-map ; inline + +! ------------------------------------------------- +! numerical analysis of matrices follows + + +GENERIC: rank ( matrix -- rank ) +M: zero-matrix rank + drop +zero-rank+ ; + +M: square-matrix rank + square-rank ; + +M: matrix rank + nonsquare-rank ; + +GENERIC: nullity ( matrix -- nullity ) + + +! implementation details of determinant and inverse + ( a b c ) + ! last 2 rows, transposed to make the next step easier + matrix-seq rest transpose + ! get the lower sub-matrices in reverse order of a b c columns + [ rest ] [ [ first ] [ third ] bi 2array ] [ 1 head* ] tri 3array + ! find determinants + [ (2determinant) ] map + ! negate odd elements of a b c and multiply by the new determinants + { a b c } t alternating-sign v* + ! sum the resulting sequence + sum ; + +DEFER: (ndeterminant) +: make-determinants ( n matrix -- seq ) + [ + cols-except [ length ] keep (ndeterminant) ! recurses here + ] map-index ; + +DEFER: (determinant) +! generalized to 4 and higher +: (ndeterminant) ( n matrix -- ndet ) + ! TODO? recurse for n < 3 + over 4 < [ (determinant) ] [ + [ nip first t alternating-sign ] [ rest make-determinants ] 2bi + v* sum + ] if ; + +! switches on dimensions only +: (determinant) ( n matrix -- determinant ) + over { + { 1 [ nip (1determinant) ] } + { 2 [ nip (2determinant) ] } + { 3 [ nip (3determinant) ] } + [ drop (ndeterminant) ] + } case ; +PRIVATE> + +GENERIC: determinant ( matrix -- determinant ) +M: zero-square-matrix determinant + drop 0 ; + +M: square-matrix determinant + [ length ] keep (determinant) ; + +! determinant is undefined for m =/= n, unlike inverse +M: matrix determinant + dimension first2 non-square-determinant ; + +: 1/det ( matrix -- 1/det ) + determinant recip ; inline + +! ----------------------------------------------------- +! inverse operations and implementations follow +ALIAS: multiplicative-inverse recip + +! per element, find the determinant of all other elements except the element's row / col +! https://www.mathsisfun.com/algebra/matrix-inverse-minors-cofactors-adjugate.html +: >minors ( matrix -- matrix' ) + matrix-except-all [ [ determinant ] map ] map ; + +! alternately invert values of the matrix (see alternating-sign) +: >cofactors ( matrix -- matrix' ) + [ even? alternating-sign ] map-index ; + +! multiply a matrix by the inverse of its determinant +: m*1/det ( matrix -- matrix' ) + [ 1/det ] keep n*m ; inline + +! inverse implementation +minors >cofactors transpose ] + ! adjugate * 1/det + bi n*m ; + +! TODO +: (left-inverse) ( matrix -- left-invert ) ; +: (right-inverse) ( matrix -- right-invert ) ; + +! TODO update this when rank works properly +! only defined for rank(A) = rows(A) OR rank(A) = cols(M) +! https://en.wikipedia.org/wiki/Invertible_matrix +: (specialized-inverse) ( rect-matrix -- inverted ) + dup [ rank ] [ dimension ] bi [ = ] with map { + { { t f } [ (left-inverse) ] } + { { f t } [ (right-inverse) ] } + [ no-case ] + } case ; +PRIVATE> + +M: zero-square-matrix recip + ; inline + +M: square-matrix recip + (square-inverse) ; inline + +M: zero-matrix recip + transpose ; inline ! TODO: error based on rankiness + +M: matrix recip + (specialized-inverse) ; inline + +! TODO: use the faster algorithm: [ determinant zero? ] +: invertible-matrix? ( matrix -- ? ) + [ dimension first2 max ] keep + dup recip m. = ; + +: linearly-independent-matrix? ( matrix -- ? ) ; + + + [ [ dupd m. ] when [ dup m. ] dip ] reduce nip ; +PRIVATE> + +! A^-1 is the inverse but other negative powers are nonsense +: m^n ( m n -- n ) { + { [ dup -1 = ] [ drop recip ] } + { [ dup 0 >= ] [ (m^n) ] } + [ negative-power-matrix ] + } cond ; + +: n^m ( n m -- n ) swap m^n ; inline + +: covariance-matrix-ddof ( matrix ddof -- cov ) + '[ _ cov-ddof ] cartesian-column-map ; inline + +: covariance-matrix ( matrix -- cov ) + 0 covariance-matrix-ddof ; inline + +: sample-covariance-matrix ( matrix -- cov ) + 1 covariance-matrix-ddof ; inline + +: population-covariance-matrix ( matrix -- cov ) 0 covariance-matrix-ddof ; inline diff --git a/extra/math/matrices/extras/summary.txt b/extra/math/matrices/extras/summary.txt new file mode 100644 index 0000000000..87a52d7e3f --- /dev/null +++ b/extra/math/matrices/extras/summary.txt @@ -0,0 +1 @@ +Matrix arithmetic - extra and miscellaneous words \ No newline at end of file diff --git a/extra/rosetta-code/bitmap/bitmap.factor b/extra/rosetta-code/bitmap/bitmap.factor index e45fbb9a74..54b1456b89 100644 --- a/extra/rosetta-code/bitmap/bitmap.factor +++ b/extra/rosetta-code/bitmap/bitmap.factor @@ -36,7 +36,7 @@ IN: rosetta-code.bitmap ! The storage functions : ( width height -- image ) - zero-matrix [ drop { 0 0 0 } ] mmap ; + [ drop { 0 0 0 } ] mmap ; : fill-image ( {R,G,B} image -- image ) swap '[ drop _ ] mmap! ; : set-pixel ( {R,G,B} {i,j} image -- ) set-Mi,j ; inline diff --git a/extra/rosetta-code/conjugate-transpose/conjugate-transpose.factor b/extra/rosetta-code/conjugate-transpose/conjugate-transpose.factor index b44b7fdae1..b84a88e2f8 100644 --- a/extra/rosetta-code/conjugate-transpose/conjugate-transpose.factor +++ b/extra/rosetta-code/conjugate-transpose/conjugate-transpose.factor @@ -38,4 +38,4 @@ IN: rosetta-code.conjugate-transpose dup conj-t [ m. ] [ swap m. ] 2bi = ; : unitary-matrix? ( matrix -- ? ) - [ dup conj-t m. ] [ length identity-matrix ] bi = ; + [ dup conj-t m. ] [ length ] bi = ; From 8e8c62a2d947383a51f23d18b862210489858393 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Sun, 8 Dec 2019 09:06:55 -0800 Subject: [PATCH 02/22] tools.test: adding a warning for possible long unit tests. This will help us learn which tests are the slowest on Travis. --- basis/tools/test/test.factor | 33 ++++++++++++++++++++++++--------- 1 file changed, 24 insertions(+), 9 deletions(-) diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index 1b10c21bf0..5449c2ac9d 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -3,11 +3,12 @@ USING: accessors arrays assocs combinators command-line compiler.units continuations debugger effects fry generalizations io io.files.temp io.files.unique kernel lexer -locals macros math.functions math.vectors namespaces parser +locals macros math math.functions math.vectors namespaces parser prettyprint quotations sequences sequences.generalizations source-files source-files.errors source-files.errors.debugger -splitting stack-checker summary system tools.errors unicode -vocabs vocabs.files vocabs.metadata vocabs.parser words ; +splitting stack-checker summary system tools.errors tools.time +unicode vocabs vocabs.files vocabs.metadata vocabs.parser words +; FROM: vocabs.hierarchy => load ; IN: tools.test @@ -46,6 +47,9 @@ t restartable-tests? set-global swap >>error error-continuation get >>continuation ; +SYMBOL: long-unit-tests-threshold +long-unit-tests-threshold [ 10,000,000,000 ] initialize + SYMBOL: long-unit-tests-enabled? long-unit-tests-enabled? [ t ] initialize @@ -167,15 +171,26 @@ SYMBOL: forget-tests? forget-tests? get [ [ [ forget-source ] each ] with-compilation-unit ] [ drop ] if ; +: possible-long-unit-tests ( vocab nanos -- ) + long-unit-tests-threshold get [ + dupd > long-unit-tests-enabled? get not and [ + swap + "Warning: possible long unit test for " write + vocab-name write " - " write + 1,000,000,000 /f pprint " seconds" print + ] [ 2drop ] if + ] [ 2drop ] if* ; + : test-vocab ( vocab -- ) - lookup-vocab dup [ + lookup-vocab [ dup source-loaded?>> [ - vocab-tests - [ [ run-test-file ] each ] - [ forget-tests ] - bi + dup vocab-tests [ + [ [ run-test-file ] each ] + [ forget-tests ] + bi + ] benchmark possible-long-unit-tests ] [ drop ] if - ] [ drop ] if ; + ] when* ; : test-vocabs ( vocabs -- ) [ test-vocab ] each ; From a8fd0d05e751b29b5dd926466c3dc3aba7cf33ae Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Dec 2019 11:48:59 -0800 Subject: [PATCH 03/22] .travis.yml: Don't run long-running tests. --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 791416095e..946c1512b1 100644 --- a/.travis.yml +++ b/.travis.yml @@ -69,7 +69,7 @@ script: - export CI_BRANCH="${TRAVIS_PULL_REQUEST_BRANCH:-$TRAVIS_BRANCH}" - echo "CI_BRANCH=${CI_BRANCH}" - DEBUG=1 ./build.sh net-bootstrap < /dev/null - - "./factor -e='USING: memory vocabs.hierarchy ; \"zealot\" load save'" + - "./factor -e='USING: memory vocabs.hierarchy tools.test namespaces ; \"zealot\" load f long-unit-tests-enabled? set-global save'" - './factor -run=zealot.cli-changed-vocabs' - './factor -run=tools.test `./factor -run=zealot.cli-changed-vocabs | paste -s -d " " -`' - './factor -run=zealot.help-lint `./factor -run=zealot.cli-changed-vocabs | paste -s -d " " -`' From 5beead130b68ef4a04609785865177baacf6f207 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Dec 2019 11:58:06 -0800 Subject: [PATCH 04/22] .travis: Trying to fix macos. /usr/local/Homebrew/Library/Homebrew/brew.rb:10:in `
': Homebrew must be run under Ruby 2.6! You're running 2.3.3. (RuntimeError) The command "if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions snappy > /dev/null || brew install snappy; fi" failed and exited with 1 during . Your build has been stopped. --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index 946c1512b1..d21c257945 100644 --- a/.travis.yml +++ b/.travis.yml @@ -36,6 +36,7 @@ addons: before_install: - uname -s - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then ./build.sh deps-macosx ; else ./build.sh deps-apt-get ; fi + - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions portable-ruby || brew install homebrew/portable-ruby/portable-ruby ; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions snappy > /dev/null || brew install snappy; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions cmake > /dev/null || brew install cmake; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions libmagic > /dev/null || brew install libmagic; fi From 34df021a6f65742453dfe9798465f470a0974ce8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Dec 2019 12:07:38 -0800 Subject: [PATCH 05/22] .travis: Delete old rubygems after we install it. --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index d21c257945..a856849069 100644 --- a/.travis.yml +++ b/.travis.yml @@ -37,6 +37,7 @@ before_install: - uname -s - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then ./build.sh deps-macosx ; else ./build.sh deps-apt-get ; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions portable-ruby || brew install homebrew/portable-ruby/portable-ruby ; fi + - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then sudo rm /Library/Ruby/Site/2.3.3/rubygems.rb ; fi # https://github.com/Homebrew/brew/issues/3404 - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions snappy > /dev/null || brew install snappy; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions cmake > /dev/null || brew install cmake; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions libmagic > /dev/null || brew install libmagic; fi From 56f1da8eaeeffcfd5548640eda287fd5b1be147c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Dec 2019 12:12:37 -0800 Subject: [PATCH 06/22] .travis: fixing ruby? --- .travis.yml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index a856849069..79bb31fc2c 100644 --- a/.travis.yml +++ b/.travis.yml @@ -33,11 +33,15 @@ addons: - libsnappy-dev - libgtk2.0-dev - gtk2-engines-pixbuf + - rvm before_install: - uname -s - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then ./build.sh deps-macosx ; else ./build.sh deps-apt-get ; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions portable-ruby || brew install homebrew/portable-ruby/portable-ruby ; fi - - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then sudo rm /Library/Ruby/Site/2.3.3/rubygems.rb ; fi # https://github.com/Homebrew/brew/issues/3404 + - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then echo "ruby1" && ruby -v && which ruby; fi # https://github.com/Homebrew/brew/issues/3404 + - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then sudo rm -rf /Library/Ruby/Site/2.3.3 ; fi # https://github.com/Homebrew/brew/issues/3404 + - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then echo "ruby2" && ruby -v && which ruby; fi # https://github.com/Homebrew/brew/issues/3404 + - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then echo "ruby3" && rvm use 2.6 && ruby -v && which ruby; fi # https://github.com/Homebrew/brew/issues/3404 - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions snappy > /dev/null || brew install snappy; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions cmake > /dev/null || brew install cmake; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions libmagic > /dev/null || brew install libmagic; fi From d2b2b5a1a64bca923f917ce2ff94a8546ff0f293 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Dec 2019 12:20:30 -0800 Subject: [PATCH 07/22] .travis: more testing --- .travis.yml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index 79bb31fc2c..a3907bfe7e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -33,15 +33,14 @@ addons: - libsnappy-dev - libgtk2.0-dev - gtk2-engines-pixbuf - - rvm before_install: - uname -s - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then ./build.sh deps-macosx ; else ./build.sh deps-apt-get ; fi - - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions portable-ruby || brew install homebrew/portable-ruby/portable-ruby ; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then echo "ruby1" && ruby -v && which ruby; fi # https://github.com/Homebrew/brew/issues/3404 - - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then sudo rm -rf /Library/Ruby/Site/2.3.3 ; fi # https://github.com/Homebrew/brew/issues/3404 + - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew install homebrew/portable-ruby/portable-ruby rvm ; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then echo "ruby2" && ruby -v && which ruby; fi # https://github.com/Homebrew/brew/issues/3404 - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then echo "ruby3" && rvm use 2.6 && ruby -v && which ruby; fi # https://github.com/Homebrew/brew/issues/3404 + - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then sudo rm -rf /Library/Ruby/Site/2.3.3 ; fi # https://github.com/Homebrew/brew/issues/3404 - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions snappy > /dev/null || brew install snappy; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions cmake > /dev/null || brew install cmake; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions libmagic > /dev/null || brew install libmagic; fi From 336c2aefad21a06adc6beff33daeb29c45d94be1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Dec 2019 09:35:13 -0800 Subject: [PATCH 08/22] travis: upgrade rvm first --- .travis.yml | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/.travis.yml b/.travis.yml index a3907bfe7e..671885c739 100644 --- a/.travis.yml +++ b/.travis.yml @@ -35,12 +35,12 @@ addons: - gtk2-engines-pixbuf before_install: - uname -s + - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rm -rf ~/.gnupg/; fi # https://github.com/rvm/rvm/issues/3110 + - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then curl -sSL https://rvm.io/mpapis.asc | gpg --import - ; fi + - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then curl -sSL https://rvm.io/pkuczynski.asc | gpg --import - ; fi + - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then curl -sSL https://get.rvm.io | bash -s stable; fi # https://github.com/travis-ci/travis-ci/issues/6307 + - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then ./build.sh deps-macosx ; else ./build.sh deps-apt-get ; fi - - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then echo "ruby1" && ruby -v && which ruby; fi # https://github.com/Homebrew/brew/issues/3404 - - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew install homebrew/portable-ruby/portable-ruby rvm ; fi - - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then echo "ruby2" && ruby -v && which ruby; fi # https://github.com/Homebrew/brew/issues/3404 - - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then echo "ruby3" && rvm use 2.6 && ruby -v && which ruby; fi # https://github.com/Homebrew/brew/issues/3404 - - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then sudo rm -rf /Library/Ruby/Site/2.3.3 ; fi # https://github.com/Homebrew/brew/issues/3404 - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions snappy > /dev/null || brew install snappy; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions cmake > /dev/null || brew install cmake; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions libmagic > /dev/null || brew install libmagic; fi @@ -52,10 +52,6 @@ before_install: - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew services start redis; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew services start postgresql; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew services start memcached; fi - - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rm -rf ~/.gnupg/; fi # https://github.com/rvm/rvm/issues/3110 - - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then curl -sSL https://rvm.io/mpapis.asc | gpg --import - ; fi - - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then curl -sSL https://rvm.io/pkuczynski.asc | gpg --import - ; fi - - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then curl -sSL https://get.rvm.io | bash -s stable; fi # https://github.com/travis-ci/travis-ci/issues/6307 - if [[ "$TRAVIS_OS_NAME" != "windows" ]]; then wget https://github.com/vmt/udis86/archive/v1.7.2.tar.gz && tar xzvf v1.7.2.tar.gz && ( cd udis86-1.7.2/ && ./autogen.sh && ./configure --enable-shared=yes && make && sudo make install ) && From fff022da749c2e5da77a674849b24aedb399ce63 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Dec 2019 09:43:27 -0800 Subject: [PATCH 09/22] .travis: use newer ruby and turn off brew updating --- .travis.yml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.travis.yml b/.travis.yml index 671885c739..e0febe5f68 100644 --- a/.travis.yml +++ b/.travis.yml @@ -35,10 +35,12 @@ addons: - gtk2-engines-pixbuf before_install: - uname -s + - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then export HOMEBREW_NO_AUTO_UPDATE=1 ; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rm -rf ~/.gnupg/; fi # https://github.com/rvm/rvm/issues/3110 - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then curl -sSL https://rvm.io/mpapis.asc | gpg --import - ; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then curl -sSL https://rvm.io/pkuczynski.asc | gpg --import - ; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then curl -sSL https://get.rvm.io | bash -s stable; fi # https://github.com/travis-ci/travis-ci/issues/6307 + - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rvm use 2.6 ; fi # for homebrew - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then ./build.sh deps-macosx ; else ./build.sh deps-apt-get ; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions snappy > /dev/null || brew install snappy; fi From 310f5374c9169d23e8092c26141d99d2ed398d46 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Dec 2019 09:50:59 -0800 Subject: [PATCH 10/22] .travis: rvm reload --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index e0febe5f68..96714ac6fc 100644 --- a/.travis.yml +++ b/.travis.yml @@ -40,6 +40,7 @@ before_install: - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then curl -sSL https://rvm.io/mpapis.asc | gpg --import - ; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then curl -sSL https://rvm.io/pkuczynski.asc | gpg --import - ; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then curl -sSL https://get.rvm.io | bash -s stable; fi # https://github.com/travis-ci/travis-ci/issues/6307 + - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rvm reload ; fi # for homebrew - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rvm use 2.6 ; fi # for homebrew - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then ./build.sh deps-macosx ; else ./build.sh deps-apt-get ; fi From f95ed9c23059ea357a15f1b885682538d6f1cff8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Dec 2019 09:56:15 -0800 Subject: [PATCH 11/22] .travis: install correct version of ruby --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index 96714ac6fc..ed7e417a39 100644 --- a/.travis.yml +++ b/.travis.yml @@ -41,6 +41,7 @@ before_install: - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then curl -sSL https://rvm.io/pkuczynski.asc | gpg --import - ; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then curl -sSL https://get.rvm.io | bash -s stable; fi # https://github.com/travis-ci/travis-ci/issues/6307 - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rvm reload ; fi # for homebrew + - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rvm install ruby-2.6.3 ; fi # for homebrew - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rvm use 2.6 ; fi # for homebrew - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then ./build.sh deps-macosx ; else ./build.sh deps-apt-get ; fi From 3db98706691d38f0d1c5d099ed990ae0c6eaa6ee Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Dec 2019 10:12:07 -0800 Subject: [PATCH 12/22] .travis: Don't upgrade ruby, it takes too long. --- .travis.yml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/.travis.yml b/.travis.yml index ed7e417a39..c0308ab11a 100644 --- a/.travis.yml +++ b/.travis.yml @@ -35,14 +35,14 @@ addons: - gtk2-engines-pixbuf before_install: - uname -s - - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then export HOMEBREW_NO_AUTO_UPDATE=1 ; fi + - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then export HOMEBREW_NO_AUTO_UPDATE=1 ; fi # Don't let homebrew upgrade itself - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rm -rf ~/.gnupg/; fi # https://github.com/rvm/rvm/issues/3110 - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then curl -sSL https://rvm.io/mpapis.asc | gpg --import - ; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then curl -sSL https://rvm.io/pkuczynski.asc | gpg --import - ; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then curl -sSL https://get.rvm.io | bash -s stable; fi # https://github.com/travis-ci/travis-ci/issues/6307 - - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rvm reload ; fi # for homebrew - - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rvm install ruby-2.6.3 ; fi # for homebrew - - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rvm use 2.6 ; fi # for homebrew + #- if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rvm reload ; fi # for homebrew to have 2.6.3, which takes too long. instead we just use HOMEBREW_NO_AUTO_UPDATE=1 + #- if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rvm install ruby-2.6.3 ; fi # for homebrew + #- if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rvm use 2.6 ; fi # for homebrew - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then ./build.sh deps-macosx ; else ./build.sh deps-apt-get ; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions snappy > /dev/null || brew install snappy; fi From c33a4060661cf4d8a6c94322e445cec09c34503f Mon Sep 17 00:00:00 2001 From: nomennescio Date: Tue, 5 Nov 2019 13:57:09 +0100 Subject: [PATCH 13/22] Support for MinGW compiler. Need to instal MinGW compiler and runtime. --- build.sh | 24 +++++++++++++++++++++--- vm/Config.windows | 6 +++--- vm/Config.windows.x86.32 | 2 +- vm/master.hpp | 4 +++- vm/os-windows.cpp | 2 ++ 5 files changed, 30 insertions(+), 8 deletions(-) diff --git a/build.sh b/build.sh index fba998ee4e..4e3e7bfe39 100755 --- a/build.sh +++ b/build.sh @@ -92,7 +92,7 @@ check_ret() { set_downloader() { test_program_installed wget if [[ $? -ne 0 ]] ; then - DOWNLOADER=wget + DOWNLOADER="wget -nd" DOWNLOADER_NAME=wget return fi @@ -154,6 +154,23 @@ clang_version_ok() { } set_cc() { + + # on Cygwin we MUST use the MinGW "cross-compiler", therefore check these first + # furthermore, we prefer 64 bit over 32 bit versions if both are available + test_programs_installed x86_64-w64-mingw32-gcc x86_64-w64-mingw32-g++ + if [[ $? -ne 0 ]] ; then + [ -z "$CC" ] && CC=x86_64-w64-mingw32-gcc + [ -z "$CXX" ] && CXX=x86_64-w64-mingw32-g++ + return + fi + + test_programs_installed i686-w64-mingw32-gcc i686-w64-mingw32-g++ + if [[ $? -ne 0 ]] ; then + [ -z "$CC" ] && CC=i686-w64-mingw32-gcc + [ -z "$CXX" ] && CXX=i686-w64-mingw32-g++ + return + fi + test_programs_installed clang clang++ if [[ $? -ne 0 ]] && clang_version_ok ; then [ -z "$CC" ] && CC=clang @@ -161,6 +178,7 @@ set_cc() { return fi + # gcc and g++ will fail to correctly build Factor on Cygwin test_programs_installed gcc g++ if [[ $? -ne 0 ]] ; then [ -z "$CC" ] && CC=gcc @@ -187,8 +205,8 @@ check_installed_programs() { ensure_program_installed uname ensure_program_installed git ensure_program_installed wget curl - ensure_program_installed clang gcc - ensure_program_installed clang++ g++ cl + ensure_program_installed clang x86_64-w64-mingw32-gcc i686-w64-mingw32-gcc gcc + ensure_program_installed clang++ x86_64-w64-mingw32-g++ i686-w64-mingw32-g++ g++ cl ensure_program_installed make gmake ensure_program_installed md5sum md5 ensure_program_installed cut diff --git a/vm/Config.windows b/vm/Config.windows index 0b5f843420..3dd37e99fb 100644 --- a/vm/Config.windows +++ b/vm/Config.windows @@ -1,4 +1,4 @@ -SITE_CFLAGS += -mno-cygwin -mwindows +SITE_CFLAGS += -mwindows CFLAGS_CONSOLE += -mconsole SHARED_FLAG = -shared SHARED_DLL_EXTENSION=.dll @@ -7,7 +7,7 @@ LIBS = -lm PLAF_DLL_OBJS += vm/os-windows.o vm/mvm-windows.o PLAF_EXE_OBJS += vm/resources.o vm/main-windows.o -PLAF_MASTER_HEADERS += vm/os-windows.hpp vm/mvm-windows.hpp +PLAF_MASTER_HEADERS += vm/os-windows.hpp EXE_SUFFIX= EXE_EXTENSION=.exe @@ -15,5 +15,5 @@ DLL_SUFFIX= DLL_EXTENSION=.dll CONSOLE_EXTENSION=.com -LINKER = $(CPP) -shared -mno-cygwin -o +LINKER = $(CPP) -shared -o LINK_WITH_ENGINE = -l$(DLL_PREFIX)factor$(DLL_SUFFIX) diff --git a/vm/Config.windows.x86.32 b/vm/Config.windows.x86.32 index 82cad23ef6..56b7f7fa48 100644 --- a/vm/Config.windows.x86.32 +++ b/vm/Config.windows.x86.32 @@ -1,6 +1,6 @@ PLAF_DLL_OBJS += vm/os-windows-x86.32.o PLAF_MASTER_HEADERS += vm/os-windows.32.hpp DLL_PATH=http://factorcode.org/dlls -WINDRES=windres +WINDRES=windres -F pe-i386 include vm/Config.windows include vm/Config.x86.32 diff --git a/vm/master.hpp b/vm/master.hpp index 8aa0d9787c..bac9e5f7ed 100644 --- a/vm/master.hpp +++ b/vm/master.hpp @@ -43,6 +43,8 @@ #elif defined(__INTEL_COMPILER) #define FACTOR_COMPILER_VERSION \ "Intel C Compiler " FACTOR_STRINGIZE(__INTEL_COMPILER) +#elif defined(__MINGW32__) +#define FACTOR_COMPILER_VERSION "MinGW (GCC " __VERSION__ ")" #elif defined(__GNUC__) #define FACTOR_COMPILER_VERSION "GCC " __VERSION__ #elif defined(_MSC_FULL_VER) @@ -79,7 +81,7 @@ #error "Unsupported architecture" #endif -#if defined(_MSC_VER) +#if defined(_MSC_VER) || defined (__MINGW32__) #define WINDOWS #define WINNT #elif defined(WIN32) diff --git a/vm/os-windows.cpp b/vm/os-windows.cpp index d5ecad1d09..d6b74888c2 100644 --- a/vm/os-windows.cpp +++ b/vm/os-windows.cpp @@ -185,12 +185,14 @@ uint64_t nano_count() { void sleep_nanos(uint64_t nsec) { Sleep((DWORD)(nsec / 1000000)); } +#ifndef EXCEPTION_DISPOSITION typedef enum _EXCEPTION_DISPOSITION { ExceptionContinueExecution = 0, ExceptionContinueSearch = 1, ExceptionNestedException = 2, ExceptionCollidedUnwind = 3 } EXCEPTION_DISPOSITION; +#endif LONG factor_vm::exception_handler(PEXCEPTION_RECORD e, void* frame, PCONTEXT c, void* dispatch) { From 05665e8d1398d6b838fef0325c08503a68735eee Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Fri, 13 Dec 2019 14:35:51 -0800 Subject: [PATCH 14/22] kernel: adding while* that passes the predicate result to the body. --- core/kernel/kernel-docs.factor | 4 ++++ core/kernel/kernel.factor | 3 +++ 2 files changed, 7 insertions(+) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index ad0009e95f..d06c764758 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -885,6 +885,10 @@ HELP: while { $values { "pred" { $quotation ( ..a -- ..b ? ) } } { "body" { $quotation ( ..b -- ..a ) } } } { $description "Calls " { $snippet "body" } " until " { $snippet "pred" } " returns " { $link f } "." } ; +HELP: while* +{ $values { "pred" { $quotation ( ..a -- ..b ? ) } } { "body" { $quotation ( ..b ? -- ..a ) } } } +{ $description "Calls " { $snippet "body" } " until " { $snippet "pred" } " returns " { $link f } "." } ; + HELP: until { $values { "pred" { $quotation ( ..a -- ..b ? ) } } { "body" { $quotation ( ..b -- ..a ) } } } { $description "Calls " { $snippet "body" } " until " { $snippet "pred" } " returns " { $link t } "." } ; diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 7a7db30948..35bbfdfb38 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -284,6 +284,9 @@ UNION: boolean POSTPONE: t POSTPONE: f ; : while ( ..a pred: ( ..a -- ..b ? ) body: ( ..b -- ..a ) -- ..b ) swap do compose [ loop ] curry when ; inline +: while* ( ..a pred: ( ..a -- ..b ? ) body: ( ..b ? -- ..a ) -- ..b ) + [ [ dup ] compose ] dip while drop ; inline + : until ( ..a pred: ( ..a -- ..b ? ) body: ( ..b -- ..a ) -- ..b ) [ [ not ] compose ] dip while ; inline From 77b13fbdc206dd4cfa171a93398d4375d4b83e7e Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Fri, 13 Dec 2019 14:38:26 -0800 Subject: [PATCH 15/22] core/basis/extra: using while* in a few places. --- basis/io/encodings/string/string.factor | 2 +- basis/json/reader/reader.factor | 2 +- core/io/io.factor | 14 ++++++-------- extra/audio/wav/wav.factor | 4 ++-- extra/cuesheet/cuesheet.factor | 2 +- extra/html/entities/entities.factor | 2 +- extra/images/atlas/atlas.factor | 2 +- extra/tokyo/assoc-functor/assoc-functor.factor | 4 ++-- extra/trees/trees.factor | 4 ++-- 9 files changed, 17 insertions(+), 19 deletions(-) diff --git a/basis/io/encodings/string/string.factor b/basis/io/encodings/string/string.factor index e6f278e5b3..f58fb98903 100644 --- a/basis/io/encodings/string/string.factor +++ b/basis/io/encodings/string/string.factor @@ -13,7 +13,7 @@ IN: io.encodings.string ] [ byte-array encoding :> reader byte-array length encoding guess-decoded-length :> buf - [ reader stream-read1 dup ] [ buf push ] while drop + [ reader stream-read1 ] [ buf push ] while* buf "" like ] if ] if ; inline diff --git a/basis/json/reader/reader.factor b/basis/json/reader/reader.factor index 39e932c102..7d223c0623 100644 --- a/basis/json/reader/reader.factor +++ b/basis/json/reader/reader.factor @@ -126,7 +126,7 @@ DEFER: (read-json-string) } case ; : json-read-input ( stream -- objects ) - V{ } clone over '[ _ stream-read1 dup ] [ scan ] while drop nip ; + V{ } clone over '[ _ stream-read1 ] [ scan ] while* nip ; ! If there are no json objects, return an empty hashtable ! This happens for empty files. diff --git a/core/io/io.factor b/core/io/io.factor index d1e345a2a8..9d20471b29 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -103,9 +103,6 @@ SYMBOL: error-stream : bl ( -- ) output-stream get stream-bl ; -: each-morsel ( ..a handler: ( ..a data -- ..b ) reader: ( ..b -- ..a data ) -- ..a ) - [ dup ] compose swap while drop ; inline - fmt! f :> data! - [ { [ fmt data and not ] [ read-chunk ] } 0&& dup ] + [ { [ fmt data and not ] [ read-chunk ] } 0&& ] [ { { [ dup FMT-MAGIC wav-fmt-chunk check-chunk ] [ wav-fmt-chunk memory>struct fmt! ] } { [ dup DATA-MAGIC wav-data-chunk check-chunk ] [ wav-data-chunk memory>struct data! ] } [ drop ] - } cond ] while drop + } cond ] while* fmt data 2dup and [ invalid-audio-file ] unless ; : verify-wav ( chunk -- ) diff --git a/extra/cuesheet/cuesheet.factor b/extra/cuesheet/cuesheet.factor index 8f5b86a599..77eaa721dd 100644 --- a/extra/cuesheet/cuesheet.factor +++ b/extra/cuesheet/cuesheet.factor @@ -127,7 +127,7 @@ ERROR: unknown-syntax syntax ; PRIVATE> : read-cuesheet ( -- cuesheet ) - [ readln dup ] [ parse-line ] while drop ; + [ readln ] [ parse-line ] while* ; : file>cuesheet ( path -- cuesheet ) utf8 [ read-cuesheet ] with-file-reader ; diff --git a/extra/html/entities/entities.factor b/extra/html/entities/entities.factor index 1baab98029..9902326f0b 100644 --- a/extra/html/entities/entities.factor +++ b/extra/html/entities/entities.factor @@ -28,7 +28,7 @@ PRIVATE> : html-escape ( str -- newstr ) [ - [ dup next-escape dup ] [ escape, ] while 2drop , + [ dup next-escape ] [ escape, ] while* drop , ] { } make dup length 1 > [ concat ] [ first ] if ; image-placements 0 :> @y! - [ image-placements atlas-width @y (pack-stripe) dup ] [ @y + @y! ] while drop + [ image-placements atlas-width @y (pack-stripe) ] [ @y + @y! ] while* image-placements ; inline : atlas-image-format ( image-placements -- component-order component-type upside-down? ) diff --git a/extra/tokyo/assoc-functor/assoc-functor.factor b/extra/tokyo/assoc-functor/assoc-functor.factor index 1c4ff1b88a..d9b9392b08 100644 --- a/extra/tokyo/assoc-functor/assoc-functor.factor +++ b/extra/tokyo/assoc-functor/assoc-functor.factor @@ -37,10 +37,10 @@ M: TYPE assoc-size handle>> DBRNUM ; : DBKEYS ( db -- keys ) [ assoc-size ] [ handle>> ] bi dup DBITERINIT drop 0 int - [ 2dup DBITERNEXT dup ] [ + [ 2dup DBITERNEXT ] [ [ memory>object ] [ tcfree ] bi reach push - ] while 3drop ; + ] while* 2drop ; M: TYPE >alist [ DBKEYS dup ] keep '[ dup _ at 2array ] map! drop ; diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor index b9b00e2b47..b43da272dd 100644 --- a/extra/trees/trees.factor +++ b/extra/trees/trees.factor @@ -238,10 +238,10 @@ PRIVATE> [ root>> (nodepath-at) ] { } make ; : right-extremity ( node -- node' ) - [ dup right>> dup ] [ nip ] while drop ; + [ dup right>> ] [ nip ] while* ; : left-extremity ( node -- node' ) - [ dup left>> dup ] [ nip ] while drop ; + [ dup left>> ] [ nip ] while* ; : lower-node-in-child? ( key node -- ? ) [ nip left>> ] [ key>> = ] 2bi and ; From ec58d39bb2402e72b0aed3bf73e957db6738a8d2 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Fri, 13 Dec 2019 14:41:43 -0800 Subject: [PATCH 16/22] misc/vim: update vim syntax keywords. --- misc/vim/syntax/factor.vim | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/misc/vim/syntax/factor.vim b/misc/vim/syntax/factor.vim index 8854715036..a403897c09 100644 --- a/misc/vim/syntax/factor.vim +++ b/misc/vim/syntax/factor.vim @@ -53,17 +53,17 @@ syn match factorCallQuotation /\/ con syn match factorExecute /\/ contained contains=factorStackEffect syn keyword factorCallNextMethod call-next-method -syn keyword factorKeyword (clone) -roll -rot -rotd 2bi 2bi* 2bi@ 2curry 2dip 2drop 2dup 2keep 2keepd 2nip 2nipd 2over 2tri 2tri* 2tri@ 2with 3bi 3curry 3dip 3drop 3dup 3keep 3nip 3nipd 3tri 4dip 4drop 4dup 4keep 4nip 5drop 5nip = >boolean ? ?if and assert assert= assert? bi bi* bi-curry bi-curry* bi-curry@ bi@ boa boolean boolean? both? build call callstack callstack>array callstack? clear clone compose composed composed? curried curried? curry die dip do drop dup dupd either? eq? equal? execute get-callstack get-datastack get-retainstack hashcode hashcode* identity-hashcode identity-tuple identity-tuple? if if* keep keepd keepdd loop most new nip nipd not null object or over overd pick pickd prepose reach roll rot rotd same? spin swap swapd throw tri tri* tri-curry tri-curry* tri-curry@ tri@ tuck tuple tuple? unless unless* until when when* while with wrapper wrapper? xor -syn keyword factorKeyword 2cache >alist ?at ?of assoc assoc-all? assoc-any? assoc-clone-like assoc-combine assoc-diff assoc-diff! assoc-differ assoc-each assoc-empty? assoc-filter assoc-filter! assoc-filter-as assoc-find assoc-hashcode assoc-intersect assoc-like assoc-map assoc-map-as assoc-partition assoc-refine assoc-reject assoc-reject! assoc-reject-as assoc-size assoc-stack assoc-subset? assoc-union assoc-union! assoc-union-as assoc= assoc>map assoc? at at* at+ cache change-at clear-assoc collect-by delete-at delete-at* enumerated enumerated? extract-keys harvest-keys harvest-values inc-at key? keys map>alist map>assoc maybe-set-at new-assoc of push-at rename-at set-at sift-keys sift-values substitute unzip value-at value-at* value? values zip zip-as zip-index zip-index-as +syn keyword factorKeyword (clone) -roll -rot -rotd 2bi 2bi* 2bi@ 2curry 2dip 2drop 2dup 2keep 2keepd 2nip 2nipd 2over 2tri 2tri* 2tri@ 2with 3bi 3curry 3dip 3drop 3dup 3keep 3nip 3nipd 3tri 4dip 4drop 4dup 4keep 4nip 5drop 5nip = >boolean ? ?if and assert assert= assert? bi bi* bi-curry bi-curry* bi-curry@ bi@ boa boolean boolean? both? build call callstack callstack>array callstack? clear clone compose composed composed? curried curried? curry die dip do drop dup dupd either? eq? equal? execute get-callstack get-datastack get-retainstack hashcode hashcode* identity-hashcode identity-tuple identity-tuple? if if* keep keepd keepdd loop most new nip nipd not null object or over overd pick pickd prepose reach roll rot rotd same? spin swap swapd throw tri tri* tri-curry tri-curry* tri-curry@ tri@ tuck tuple tuple? unless unless* until when when* while while* with wrapper wrapper? xor +syn keyword factorKeyword 2cache >alist ?at ?delete-at ?of assoc assoc-all? assoc-any? assoc-clone-like assoc-combine assoc-diff assoc-diff! assoc-differ assoc-each assoc-empty? assoc-filter assoc-filter! assoc-filter-as assoc-find assoc-hashcode assoc-intersect assoc-like assoc-map assoc-map-as assoc-partition assoc-refine assoc-reject assoc-reject! assoc-reject-as assoc-size assoc-stack assoc-subset? assoc-union assoc-union! assoc-union-as assoc= assoc>map assoc? at at* at+ cache change-at clear-assoc collect-by delete-at delete-at* enumerated enumerated? extract-keys harvest-keys harvest-values inc-at key? keys map>alist map>assoc maybe-set-at new-assoc of push-at rename-at set-at sift-keys sift-values substitute unzip value-at value-at* value? values zip zip-as zip-index zip-index-as syn keyword factorKeyword 2cleave 2cleave>quot 3cleave 3cleave>quot 4cleave 4cleave>quot alist>quot call-effect case case-find case>quot cleave cleave>quot cond cond>quot deep-spread>quot execute-effect linear-case-quot no-case no-case? no-cond no-cond? recursive-hashcode shallow-spread>quot spread to-fixed-point wrong-values wrong-values? syn keyword factorKeyword (all-integers?) (each-integer) (find-integer) * + - / /f /i /mod 2/ 2^ < <= > >= >bignum >fixnum >float >fraction >integer >rect ?1+ abs align all-integers? bignum bignum? bit? bitand bitnot bitor bits>double bits>float bitxor complex complex? denominator double>bits each-integer even? find-integer find-last-integer fixnum fixnum? float float>bits float? fp-bitwise= fp-infinity? fp-nan-payload fp-nan? fp-qnan? fp-sign fp-snan? fp-special? gcd if-zero imaginary-part integer integer>fixnum integer>fixnum-strict integer? log2 log2-expects-positive log2-expects-positive? mod neg neg? next-float next-power-of-2 number number= number? numerator odd? power-of-2? prev-float ratio ratio? rational rational? real real-part real? recip rect> rem sgn shift simple-gcd sq times u< u<= u> u>= unless-zero unordered? when-zero zero? syn keyword factorKeyword 1sequence 2all? 2each 2each-from 2map 2map-as 2map-reduce 2reduce 2selector 2sequence 3append 3append-as 3each 3map 3map-as 3sequence 4sequence ?first ?last ?nth ?second ?set-nth accumulate accumulate! accumulate* accumulate*! accumulate*-as accumulate-as all? any? append append! append-as assert-sequence assert-sequence= assert-sequence? binary-reduce bounds-check bounds-check? bounds-error bounds-error? but-last but-last-slice cartesian-each cartesian-map cartesian-product change-nth check-slice clone-like collapse-slice collector collector-as collector-for collector-for-as concat concat-as copy count cut cut* cut-slice delete-all delete-slice drop-prefix each each-from each-index empty? exchange filter filter! filter-as find find-from find-index find-index-from find-last find-last-from first first2 first3 first4 flip follow fourth glue halves harvest head head* head-slice head-slice* head? if-empty immutable immutable-sequence immutable-sequence? immutable? index index-from indices infimum infimum-by insert-nth interleave iota iota? join join-as last last-index last-index-from length lengthen like longer longer? longest map map! map-as map-find map-find-last map-index map-index-as map-integers map-reduce map-sum max-length member-eq? member? midpoint@ min-length mismatch move new-like new-resizable new-sequence non-negative-integer-expected non-negative-integer-expected? none? nth nths pad-head pad-tail padding partition pop pop* prefix prepend prepend-as produce produce-as product push push-all push-either push-if reduce reduce-index reject reject! reject-as remove remove! remove-eq remove-eq! remove-nth remove-nth! repetition repetition? replace-slice replicate replicate-as rest rest-slice reverse reverse! reversed reversed? second selector selector-as sequence sequence-hashcode sequence= sequence? set-first set-fourth set-last set-length set-nth set-second set-third short shorten shorter shorter? shortest sift slice slice-error slice-error? slice? snip snip-slice subseq subseq-as subseq-start subseq-start-from subseq? suffix suffix! sum sum-lengths supremum supremum-by surround tail tail* tail-slice tail-slice* tail? third trim trim-head trim-head-slice trim-slice trim-tail trim-tail-slice unclip unclip-last unclip-last-slice unclip-slice unless-empty virtual-exemplar virtual-sequence virtual-sequence? virtual@ when-empty syn keyword factorKeyword +@ change change-global counter dec get get-global get-namestack global inc init-namespaces initialize namespace off on set set-global set-namestack toggle with-global with-scope with-variable with-variable-off with-variable-on with-variables syn keyword factorKeyword 1array 2array 3array 4array >array array array? pair pair? resize-array -syn keyword factorKeyword (each-stream-block) (each-stream-block-slice) (stream-contents-by-block) (stream-contents-by-element) (stream-contents-by-length) (stream-contents-by-length-or-block) +byte+ +character+ bad-seek-type bad-seek-type? bl contents each-block each-block-size each-block-slice each-line each-morsel each-stream-block each-stream-block-slice each-stream-line error-stream flush input-stream input-stream? invalid-read-buffer invalid-read-buffer? lines nl output-stream output-stream? print read read-into read-partial read-partial-into read-until read1 readln seek-absolute seek-absolute? seek-end seek-end? seek-input seek-output seek-relative seek-relative? stream-bl stream-contents stream-contents* stream-copy stream-copy* stream-element-type stream-flush stream-length stream-lines stream-nl stream-print stream-read stream-read-into stream-read-partial stream-read-partial-into stream-read-partial-unsafe stream-read-unsafe stream-read-until stream-read1 stream-readln stream-seek stream-seekable? stream-tell stream-write stream-write1 tell-input tell-output with-error-stream with-error-stream* with-error>output with-input-output+error-streams with-input-output+error-streams* with-input-stream with-input-stream* with-output+error-stream with-output+error-stream* with-output-stream with-output-stream* with-output>error with-streams with-streams* write write1 +syn keyword factorKeyword (each-stream-block) (each-stream-block-slice) (stream-contents-by-block) (stream-contents-by-element) (stream-contents-by-length) (stream-contents-by-length-or-block) +byte+ +character+ bad-seek-type bad-seek-type? bl contents each-block each-block-size each-block-slice each-line each-stream-block each-stream-block-slice each-stream-line error-stream flush input-stream input-stream? invalid-read-buffer invalid-read-buffer? lines nl output-stream output-stream? print read read-into read-partial read-partial-into read-until read1 readln seek-absolute seek-absolute? seek-end seek-end? seek-input seek-output seek-relative seek-relative? stream-bl stream-contents stream-contents* stream-copy stream-copy* stream-element-type stream-flush stream-length stream-lines stream-nl stream-print stream-read stream-read-into stream-read-partial stream-read-partial-into stream-read-partial-unsafe stream-read-unsafe stream-read-until stream-read1 stream-readln stream-seek stream-seekable? stream-tell stream-write stream-write1 tell-input tell-output with-error-stream with-error-stream* with-error>output with-input-output+error-streams with-input-output+error-streams* with-input-stream with-input-stream* with-output+error-stream with-output+error-stream* with-output-stream with-output-stream* with-output>error with-streams with-streams* write write1 syn keyword factorKeyword 1string >string resize-string string string? syn keyword factorKeyword 1vector >vector ?push vector vector? -syn keyword factorKeyword attempt-all attempt-all-error attempt-all-error? callback-error-hook callcc0 callcc1 cleanup compute-restarts condition condition? continuation continuation? continue continue-restart continue-with current-continuation error error-continuation error-in-thread error-thread ifcc ignore-error ignore-error/f ignore-errors in-callback? original-error recover restart restart? restarts rethrow rethrow-restarts return return-continuation thread-error-hook throw-continue throw-restarts with-datastack with-return +syn keyword factorKeyword attempt-all attempt-all-error attempt-all-error? callback-error-hook callcc0 callcc1 cleanup compute-restarts condition condition? continuation continuation? continue continue-restart continue-with current-continuation error error-continuation error-in-thread error-thread finally ifcc ignore-error ignore-error/f ignore-errors in-callback? original-error recover restart restart? restarts rethrow rethrow-restarts return return-continuation thread-error-hook throw-continue throw-restarts with-datastack with-return syn cluster factorReal contains=factorInt,factorFloat,factorPosRatio,factorNegRatio,factorBinary,factorHex,factorOctal From a7722b0804bd3e3378741b2768cede4526286daf Mon Sep 17 00:00:00 2001 From: Nandeeka Nayak Date: Tue, 29 Oct 2019 10:09:38 -0700 Subject: [PATCH 17/22] tensors: optimize matrix operations. tensors: Add benchmarking file tensors: Add addition and multiplication tests for benchmarking tensors: inlined slicing to improve metrics. tensors: fix help-lint warnings. tensors: restore newer matmul tensors: add fixnum declaration. tensors: away with you, unsafe! tensors: transpose added to benchmarks tensors: optimize matmul to be within an order of magnitude of np. tensors: remove type declaration. tensors: optimize matmul. --- extra/tensors/benchmark/benchmark.factor | 50 +++++++++ extra/tensors/tensors.factor | 123 +++++++++++------------ 2 files changed, 106 insertions(+), 67 deletions(-) create mode 100644 extra/tensors/benchmark/benchmark.factor diff --git a/extra/tensors/benchmark/benchmark.factor b/extra/tensors/benchmark/benchmark.factor new file mode 100644 index 0000000000..6de3a25ce9 --- /dev/null +++ b/extra/tensors/benchmark/benchmark.factor @@ -0,0 +1,50 @@ +! Copyright (C) 2019 HMC Clinic. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays io kernel locals math prettyprint tensors tools.time ; +IN: tensors.benchmark + +float + nip nip ; + +:: matmul-tensors ( trials elems -- time ) + ! Create the arrays to be multiplied + elems elems 2array naturals dup + ! Benchmark! + [ trials [ 2dup matmul drop ] times ] benchmark + ! Normalize + trials / >float + nip nip ; + +:: transpose-tensor ( trials elems -- time ) + ! Create the array to be transposed + elems elems 2array naturals + ! benchmark + [ trials [ dup transpose drop ] times ] benchmark + ! Normalize + trials / >float + nip ; + +PRIVATE> + +: run-benchmarks ( -- ) + "Benchmarking the tensors vocabulary" print + "Add two 100 element tensors" print + 1000000 100 add-tensors . + "Add two 100,000 element tensors" print + 10000 100000 add-tensors . + "Multiply two 10x10 matrices" print + 100000 10 matmul-tensors . + "Multiply two 100x100 matrices" print + 1000 100 matmul-tensors . + "Transpose a 10x10 matrix" print + 10000 10 transpose-tensor . + "Transpose a 100x100 matrix" print + 10 100 transpose-tensor . ; diff --git a/extra/tensors/tensors.factor b/extra/tensors/tensors.factor index d952474bf2..dc1cd63173 100644 --- a/extra/tensors/tensors.factor +++ b/extra/tensors/tensors.factor @@ -1,9 +1,12 @@ ! Copyright (C) 2019 HMC Clinic. ! See http://factorcode.org/license.txt for BSD license. + USING: accessors alien.c-types alien.data arrays concurrency.combinators grouping kernel locals math.functions -math.ranges math.statistics math multi-methods quotations sequences -sequences.private specialized-arrays tensors.tensor-slice typed ; +math.ranges math.statistics math multi-methods quotations sequences +sequences.extras sequences.private specialized-arrays +tensors.tensor-slice typed ; + QUALIFIED-WITH: alien.c-types c SPECIALIZED-ARRAY: c:float IN: tensors @@ -47,7 +50,7 @@ PRIVATE> ! Construct a one-dimensional tensor with values start, start+step, ! ..., stop (inclusive) : arange ( a b step -- tensor ) - [ length 1array ] keep >float-array ; + [ length >fixnum 1array ] keep >float-array ; ! Construct a tensors with vec { 0 1 2 ... } and reshape to the desired shape : naturals ( shape -- tensor ) @@ -148,20 +151,24 @@ METHOD: t% { number tensor } swap [ swap mod ] curry t-uop ; ! Perform matrix multiplication muliplying an ! mxn matrix with a nxp matrix -TYPED:: 2d-matmul ( vec1: slice vec2: slice res: slice n: number p: number -- ) +TYPED:: 2d-matmul ( vec1: float-array start1: fixnum + vec2: float-array start2: fixnum + res: float-array start3: fixnum + m: fixnum n: fixnum p: fixnum -- ) ! For each element in the range, we want to compute the dot product of the ! corresponding row and column - res - [ >fixnum - ! Get the row - [ [ vec1 n ] dip p row ] - ! Get the column - ! [ p mod vec2 swap p every ] bi - [ p mod f p vec2 ] bi - ! Take the dot product - [ * ] [ + ] 2map-reduce - ] - map! drop ; + m [ :> i + p [ :> j + 0.0 ! This is the sum + n [ :> k + ! Add to the sum + i n * k + start1 + vec1 nth-unsafe + k p * j + start2 + vec2 nth-unsafe + * + + ] each-integer + i p * j + start3 + res set-nth-unsafe + ] each-integer + ] each-integer ; PRIVATE> @@ -176,70 +183,52 @@ TYPED:: matmul ( tensor1: tensor tensor2: tensor -- tensor3: tensor ) tensor1 shape>> unclip-last-slice :> n unclip-last-slice :> m :> top-shape tensor2 shape>> last :> p - top-shape product :> rest + top-shape product :> top-prod - ! Now create the new tensor with { 0 ... m*p-1 } repeating - top-shape { m p } append naturals m p * t% :> tensor3 + ! Create the shape of the resulting tensor + top-shape { m p } append + + ! Now create the new float array to store the underlying result + dup product c:float (c-array) :> vec3 ! Now update the tensor3 to contain the multiplied matricies - rest [0,b) - [ + top-prod [ :> i - ! First make vec1 - m n * i * dup m n * + tensor1 vec>> - ! Now make vec2 - n p * i * dup n p * + tensor2 vec>> - ! Now make the resulting vector - m p * i * dup m p * + tensor3 vec>> - ! Push n and p and multiply the clices - n p 2d-matmul - 0 - ] map drop - tensor3 ; + ! Compute vec1 and start1 + tensor1 vec>> m n * i * + ! Compute vec2 and start2 + tensor2 vec>> n p * i * + ! Compute the result + vec3 m p * i * + ! Push m, n, and p and multiply the arrays + m n p 2d-matmul + ] each-integer + vec3 ; + cum-product { 1 } prepend ; + 1 swap [ swap [ * ] keep ] map nip ; ! helper for transpose: given shape, flat index, & mults for the shape, gives nd index -:: trans-index ( ind shape mults -- seq ) - ! what we use to divide things - shape reverse :> S - ! accumulator - V{ } clone - ! loop thru elements & indices of S (mod by elment m) - S [| m i | - ! we divide by the product of the 1st n elements of S - S i head-slice product :> div - ! do not mod on the last index - i S length 1 - = not :> mod? - ! multiply accumulator by mults & sum - dup mults [ * ] 2map sum - ! subtract from ind & divide - ind swap - div / - ! mod if necessary - mod? [ m mod ] [ ] if - ! append to accumulator - [ dup ] dip swap push - ] each-index - reverse ; +: transpose-index ( i shape -- seq ) + [ /mod ] map reverse nip ; PRIVATE> -! Transpose an n-dimensional tensor +! Transpose an n-dimensional tensor by flipping the axes TYPED:: transpose ( tensor: tensor -- tensor': tensor ) - ! new shape - tensor shape>> reverse :> newshape - ! what we multiply by to get indices in the old tensor - tensor shape>> ind-mults :> old-mults - ! what we multiply to get indices in new tensor - newshape ind-mults :> mults - ! new tensor of correct shape - newshape naturals dup vec>> - [ ! go thru each index + tensor shape>> :> old-shape + tensor vec>> :> vec + old-shape reverse :> new-shape + ! check that the size is fine + new-shape product vec length assert= + old-shape ind-mults reverse :> mults + ! loop through new tensor + new-shape dup product [ ! find index in original tensor - newshape mults trans-index old-mults [ * ] 2map sum >fixnum + old-shape mults [ [ /mod ] dip * ] 2map-sum nip ! get that index in original tensor - tensor vec>> nth - ] map! >>vec ; + vec nth-unsafe + ] float-array{ } map-as ; From 1959c68febe894a7220870603bc5be0a1b8591ba Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Fri, 13 Dec 2019 15:09:24 -0800 Subject: [PATCH 18/22] tensors: faster tensor/number operations by forcing floats. --- extra/tensors/tensors.factor | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/extra/tensors/tensors.factor b/extra/tensors/tensors.factor index dc1cd63173..dd44ca72f5 100644 --- a/extra/tensors/tensors.factor +++ b/extra/tensors/tensors.factor @@ -101,32 +101,32 @@ PRIVATE> ! Add a tensor to either another tensor or a scalar multi-methods:GENERIC: t+ ( x y -- tensor ) METHOD: t+ { tensor tensor } [ + ] t-bop ; -METHOD: t+ { tensor number } [ + ] curry t-uop ; -METHOD: t+ { number tensor } swap [ + ] curry t-uop ; +METHOD: t+ { tensor number } >float [ + ] curry t-uop ; +METHOD: t+ { number tensor } [ >float ] dip [ + ] with t-uop ; ! Subtraction between two tensors or a tensor and a scalar multi-methods:GENERIC: t- ( x y -- tensor ) METHOD: t- { tensor tensor } [ - ] t-bop ; -METHOD: t- { tensor number } [ - ] curry t-uop ; -METHOD: t- { number tensor } swap [ swap - ] curry t-uop ; +METHOD: t- { tensor number } >float [ - ] curry t-uop ; +METHOD: t- { number tensor } [ >float ] dip [ - ] with t-uop ; ! Multiply a tensor with either another tensor or a scalar multi-methods:GENERIC: t* ( x y -- tensor ) METHOD: t* { tensor tensor } [ * ] t-bop ; METHOD: t* { tensor number } [ * ] curry t-uop ; -METHOD: t* { number tensor } swap [ * ] curry t-uop ; +METHOD: t* { number tensor } [ >float ] dip [ * ] with t-uop ; ! Divide two tensors or a tensor and a scalar multi-methods:GENERIC: t/ ( x y -- tensor ) METHOD: t/ { tensor tensor } [ / ] t-bop ; METHOD: t/ { tensor number } [ / ] curry t-uop ; -METHOD: t/ { number tensor } swap [ swap / ] curry t-uop ; +METHOD: t/ { number tensor } [ / ] with t-uop ; ! Divide two tensors or a tensor and a scalar multi-methods:GENERIC: t% ( x y -- tensor ) METHOD: t% { tensor tensor } [ mod ] t-bop ; METHOD: t% { tensor number } [ mod ] curry t-uop ; -METHOD: t% { number tensor } swap [ swap mod ] curry t-uop ; +METHOD: t% { number tensor } [ mod ] with t-uop ; Date: Fri, 13 Dec 2019 15:31:49 -0800 Subject: [PATCH 19/22] timers: allow timers to re-use threads when restarted, simplify. Throw an error if started twice. --- basis/timers/timers-tests.factor | 21 +++++- basis/timers/timers.factor | 106 ++++++++++++------------------- 2 files changed, 61 insertions(+), 66 deletions(-) diff --git a/basis/timers/timers-tests.factor b/basis/timers/timers-tests.factor index ce2a79f833..3c1c388d7e 100644 --- a/basis/timers/timers-tests.factor +++ b/basis/timers/timers-tests.factor @@ -1,6 +1,6 @@ -USING: timers timers.private calendar concurrency.count-downs +USING: accessors calendar combinators concurrency.count-downs concurrency.promises fry kernel math math.order sequences -threads tools.test tools.time ; +threads timers tools.test tools.time ; { } [ 1 @@ -74,3 +74,20 @@ threads tools.test tools.time ; dup restart-timer drop 700 milliseconds sleep ] unit-test + + +{ { 1 } t t t t } [ + { 0 } + dup '[ 0 _ [ 1 + ] change-nth ] 300 milliseconds f + dup start-timer [ thread>> ] keep { + [ dup restart-timer thread>> eq? ] + [ dup restart-timer thread>> eq? ] + [ dup restart-timer thread>> eq? ] + [ dup restart-timer thread>> eq? ] + } 2cleave + 700 milliseconds sleep +] unit-test + +[ + [ ] 1 seconds later start-timer +] [ timer-already-started? ] must-fail-with diff --git a/basis/timers/timers.factor b/basis/timers/timers.factor index 029f640616..57006c1bd9 100644 --- a/basis/timers/timers.factor +++ b/basis/timers/timers.factor @@ -1,17 +1,17 @@ ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors calendar combinators.short-circuit fry kernel -math math.functions quotations system threads typed ; + +USING: accessors calendar fry kernel math quotations system +threads ; + IN: timers TUPLE: timer { quot callable initial: [ ] } - start-nanos delay-nanos interval-nanos - iteration-start-nanos + next-nanos quotation-running? - restart? thread ; nanoseconds ; M: real >nanoseconds >integer ; M: duration >nanoseconds duration>nanoseconds >integer ; -TYPED: set-next-timer-time ( timer: timer -- timer ) - ! start + delay + ceiling((now - (start + delay)) / interval) * interval - nano-count - over start-nanos>> - - over delay-nanos>> [ - ] when* - over interval-nanos>> / ceiling - over interval-nanos>> * - over start-nanos>> + - over delay-nanos>> [ + ] when* - >>iteration-start-nanos ; +: delay-nanos ( timer -- n ) + delay-nanos>> 0 or nano-count + ; -TYPED: stop-timer? ( timer: timer -- ? ) - { [ thread>> self eq? not ] [ restart?>> ] } 1|| ; inline +: interval-nanos ( timer -- n/f ) + [ next-nanos>> nano-count over - ] [ interval-nanos>> ] bi + [ dupd [ mod ] [ swap - ] bi + + ] [ 2drop f ] if* ; -DEFER: call-timer-loop +: next-nanos ( timer -- timer n/f ) + dup thread>> self eq? [ + dup next-nanos>> dup t eq? [ + drop dup delay-nanos [ >>next-nanos ] keep + ] when + ] [ f ] if ; -TYPED: loop-timer ( timer: timer -- ) - nano-count over - [ iteration-start-nanos>> - ] [ interval-nanos>> ] bi < - [ set-next-timer-time ] dip - [ dup iteration-start-nanos>> ] [ 0 ] if - 0 or sleep-until call-timer-loop ; +: run-timer ( timer -- timer ) + dup interval-nanos >>next-nanos + t >>quotation-running? + dup quot>> call( -- ) + f >>quotation-running? ; -TYPED: maybe-loop-timer ( timer: timer -- ) - dup { [ stop-timer? ] [ interval-nanos>> not ] } 1|| - [ drop ] [ loop-timer ] if ; +: timer-loop ( timer -- ) + [ next-nanos ] [ + dup nano-count <= [ + drop run-timer yield + ] [ + sleep-until + ] if + ] while* dup thread>> self eq? [ f >>thread ] when drop ; -TYPED: call-timer-loop ( timer: timer -- ) - dup stop-timer? [ - drop - ] [ - [ - [ t >>quotation-running? drop ] - [ quot>> call( -- ) ] - [ f >>quotation-running? drop ] tri - ] keep - maybe-loop-timer - ] if ; - -TYPED: sleep-delay ( timer: timer -- ) - dup stop-timer? [ - drop - ] [ - nano-count >>start-nanos - delay-nanos>> [ sleep ] when* - ] if ; - -TYPED: timer-loop ( timer: timer -- ) - [ sleep-delay ] - [ nano-count >>iteration-start-nanos call-timer-loop ] - [ dup restart?>> [ f >>restart? timer-loop ] [ drop ] if ] tri ; +: ?interrupt ( thread timer -- ) + quotation-running?>> [ drop ] [ [ interrupt ] when* ] if ; PRIVATE> +ERROR: timer-already-started timer ; + : ( quot delay-duration/f interval-duration/f -- timer ) timer new swap >nanoseconds >>interval-nanos @@ -82,20 +64,19 @@ PRIVATE> swap >>quot ; inline : start-timer ( timer -- ) - [ - '[ _ timer-loop ] "Timer execution" spawn - ] keep thread<< ; + dup thread>> [ timer-already-started ] when + t >>next-nanos + dup '[ _ timer-loop ] "Timer" + [ >>thread drop ] [ (spawn) ] bi ; : stop-timer ( timer -- ) - dup quotation-running?>> [ - dup thread>> [ interrupt ] when* - ] unless f >>thread drop ; + [ f ] change-thread ?interrupt ; : restart-timer ( timer -- ) - dup quotation-running?>> [ - t >>restart? drop + dup thread>> [ + t >>next-nanos [ thread>> ] [ ?interrupt ] bi ] [ - dup thread>> [ interrupt ] when* start-timer + start-timer ] if ; PRIVATE> : every ( quot interval-duration -- timer ) - [ f ] dip (start-timer) ; + f swap (start-timer) ; : later ( quot delay-duration -- timer ) f (start-timer) ; : delayed-every ( quot duration -- timer ) dup (start-timer) ; - -: nanos-since ( nano-count -- nanos ) - [ nano-count ] dip - ; From 6be39382a3047577d9cf5fe8f35ec88201a0852a Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Fri, 13 Dec 2019 19:20:27 -0800 Subject: [PATCH 20/22] sequences: adding cartesian-find. --- core/sequences/sequences-docs.factor | 5 +++++ core/sequences/sequences-tests.factor | 3 +++ core/sequences/sequences.factor | 3 +++ 3 files changed, 11 insertions(+) diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 2404d2e17e..1ce18af8b2 100644 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -1621,6 +1621,10 @@ HELP: assert-sequence= } } ; +HELP: cartesian-find +{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation ( ... elt1 elt2 -- ... ? ) } } { "elt1" object } { "elt2" object } } +{ $description "Applies the quotation to every possible pairing of elements from the two sequences, returning the first two elements where the quotation returns a true value." } ; + HELP: cartesian-each { $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation ( ... elt1 elt2 -- ... ) } } } { $description "Applies the quotation to every possible pairing of elements from the two sequences." } ; @@ -1981,6 +1985,7 @@ $nl { $subsections cartesian-each cartesian-map + cartesian-find } "Computing the cartesian product of two sequences:" { $subsections diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 72a326aaab..74320d76ba 100644 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -363,6 +363,9 @@ M: bogus-hashcode hashcode* 2drop 0 >bignum ; { { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } } [ { 1 2 } { "a" "b" } cartesian-product ] unit-test +{ 2 4 } [ { 1 2 3 } { 4 5 6 } [ [ even? ] both? ] cartesian-find ] unit-test +{ f f } [ { 1 2 3 } { 4 5 6 } [ [ 10 > ] both? ] cartesian-find ] unit-test + [ { } [ string>digits sum ] [ + ] map-reduce ] must-infer [ { } [ ] [ + ] map-reduce ] must-fail { 4 } [ { 1 1 } [ 1 + ] [ + ] map-reduce ] unit-test diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index a711f645af..d0b2a7bc42 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -1082,6 +1082,9 @@ M: repetition sum [ elt>> ] [ length>> ] bi * ; inline : cartesian-product ( seq1 seq2 -- newseq ) [ { } 2sequence ] cartesian-map ; +: cartesian-find ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ? ) -- ... elt1 elt2 ) + [ f ] 3dip [ with find swap ] 2curry [ nip ] prepose find nip swap ; inline + Date: Fri, 13 Dec 2019 19:30:22 -0800 Subject: [PATCH 21/22] sequences.product: adding product-find. --- basis/sequences/product/product-docs.factor | 8 +++++++- basis/sequences/product/product-tests.factor | 12 +++++++++++- basis/sequences/product/product.factor | 7 +++++++ 3 files changed, 25 insertions(+), 2 deletions(-) diff --git a/basis/sequences/product/product-docs.factor b/basis/sequences/product/product-docs.factor index 36322fdd9c..29653555fd 100644 --- a/basis/sequences/product/product-docs.factor +++ b/basis/sequences/product/product-docs.factor @@ -58,7 +58,12 @@ HELP: product-each { $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } "." } { $notes { $snippet "[ ... ] product-each" } " is equivalent to, but more efficient than, " { $snippet " [ ... ] each" } "." } ; -{ product-map product-each } related-words +HELP: product-find +{ $values { "sequences" sequence } { "quot" { $quotation ( ... seq -- ... ? ) } } { "sequence" sequence } } +{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } ", returning the first sequence where the quotation returns a true value." } +{ $notes { $snippet "[ ... ] product-each" } " is equivalent to, but more efficient than, " { $snippet " [ ... ] find" } "." } ; + +{ product-map product-each product-find } related-words ARTICLE: "sequences.product" "Product sequences" "The " { $vocab-link "sequences.product" } " vocabulary provides a virtual sequence and combinators for manipulating the cartesian product of a set of sequences." @@ -69,6 +74,7 @@ ARTICLE: "sequences.product" "Product sequences" product-map-as product-map>assoc product-each + product-find } ; ABOUT: "sequences.product" diff --git a/basis/sequences/product/product-tests.factor b/basis/sequences/product/product-tests.factor index 5dfe79d04e..06a65a7be8 100644 --- a/basis/sequences/product/product-tests.factor +++ b/basis/sequences/product/product-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel make sequences sequences.product tools.test ; +USING: arrays kernel make math sequences sequences.product tools.test ; { { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } } [ { { 0 1 2 } { "a" "b" } } >array ] unit-test @@ -24,3 +24,13 @@ USING: arrays kernel make sequences sequences.product tools.test ; { { } } [ { { } { 1 } } [ ] product-map ] unit-test { } [ { { } { 1 } } [ drop ] product-each ] unit-test + +{ { 2 4 8 } } [ + { { 1 2 3 } { 4 5 6 } { 7 8 9 } } + [ [ even? ] all? ] product-find +] unit-test + +{ f } [ + { { 1 2 3 } { 4 5 6 } { 7 8 9 } } + [ [ 10 > ] all? ] product-find +] unit-test diff --git a/basis/sequences/product/product.factor b/basis/sequences/product/product.factor index 9f0289b827..f5e6c668bd 100644 --- a/basis/sequences/product/product.factor +++ b/basis/sequences/product/product.factor @@ -78,3 +78,10 @@ M: product-sequence nth sequences [ quot call 2array i result set-nth-unsafe i 1 + i! ] product-each result ] new-like exemplar assoc-like ; inline + +:: product-find ( ... sequences quot: ( ... seq -- ... ? ) -- ... sequence ) + sequences start-product-iter :> ( ns lengths ) + lengths [ 0 = ] any? [ + f [ ns lengths end-product-iter? over or ] + [ drop ns sequences nths quot keep and ns lengths product-iter ] until + ] unless ; inline From 07833d94c691a153c2b71f6564f0f453000ff9a8 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Fri, 13 Dec 2019 19:31:17 -0800 Subject: [PATCH 22/22] misc/vim: update syntax for cartesian-find. --- misc/vim/syntax/factor.vim | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/misc/vim/syntax/factor.vim b/misc/vim/syntax/factor.vim index a403897c09..4393d24d15 100644 --- a/misc/vim/syntax/factor.vim +++ b/misc/vim/syntax/factor.vim @@ -57,7 +57,7 @@ syn keyword factorKeyword (clone) -roll -rot -rotd 2bi 2bi* 2bi@ 2curry 2dip 2dr syn keyword factorKeyword 2cache >alist ?at ?delete-at ?of assoc assoc-all? assoc-any? assoc-clone-like assoc-combine assoc-diff assoc-diff! assoc-differ assoc-each assoc-empty? assoc-filter assoc-filter! assoc-filter-as assoc-find assoc-hashcode assoc-intersect assoc-like assoc-map assoc-map-as assoc-partition assoc-refine assoc-reject assoc-reject! assoc-reject-as assoc-size assoc-stack assoc-subset? assoc-union assoc-union! assoc-union-as assoc= assoc>map assoc? at at* at+ cache change-at clear-assoc collect-by delete-at delete-at* enumerated enumerated? extract-keys harvest-keys harvest-values inc-at key? keys map>alist map>assoc maybe-set-at new-assoc of push-at rename-at set-at sift-keys sift-values substitute unzip value-at value-at* value? values zip zip-as zip-index zip-index-as syn keyword factorKeyword 2cleave 2cleave>quot 3cleave 3cleave>quot 4cleave 4cleave>quot alist>quot call-effect case case-find case>quot cleave cleave>quot cond cond>quot deep-spread>quot execute-effect linear-case-quot no-case no-case? no-cond no-cond? recursive-hashcode shallow-spread>quot spread to-fixed-point wrong-values wrong-values? syn keyword factorKeyword (all-integers?) (each-integer) (find-integer) * + - / /f /i /mod 2/ 2^ < <= > >= >bignum >fixnum >float >fraction >integer >rect ?1+ abs align all-integers? bignum bignum? bit? bitand bitnot bitor bits>double bits>float bitxor complex complex? denominator double>bits each-integer even? find-integer find-last-integer fixnum fixnum? float float>bits float? fp-bitwise= fp-infinity? fp-nan-payload fp-nan? fp-qnan? fp-sign fp-snan? fp-special? gcd if-zero imaginary-part integer integer>fixnum integer>fixnum-strict integer? log2 log2-expects-positive log2-expects-positive? mod neg neg? next-float next-power-of-2 number number= number? numerator odd? power-of-2? prev-float ratio ratio? rational rational? real real-part real? recip rect> rem sgn shift simple-gcd sq times u< u<= u> u>= unless-zero unordered? when-zero zero? -syn keyword factorKeyword 1sequence 2all? 2each 2each-from 2map 2map-as 2map-reduce 2reduce 2selector 2sequence 3append 3append-as 3each 3map 3map-as 3sequence 4sequence ?first ?last ?nth ?second ?set-nth accumulate accumulate! accumulate* accumulate*! accumulate*-as accumulate-as all? any? append append! append-as assert-sequence assert-sequence= assert-sequence? binary-reduce bounds-check bounds-check? bounds-error bounds-error? but-last but-last-slice cartesian-each cartesian-map cartesian-product change-nth check-slice clone-like collapse-slice collector collector-as collector-for collector-for-as concat concat-as copy count cut cut* cut-slice delete-all delete-slice drop-prefix each each-from each-index empty? exchange filter filter! filter-as find find-from find-index find-index-from find-last find-last-from first first2 first3 first4 flip follow fourth glue halves harvest head head* head-slice head-slice* head? if-empty immutable immutable-sequence immutable-sequence? immutable? index index-from indices infimum infimum-by insert-nth interleave iota iota? join join-as last last-index last-index-from length lengthen like longer longer? longest map map! map-as map-find map-find-last map-index map-index-as map-integers map-reduce map-sum max-length member-eq? member? midpoint@ min-length mismatch move new-like new-resizable new-sequence non-negative-integer-expected non-negative-integer-expected? none? nth nths pad-head pad-tail padding partition pop pop* prefix prepend prepend-as produce produce-as product push push-all push-either push-if reduce reduce-index reject reject! reject-as remove remove! remove-eq remove-eq! remove-nth remove-nth! repetition repetition? replace-slice replicate replicate-as rest rest-slice reverse reverse! reversed reversed? second selector selector-as sequence sequence-hashcode sequence= sequence? set-first set-fourth set-last set-length set-nth set-second set-third short shorten shorter shorter? shortest sift slice slice-error slice-error? slice? snip snip-slice subseq subseq-as subseq-start subseq-start-from subseq? suffix suffix! sum sum-lengths supremum supremum-by surround tail tail* tail-slice tail-slice* tail? third trim trim-head trim-head-slice trim-slice trim-tail trim-tail-slice unclip unclip-last unclip-last-slice unclip-slice unless-empty virtual-exemplar virtual-sequence virtual-sequence? virtual@ when-empty +syn keyword factorKeyword 1sequence 2all? 2each 2each-from 2map 2map-as 2map-reduce 2reduce 2selector 2sequence 3append 3append-as 3each 3map 3map-as 3sequence 4sequence ?first ?last ?nth ?second ?set-nth accumulate accumulate! accumulate* accumulate*! accumulate*-as accumulate-as all? any? append append! append-as assert-sequence assert-sequence= assert-sequence? binary-reduce bounds-check bounds-check? bounds-error bounds-error? but-last but-last-slice cartesian-each cartesian-find cartesian-map cartesian-product change-nth check-slice clone-like collapse-slice collector collector-as collector-for collector-for-as concat concat-as copy count cut cut* cut-slice delete-all delete-slice drop-prefix each each-from each-index empty? exchange filter filter! filter-as find find-from find-index find-index-from find-last find-last-from first first2 first3 first4 flip follow fourth glue halves harvest head head* head-slice head-slice* head? if-empty immutable immutable-sequence immutable-sequence? immutable? index index-from indices infimum infimum-by insert-nth interleave iota iota? join join-as last last-index last-index-from length lengthen like longer longer? longest map map! map-as map-find map-find-last map-index map-index-as map-integers map-reduce map-sum max-length member-eq? member? midpoint@ min-length mismatch move new-like new-resizable new-sequence non-negative-integer-expected non-negative-integer-expected? none? nth nths pad-head pad-tail padding partition pop pop* prefix prepend prepend-as produce produce-as product push push-all push-either push-if reduce reduce-index reject reject! reject-as remove remove! remove-eq remove-eq! remove-nth remove-nth! repetition repetition? replace-slice replicate replicate-as rest rest-slice reverse reverse! reversed reversed? second selector selector-as sequence sequence-hashcode sequence= sequence? set-first set-fourth set-last set-length set-nth set-second set-third short shorten shorter shorter? shortest sift slice slice-error slice-error? slice? snip snip-slice subseq subseq-as subseq-start subseq-start-from subseq? suffix suffix! sum sum-lengths supremum supremum-by surround tail tail* tail-slice tail-slice* tail? third trim trim-head trim-head-slice trim-slice trim-tail trim-tail-slice unclip unclip-last unclip-last-slice unclip-slice unless-empty virtual-exemplar virtual-sequence virtual-sequence? virtual@ when-empty syn keyword factorKeyword +@ change change-global counter dec get get-global get-namestack global inc init-namespaces initialize namespace off on set set-global set-namestack toggle with-global with-scope with-variable with-variable-off with-variable-on with-variables syn keyword factorKeyword 1array 2array 3array 4array >array array array? pair pair? resize-array syn keyword factorKeyword (each-stream-block) (each-stream-block-slice) (stream-contents-by-block) (stream-contents-by-element) (stream-contents-by-length) (stream-contents-by-length-or-block) +byte+ +character+ bad-seek-type bad-seek-type? bl contents each-block each-block-size each-block-slice each-line each-stream-block each-stream-block-slice each-stream-line error-stream flush input-stream input-stream? invalid-read-buffer invalid-read-buffer? lines nl output-stream output-stream? print read read-into read-partial read-partial-into read-until read1 readln seek-absolute seek-absolute? seek-end seek-end? seek-input seek-output seek-relative seek-relative? stream-bl stream-contents stream-contents* stream-copy stream-copy* stream-element-type stream-flush stream-length stream-lines stream-nl stream-print stream-read stream-read-into stream-read-partial stream-read-partial-into stream-read-partial-unsafe stream-read-unsafe stream-read-until stream-read1 stream-readln stream-seek stream-seekable? stream-tell stream-write stream-write1 tell-input tell-output with-error-stream with-error-stream* with-error>output with-input-output+error-streams with-input-output+error-streams* with-input-stream with-input-stream* with-output+error-stream with-output+error-stream* with-output-stream with-output-stream* with-output>error with-streams with-streams* write write1