steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'modern-harvey3' of github.com:factor/factor into modern-harvey3

modern-harvey3
Doug Coleman 2019-12-01 10:06:49 -06:00
parent bea7852d60 618d41251e
commit 355c52390d
21 changed files with 1071 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
Nmakefile
View File

@ -8,21 +8,21 @@ VERSION = 0.99
!IF [git describe --all > git-describe.tmp] == 0
GIT_DESCRIBE = \
!INCLUDE <git-describe.tmp>
!IF [rm git-describe.tmp] == 0
!IF [del git-describe.tmp] == 0
!ENDIF
!ENDIF
!IF [git rev-parse HEAD > git-id.tmp] == 0
GIT_ID = \
!INCLUDE <git-id.tmp>
!IF [rm git-id.tmp] == 0
!IF [del git-id.tmp] == 0
!ENDIF
!ENDIF
!IF [git rev-parse --abbrev-ref HEAD > git-branch.tmp] == 0
GIT_BRANCH = \
!INCLUDE <git-branch.tmp>
!IF [rm git-branch.tmp] == 0
!IF [del git-branch.tmp] == 0
!ENDIF
!ENDIF

2
basis/calendar/windows/windows.factor
View File

@ -31,7 +31,7 @@ IN: calendar.windows
M: windows gmt-offset ( -- hours minutes seconds )
TIME_ZONE_INFORMATION <struct>
dup GetTimeZoneInformation {
{ TIME_ZONE_ID_INVALID [ win32-error-string throw ] }
{ TIME_ZONE_ID_INVALID [ win32-error ] }
{ TIME_ZONE_ID_UNKNOWN [ Bias>> ] }
{ TIME_ZONE_ID_STANDARD [ Bias>> ] }
{ TIME_ZONE_ID_DAYLIGHT [ [ Bias>> ] [ DaylightBias>> ] bi + ] }

5
basis/io/directories/windows/windows.factor
View File

@ -31,7 +31,7 @@ ERROR: file-delete-failed path error ;
: (delete-file) ( path -- )
dup DeleteFile 0 = [
GetLastError ERROR_ACCESS_DENIED =
[ delete-read-only-file ] [ throw-win32-error ] if
[ delete-read-only-file ] [ win32-error ] if
] [ drop ] if ;
M: windows delete-file ( path -- )
@ -48,8 +48,7 @@ M: windows delete-directory ( path -- )
RemoveDirectory win32-error=0/f ;
: find-first-file ( path WIN32_FIND_DATA -- WIN32_FIND_DATA HANDLE )
[ nip ] [ FindFirstFile ] 2bi
[ INVALID_HANDLE_VALUE = [ win32-error-string throw ] when ] keep ;
[ nip ] [ FindFirstFile ] 2bi check-invalid-handle ;
: find-next-file ( HANDLE WIN32_FIND_DATA -- WIN32_FIND_DATA/f )
[ nip ] [ FindNextFile ] 2bi 0 = [

7
basis/io/files/info/windows/windows.factor
View File

@ -19,7 +19,7 @@ TUPLE: windows-file-info < file-info-tuple attributes ;
: get-compressed-file-size ( path -- n )
{ DWORD } [ GetCompressedFileSize ] with-out-parameters
over INVALID_FILE_SIZE = [ win32-error-string throw ] [ >64bit ] if ;
over INVALID_FILE_SIZE = [ win32-error ] [ >64bit ] if ;
: set-windows-size-on-disk ( file-info path -- file-info )
over attributes>> +compressed+ swap member? [
@ -42,8 +42,7 @@ TUPLE: windows-file-info < file-info-tuple attributes ;
: find-first-file-stat ( path -- WIN32_FIND_DATA )
WIN32_FIND_DATA <struct> [
FindFirstFile
[ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep
FindFirstFile check-invalid-handle
FindClose win32-error=0/f
] keep ;
@ -184,7 +183,7 @@ CONSTANT: names-buf-length 16384
[ path-length FindNextVolume ] with-out-parameters
swap 0 = [
GetLastError ERROR_NO_MORE_FILES =
[ drop f ] [ win32-error-string throw ] if
[ drop f ] [ win32-error ] if
] [ alien>native-string ] if ;
: find-volumes ( -- array )

10
basis/io/files/windows/windows.factor
View File

@ -76,7 +76,7 @@ SYMBOL: master-completion-port
{ [ dup integer? ] [ ] }
{ [ dup array? ] [
first dup eof?
[ drop 0 ] [ n>win32-error-string throw ] if
[ drop 0 ] [ throw-windows-error ] if
] }
} cond
] with-timeout ;
@ -117,7 +117,7 @@ M: windows init-io ( -- )
: handle>file-size ( handle -- n/f )
(handle>file-size) [
GetLastError ERROR_INVALID_FUNCTION =
[ f ] [ throw-win32-error ] if
[ f ] [ win32-error ] if
] unless* ;
ERROR: seek-before-start n ;
@ -147,7 +147,7 @@ M: windows handle-length ( handle -- n/f )
GetLastError {
{ [ dup expected-io-error? ] [ drop f ] }
{ [ dup eof? ] [ drop t ] }
[ n>win32-error-string throw ]
[ throw-windows-error ]
} cond
] [ f ] if ;
@ -399,8 +399,8 @@ M: windows home
WIN32_FIND_STREAM_DATA <struct>
0
[ FindFirstStream ] keepd
over -1 <alien> = [
2drop throw-win32-error
over INVALID_HANDLE_VALUE = [
2drop win32-error
] [
1vector swap file-streams-rest
] if ;

2
basis/io/sockets/secure/windows/windows.factor
View File

@ -14,7 +14,7 @@ M: openssl ssl-certificate-verification-supported? f ;
: load-windows-cert-store ( string -- HCERTSTORE )
[ f ] dip CertOpenSystemStore
[ win32-error-string throw ] when-zero ;
[ win32-error ] when-zero ;
: X509-NAME. ( X509_NAME -- )
f 0 X509_NAME_oneline

1
basis/random/passwords/authors.txt Normal file
View File

@ -0,0 +1 @@
Alexander Ilin

48
basis/random/passwords/passwords-docs.factor Normal file
View File

@ -0,0 +1,48 @@
! Copyright (C) 2019 Alexander Ilin.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel random strings ;
IN: random.passwords
ABOUT: "random.passwords"
ARTICLE: "random.passwords" "Generating random passwords"
"The " { $vocab-link "random.passwords" } " vocab provides functions for generation of random passwords."
$nl
"Generate password of a given length from some often used character sets:"
{ $subsections alnum-password hex-password ascii-password }
"Generate a password from a custom character set:"
{ $subsections password }
;
HELP: password
{ $values
{ "n" "password length" }
{ "charset" string }
{ "string" string }
}
{ $description "Generate a password of length " { $snippet "n" } " by randomly selecting characters from the " { $snippet "charset" } " string. All characters of the " { $snippet "charset" } " have equal probability of appearing at any position of the result."
$nl
"If " { $snippet "n" } " = 0, return empty string. If " { $snippet "n" } " < 0, throw an error."
$nl
{ $link secure-random-generator } " is used as the randomness source." } ;
HELP: alnum-password
{ $values
{ "n" "password length" }
{ "string" string }
}
{ $description "Generate a random password consisting of " { $snippet "n" } " alphanumeric characters (0..9, A..Z, a..z)." } ;
HELP: ascii-password
{ $values
{ "n" "password length" }
{ "string" string }
}
{ $description "Generate a random password consisting of " { $snippet "n" } " printable ASCII characters." } ;
HELP: hex-password
{ $values
{ "n" "password length" }
{ "string" string }
}
{ $description "Generate a random password consisting of " { $snippet "n" } " hexadecimal characters (0..9, A..F)." } ;

14
basis/random/passwords/passwords-tests.factor Normal file
View File

@ -0,0 +1,14 @@
! Copyright (C) 2019 Alexander Ilin.
! See http://factorcode.org/license.txt for BSD license.
USING: math math.parser random.passwords sequences tools.test ;
IN: random.passwords.tests
{ "aaaaaaaaaa" } [ 10 "a" password ] unit-test
{ 10 } [ 10 "ab" password length ] unit-test
{ "" } [ 0 "ab" password ] unit-test
[ -1 "ab" password ] must-fail
{ 2 } [ 2 ascii-password length ] unit-test
{ 3 } [ 3 alnum-password length ] unit-test
{ 4 } [ 4 hex-password length ] unit-test
{ t } [ 4 hex-password hex> 65535 <= ] unit-test

27
basis/random/passwords/passwords.factor Normal file
View File

@ -0,0 +1,27 @@
! Copyright (C) 2019 Alexander Ilin.
! See http://factorcode.org/license.txt for BSD license.
USING: fry literals math.ranges random sequences ;
IN: random.passwords
<PRIVATE
CONSTANT: ascii-printable-charset $[ 33 126 [a,b] ]
CONSTANT: hex-charset "0123456789ABCDEF"
CONSTANT: alphanum-charset $[
char: 0 char: 9 [a,b]
char: a char: z [a,b] append
char: A char: Z [a,b] append ]
PRIVATE>
: password ( n charset -- string )
'[ [ _ random ] "" replicate-as ] with-secure-random ;
: ascii-password ( n -- string )
ascii-printable-charset password ;
: hex-password ( n -- string )
hex-charset password ;
: alnum-password ( n -- string )
alphanum-charset password ;

1
basis/windows/errors/authors.txt
View File

@ -1 +1,2 @@
Doug Coleman
Alexander Ilin

33
basis/windows/errors/errors.factor
View File

@ -717,34 +717,23 @@ CONSTANT: FORMAT_MESSAGE_MAX_WIDTH_MASK 0x000000FF
[ drop "Unknown error 0x" id 0xffff,ffff bitand >hex append ]
[ alien>native-string [ blank? ] trim ] if ;
: win32-error-string ( -- str )
GetLastError n>win32-error-string ;
ERROR: windows-error n string ;
: (win32-error) ( n -- )
[ dup win32-error-string windows-error ] unless-zero ;
: throw-windows-error ( n -- * )
dup n>win32-error-string windows-error ;
: win32-error ( -- )
GetLastError (win32-error) ;
: n>win32-error-check ( n -- )
[ throw-windows-error ] unless-zero ;
! Note that win32-error* words throw GetLastError code.
: win32-error ( -- ) GetLastError n>win32-error-check ;
: win32-error=0/f ( n -- ) { 0 f } member? [ win32-error ] when ;
: win32-error>0 ( n -- ) 0 > [ win32-error ] when ;
: win32-error<0 ( n -- ) 0 < [ win32-error ] when ;
: win32-error<>0 ( n -- ) zero? [ win32-error ] unless ;
: n>win32-error-check ( n -- )
dup ERROR_SUCCESS = [
drop
] [
dup n>win32-error-string windows-error
] if ;
: throw-win32-error ( -- * )
win32-error-string throw ;
: win32-error<>0 ( n -- ) [ win32-error ] unless-zero ;
: check-invalid-handle ( handle -- handle )
dup INVALID_HANDLE_VALUE = [ throw-win32-error ] when ;
dup INVALID_HANDLE_VALUE = [ win32-error ] when ;
CONSTANT: expected-io-errors
${
@ -758,11 +747,7 @@ CONSTANT: expected-io-errors
expected-io-errors member? ;
: expected-io-error ( error-code -- )
dup expected-io-error? [
drop
] [
throw-win32-error
] if ;
expected-io-error? [ win32-error ] unless ;
: io-error ( return-value -- )
{ 0 f } member? [ GetLastError expected-io-error ] when ;

8
basis/windows/registry/registry.factor
View File

@ -45,11 +45,7 @@ CONSTANT: registry-value-max-length 16384
f 0 KEY_ALL_ACCESS f create-key* drop ;
: close-key ( hkey -- )
RegCloseKey dup ERROR_SUCCESS = [
drop
] [
n>win32-error-string throw
] if ;
RegCloseKey n>win32-error-check ;
:: with-open-registry-key ( key subkey mode quot -- )
key subkey mode open-key :> hkey
@ -82,7 +78,7 @@ PRIVATE>
key value-name ptr1 lpType buffer
grow-buffer reg-query-value-ex
] [
ret n>win32-error-string throw
ret throw-windows-error
] if
] if ;

2
build.sh
View File

@ -98,7 +98,7 @@ set_downloader() {
fi
test_program_installed curl
if [[ $? -ne 0 ]] ; then
DOWNLOADER="curl -f -O"
DOWNLOADER="curl -L -f -O"
DOWNLOADER_NAME=curl
return
fi

5
core/alien/libraries/windows/windows.factor
View File

@ -1,8 +1,9 @@
USING: alien.libraries io.pathnames system windows.errors ;
USING: alien.libraries io.pathnames system windows.errors
windows.kernel32 ;
IN: alien.libraries.windows
M: windows >deployed-library-path
file-name ;
M: windows dlerror ( -- message )
win32-error-string ;
GetLastError n>win32-error-string ;

12
extra/tensors/tensor-slice/tensor-slice-tests.factor Normal file
View File

@ -0,0 +1,12 @@
USING: arrays sequences tensors.tensor-slice tools.test ;
IN: tensors.tensor-slice.tests
{ { 9 7 5 } } [ -1 -6 -2 10 <iota> <step-slice> >array ] unit-test
{ { 9 7 } } [ -1 -5 -2 10 <iota> <step-slice> >array ] unit-test
{ { 9 7 } } [ -1 -4 -2 10 <iota> <step-slice> >array ] unit-test
{ { 9 } } [ -1 -3 -2 10 <iota> <step-slice> >array ] unit-test
{ { } } [ -4 10 -2 10 <iota> <step-slice> >array ] unit-test
{ { 6 8 } } [ -4 15 2 10 <iota> <step-slice> >array ] unit-test
{ { 1 3 } } [ 1 4 2 10 <iota> <step-slice> >array ] unit-test
{ { 1 3 } } [ 1 5 2 10 <iota> <step-slice> >array ] unit-test
{ { 1 3 5 } } [ 1 6 2 10 <iota> <step-slice> >array ] unit-test

26
extra/tensors/tensor-slice/tensor-slice.factor Normal file
View File

@ -0,0 +1,26 @@
USING: accessors kernel locals math math.order sequences ;
IN: tensors.tensor-slice
TUPLE: step-slice < slice { step integer read-only } ;
:: <step-slice> ( from to step seq -- step-slice )
step zero? [ "can't be zero" throw ] when
seq length :> len
step 0 > [
from [ 0 ] unless*
to [ len ] unless*
] [
from [ len ] unless*
to [ 0 ] unless*
] if
[ dup 0 < [ len + ] when 0 len clamp ] bi@
! FIXME: make this work with steps
seq dup slice? [ collapse-slice ] when
step step-slice boa ;
M: step-slice virtual@
[ step>> * ] [ from>> + ] [ seq>> ] tri ;
M: step-slice length
[ to>> ] [ from>> - ] [ step>> ] tri
dup 0 < [ [ neg 0 max ] dip neg ] when /mod
zero? [ 1 + ] unless ;

136
extra/tensors/tensors-docs.factor Normal file
View File

@ -0,0 +1,136 @@
! Copyright (C) 2019 HMC Clinic.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays help.markup help.syntax math sequences ;
IN: tensors
ARTICLE: "tensors" "Tensors" "A " { $snippet "tensor" } " is a sequence "
"of floating point numbers "
"shaped into an n-dimensional matrix. It supports fast, scalable matrix "
"operations such as matrix multiplication and transposition as well as a "
"number of element-wise operations. Words for working with tensors are found "
"in the " { $vocab-link "tensors" } " vocabulary." $nl $nl
"Tensors can be created "
"by calling one of four constructors:"
{ $subsections zeros ones naturals arange }
"They can be converted to the corresponding N-dimensional array with"
{ $subsections tensor>array }
"The number of dimensions can be extracted with:"
{ $subsections dims }
"Additionally, tensors can be reshaped with:"
{ $subsections reshape flatten }
"Tensors can be combined element-wise with other tensors as well as numbers with:"
{ $subsections t+ t- t* t/ t% }
"Finally, tensors support the following matrix operations:"
{ $subsections matmul transpose } ;
ARTICLE: "tensor-operators" "Tensor Operators" "Info here" ;
HELP: tensor
{ $class-description "A sequence of floating-point numbers consisting of an "
{ $snippet "underlying" } " C-style array and a " { $snippet "shape" } "." } ;
HELP: shape-mismatch-error
{ $values { "shape1" sequence } { "shape2" sequence } }
{ $description "Throws a " { $link shape-mismatch-error } "." }
{ $error-description "Thrown by element-wise operations such as " { $link t+ }
", " { $link t- } ", " { $link t* } ", " { $link t/ } ", and " { $link t% }
" as well as matrix operations such as " { $link matmul } " if two tensors are "
"passed and they cannot be combined as desired because of a difference in the "
"shape." } ;
HELP: non-positive-shape-error
{ $values { "shape" sequence } }
{ $description "Throws a " { $link non-positive-shape-error } "." }
{ $error-description "Thrown by operations such as " { $link zeros } ", "
{ $link ones } ", " { $link naturals } ", and " { $link reshape }
", which allow users to directly set the shape of a " { $link tensor }
", when the shape has zero or negative values." } ;
HELP: zeros
{ $values { "shape" sequence } { "tensor" tensor } }
{ $description "Initializes a tensor with shape " { $snippet "shape" }
" containing all 0s." }
{ $errors "Throws a " { $link non-positive-shape-error } " if the given "
"shape has zero or negative values." } ;
HELP: ones
{ $values { "shape" sequence } { "tensor" tensor } }
{ $description "Initializes a tensor with shape " { $snippet "shape" }
" containing all 1s." }
{ $errors "Throws a " { $link non-positive-shape-error } " if the given "
"shape has zero or negative values." } ;
HELP: arange
{ $values { "a" number } { "b" number } { "step" number } { "tensor" tensor } }
{ $description "Initializes a one-dimensional tensor with values in a range from "
{ $snippet "a" } " to " { $snippet "b" } " (inclusive) with step-size " { $snippet "step" } "." } ;
HELP: naturals
{ $values { "shape" sequence } { "tensor" tensor } }
{ $description "Initializes a tensor with shape " { $snippet "shape" }
" containing a range of values from 0 to " { $snippet "shape product" } "." }
{ $errors "Throws a " { $link non-positive-shape-error } " if the given "
"shape has zero or negative values." } ;
HELP: reshape
{ $values { "tensor" tensor } { "shape" sequence } }
{ $description "Reshapes " { $snippet "tensor" } " to have shape "
{ $snippet "shape" } "." }
{ $errors "Throws a " { $link non-positive-shape-error } " if the given "
"shape has zero or negative values." } ;
HELP: flatten
{ $values { "tensor" tensor } }
{ $description "Reshapes " { $snippet "tensor" } " so that it is one-dimensional." } ;
HELP: dims
{ $values { "tensor" tensor } { "n" integer } }
{ $description "Returns the dimension of " { $snippet "tensor" } "." } ;
HELP: t+
{ $values { "x" { $or tensor number } } { "y" { $or tensor number } } { "tensor" tensor } }
{ $description "Element-wise addition. Intakes two tensors or a tensor and a number (in either order)." }
{ $errors "Throws a " { $link shape-mismatch-error } " if passed two tensors that are "
"not (or cannot be broadcast to be) the same shape." } ;
HELP: t-
{ $values { "x" { $or tensor number } } { "y" { $or tensor number } } { "tensor" tensor } }
{ $description "Element-wise subtraction. Intakes two tensors or a tensor and a number (in either order)." }
{ $errors "Throws a " { $link shape-mismatch-error } " if passed two tensors that are "
"not (or cannot be broadcast to be) the same shape." } ;
HELP: t*
{ $values { "x" { $or tensor number } } { "y" { $or tensor number } } { "tensor" tensor } }
{ $description "Element-wise multiplication. Intakes two tensors or a tensor and a number (in either order)." }
{ $errors "Throws a " { $link shape-mismatch-error } " if passed two tensors that are "
"not (or cannot be broadcast to be) the same shape." } ;
HELP: t/
{ $values { "x" { $or tensor number } } { "y" { $or tensor number } } { "tensor" tensor } }
{ $description "Element-wise division. Intakes two tensors or a tensor and a number (in either order)." }
{ $errors "Throws a " { $link shape-mismatch-error } " if passed two tensors that are "
"not (or cannot be broadcast to be) the same shape." } ;
HELP: t%
{ $values { "x" { $or tensor number } } { "y" { $or tensor number } } { "tensor" tensor } }
{ $description "Element-wise modulo operator. Intakes two tensors or a tensor and a number (in either order)." }
{ $errors "Throws a " { $link shape-mismatch-error } " if passed two tensors that are "
"not (or cannot be broadcast to be) the same shape." } ;
HELP: tensor>array
{ $values { "tensor" tensor } { "seq" array } }
{ $description "Returns " { $snippet "tensor" } " as an n-dimensional array." } ;
HELP: matmul
{ $values { "tensor1" tensor } { "tensor2" tensor } { "tensor3" tensor } }
{ $description "Performs n-dimensional matrix multiplication on two tensors, where " { $snippet "tensor1" }
" has shape " { $snippet "...xmxn" } " and " { $snippet "tensor1" } " has shape " { $snippet "...xnxp" } "." }
{ $errors "Throws a " { $link shape-mismatch-error } " if the bottom two "
"dimensions of the tensors passed do not take the form " { $snippet "mxn" }
" and " { $snippet "nxp" } " and/or the top dimensions do not match." } ;
HELP: transpose
{ $values { "tensor" tensor } { "tensor'" tensor } }
{ $description "Performs n-dimensional matrix transposition on " { $snippet "tens" } "." } ;
ABOUT: "tensors"

530
extra/tensors/tensors-tests.factor Normal file
View File

@ -0,0 +1,530 @@
! Copyright (C) 2019 HMC Clinic.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types kernel math math.order math.vectors
sequences specialized-arrays tensors tools.test ;
QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAY: c:float
IN: tensors.tests
! Test zeros
{ float-array{ 0.0 0.0 0.0 0.0 } } [
{ 4 } zeros vec>>
] unit-test
{ { 4 } } [
{ 4 } zeros shape>>
] unit-test
{ float-array{ 0.0 0.0 0.0 0.0 } } [
{ 2 2 } zeros vec>>
] unit-test
{ { 2 2 } } [
{ 2 2 } zeros shape>>
] unit-test
[
{ 0 5 } zeros
]
[ { 0 5 } \ non-positive-shape-error boa = ] must-fail-with
[
{ -3 5 } zeros
]
[ { -3 5 } \ non-positive-shape-error boa = ] must-fail-with
! Test ones
{ float-array{ 1.0 1.0 1.0 1.0 } } [
{ 4 } ones vec>>
] unit-test
{ { 4 } } [
{ 4 } ones shape>>
] unit-test
{ float-array{ 1.0 1.0 1.0 1.0 } } [
{ 2 2 } ones vec>>
] unit-test
{ { 2 2 } } [
{ 2 2 } ones shape>>
] unit-test
[
{ 0 5 } ones
]
[ { 0 5 } \ non-positive-shape-error boa = ] must-fail-with
[
{ -3 5 } ones
]
[ { -3 5 } \ non-positive-shape-error boa = ] must-fail-with
! Test arange
{ { 4 } float-array{ 0. 1. 2. 3. } } [
0 3 1 arange [ shape>> ] [ vec>> ] bi
] unit-test
{ { 4 } float-array{ 0. 2. 4. 6. } } [
0 7 2 arange [ shape>> ] [ vec>> ] bi
] unit-test
{ { 3 } float-array{ 1. 4. 7. } } [
1 9 3 arange [ shape>> ] [ vec>> ] bi
] unit-test
{ { 5 } float-array{ 1. 3. 5. 7. 9. } } [
1 9 2 arange [ shape>> ] [ vec>> ] bi
] unit-test
! Test naturals
{ float-array{ 0.0 1.0 2.0 3.0 } } [
{ 4 } naturals vec>>
] unit-test
{ { 4 } } [
{ 4 } naturals shape>>
] unit-test
{ float-array{ 0.0 1.0 2.0 3.0 } } [
{ 2 2 } naturals vec>>
] unit-test
{ { 2 2 } } [
{ 2 2 } naturals shape>>
] unit-test
[
{ 0 5 } naturals
]
[ { 0 5 } \ non-positive-shape-error boa = ] must-fail-with
[
{ -3 5 } naturals
]
[ { -3 5 } \ non-positive-shape-error boa = ] must-fail-with
! Test reshape
{ float-array{ 0.0 0.0 0.0 0.0 } } [
{ 4 } zeros { 2 2 } reshape vec>>
] unit-test
{ { 2 2 } } [
{ 4 } zeros { 2 2 } reshape shape>>
] unit-test
[
{ 2 2 } zeros { 2 3 } reshape
]
[ { 2 2 } { 2 3 } \ shape-mismatch-error boa = ] must-fail-with
[
{ 2 2 } zeros { -2 -2 } reshape
]
[ { -2 -2 } \ non-positive-shape-error boa = ] must-fail-with
! Test flatten
{ float-array{ 0.0 0.0 0.0 0.0 } } [
{ 2 2 } zeros flatten vec>>
] unit-test
{ { 4 } } [
{ 2 2 } zeros flatten shape>>
] unit-test
{ float-array{ 0.0 0.0 0.0 0.0 } } [
{ 4 } zeros flatten vec>>
] unit-test
{ { 4 } } [
{ 4 } zeros flatten shape>>
] unit-test
! Test dims
{ 1 } [
{ 3 } zeros dims
] unit-test
{ 2 } [
{ 2 2 } ones dims
] unit-test
{ 3 } [
{ 1 2 3 } zeros dims
] unit-test
! Test addition
{ float-array{ 1.0 2.0 3.0 4.0 } } [
{ 4 } naturals { 4 } ones t+ vec>>
] unit-test
{ { 4 } } [
{ 4 } naturals { 4 } ones t+ shape>>
] unit-test
{ float-array{ 1.0 2.0 3.0 4.0 } } [
{ 2 2 } naturals { 2 2 } ones t+ vec>>
] unit-test
{ { 2 2 } } [
{ 2 2 } naturals { 2 2 } ones t+ shape>>
] unit-test
[
{ 3 } naturals { 2 2 } ones t+ vec>>
]
[ { 3 } { 2 2 } \ shape-mismatch-error boa = ] must-fail-with
[
{ 4 } naturals { 2 2 } ones t+ vec>>
]
[ { 4 } { 2 2 } \ shape-mismatch-error boa = ] must-fail-with
! Test scalar addition
{ float-array{ 1.0 2.0 3.0 4.0 } } [
{ 4 } naturals 1 t+ vec>>
] unit-test
{ { 4 } } [
{ 4 } naturals 1 t+ shape>>
] unit-test
{ float-array{ 1.0 2.0 3.0 4.0 } } [
1 { 4 } naturals t+ vec>>
] unit-test
{ { 4 } } [
1 { 4 } naturals t+ shape>>
] unit-test
! Test subtraction
{ float-array{ -1.0 0.0 1.0 2.0 } } [
{ 4 } naturals { 4 } ones t- vec>>
] unit-test
{ { 4 } } [
{ 4 } naturals { 4 } ones t- shape>>
] unit-test
{ float-array{ -1.0 0.0 1.0 2.0 } } [
{ 2 2 } naturals { 2 2 } ones t- vec>>
] unit-test
{ { 2 2 } } [
{ 2 2 } naturals { 2 2 } ones t- shape>>
] unit-test
[
{ 3 } naturals { 2 2 } ones t- vec>>
]
[ { 3 } { 2 2 } \ shape-mismatch-error boa = ] must-fail-with
[
{ 4 } naturals { 2 2 } ones t- vec>>
]
[ { 4 } { 2 2 } \ shape-mismatch-error boa = ] must-fail-with
! Test scalar subtraction
{ float-array{ -1.0 0.0 1.0 2.0 } } [
{ 4 } naturals 1 t- vec>>
] unit-test
{ { 4 } } [
{ 4 } naturals 1 t- shape>>
] unit-test
{ float-array{ 1.0 0.0 -1.0 -2.0 } } [
1 { 4 } naturals t- vec>>
] unit-test
{ { 4 } } [
1 { 4 } naturals t- shape>>
] unit-test
! Test multiplication
{ float-array{ 0.0 1.0 4.0 9.0 } } [
{ 4 } naturals { 4 } naturals t* vec>>
] unit-test
{ { 4 } } [
{ 4 } naturals { 4 } naturals t* shape>>
] unit-test
{ float-array{ 0.0 1.0 4.0 9.0 } } [
{ 2 2 } naturals { 2 2 } naturals t* vec>>
] unit-test
{ { 2 2 } } [
{ 2 2 } naturals { 2 2 } naturals t* shape>>
] unit-test
[
{ 3 } naturals { 2 2 } naturals t* vec>>
]
[ { 3 } { 2 2 } \ shape-mismatch-error boa = ] must-fail-with
[
{ 4 } naturals { 2 2 } naturals t* vec>>
]
[ { 4 } { 2 2 } \ shape-mismatch-error boa = ] must-fail-with
! Test division
{ t } [
{ 4 } ones
{ 4 } naturals { 4 } ones t+
t/ vec>>
{ 1.0 0.5 0.33333 0.25 } v-
[ abs ] map
0 [ max ] reduce 0.0001 <
] unit-test
{ { 4 } } [
{ 4 } ones
{ 4 } naturals { 4 } ones t+
t/ shape>>
] unit-test
{ t } [
{ 2 2 } ones
{ 2 2 } naturals { 2 2 } ones t+
t/ vec>>
{ 1.0 0.5 0.33333 0.25 } v-
[ abs ] map
0 [ max ] reduce 0.0001 <
] unit-test
{ { 2 2 } } [
{ 2 2 } ones
{ 2 2 } naturals { 2 2 } ones t+
t/ shape>>
] unit-test
[
{ 3 } ones
{ 2 2 } naturals { 2 2 } ones t+
t/ vec>>
]
[ { 3 } { 2 2 } \ shape-mismatch-error boa = ] must-fail-with
[
{ 4 } ones
{ 2 2 } naturals { 2 2 } ones t+
t/ vec>>
]
[ { 4 } { 2 2 } \ shape-mismatch-error boa = ] must-fail-with
! Test scalar division
{ t } [
1
{ 4 } naturals { 4 } ones t+
t/ vec>>
{ 1.0 0.5 0.33333 0.25 } v-
[ abs ] map
0 [ max ] reduce 0.0001 <
] unit-test
{ { 4 } } [
1
{ 4 } naturals { 4 } ones t+
t/ shape>>
] unit-test
{ float-array{ 0.0 0.5 1.0 1.5 } } [
{ 4 } naturals 2 t/ vec>>
] unit-test
{ { 4 } } [
{ 4 } naturals 2 t/ shape>>
] unit-test
! Test scalar multiplication
{ float-array{ 0.0 3.0 6.0 9.0 } } [
{ 4 } naturals 3 t* vec>>
] unit-test
{ { 4 } } [
{ 4 } naturals 3 t* shape>>
] unit-test
{ float-array{ 0.0 3.0 6.0 9.0 } } [
{ 2 2 } naturals 3 t* vec>>
] unit-test
{ { 2 2 } } [
{ 2 2 } naturals 3 t* shape>>
] unit-test
{ float-array{ 0.0 3.0 6.0 9.0 } } [
3 { 4 } naturals t* vec>>
] unit-test
{ { 4 } } [
3 { 4 } naturals t* shape>>
] unit-test
{ float-array{ 0.0 3.0 6.0 9.0 } } [
3 { 2 2 } naturals t* vec>>
] unit-test
{ { 2 2 } } [
3 { 2 2 } naturals t* shape>>
] unit-test
! test mod
{ float-array{ 0.0 1.0 2.0 0.0 1.0 } } [
{ 5 } naturals
{ 5 } ones 3 t*
t% vec>>
] unit-test
{ { 5 } } [
{ 5 } naturals
{ 5 } ones 3 t*
t% shape>>
] unit-test
{ float-array{ 0.0 1.0 2.0 0.0 1.0 2.0 } } [
{ 2 3 } naturals
{ 2 3 } ones 3 t*
t% vec>>
] unit-test
{ { 2 3 } } [
{ 2 3 } naturals
{ 2 3 } ones 3 t*
t% shape>>
] unit-test
[
{ 4 } naturals
{ 2 3 } ones 3 t*
t% vec>>
]
[ { 4 } { 2 3 } \ shape-mismatch-error boa = ] must-fail-with
[
{ 4 } naturals
{ 2 3 } ones 3 t*
t% vec>>
]
[ { 4 } { 2 3 } \ shape-mismatch-error boa = ] must-fail-with
! Test scalar mod
{ float-array{ 0.0 1.0 2.0 0.0 1.0 } } [
{ 5 } naturals
3
t% vec>>
] unit-test
{ { 5 } } [
{ 5 } naturals
3
t% shape>>
] unit-test
{ float-array{ 0.0 1.0 2.0 0.0 1.0 2.0 } } [
{ 2 3 } naturals
3
t% vec>>
] unit-test
{ { 2 3 } } [
{ 2 3 } naturals
3
t% shape>>
] unit-test
{ float-array{ 0.0 1.0 0.0 3.0 3.0 } } [
3
{ 5 } naturals 1 t+
t% vec>>
] unit-test
{ { 5 } } [
{ 5 } naturals
3
t% shape>>
] unit-test
{ float-array{ 0.0 1.0 0.0 3.0 3.0 3.0 } } [
3
{ 2 3 } naturals 1 t+
t% vec>>
] unit-test
{ { 2 3 } } [
{ 2 3 } naturals
3
t% shape>>
] unit-test
! test tensor>array
{ { 0.0 0.0 } } [
{ 2 } zeros tensor>array
] unit-test
{ { { 0.0 0.0 } { 0.0 0.0 } } } [
{ 2 2 } zeros tensor>array
] unit-test
{ { { { 1.0 1.0 } { 1.0 1.0 } { 1.0 1.0 } }
{ { 1.0 1.0 } { 1.0 1.0 } { 1.0 1.0 } } } } [
{ 2 3 2 } ones tensor>array
] unit-test
! test matmul
{ float-array{ 70.0 76.0 82.0 88.0 94.0 190.0 212.0 234.0
256.0 278.0 310.0 348.0 386.0 424.0 462.0 } } [
{ 3 4 } naturals { 4 5 } naturals matmul vec>>
] unit-test
{ { 3 5 } } [
{ 3 4 } naturals { 4 5 } naturals matmul shape>>
] unit-test
{ float-array{ 70.0 76.0 82.0 88.0 94.0 190.0 212.0 234.0 256.0
278.0 310.0 348.0 386.0 424.0 462.0 1510.0 1564.0
1618.0 1672.0 1726.0 1950.0 2020.0 2090.0 2160.0
2230.0 2390.0 2476.0 2562.0 2648.0 2734.0 } } [
{ 2 3 4 } naturals { 2 4 5 } naturals matmul vec>>
] unit-test
{ { 2 3 5 } } [
{ 2 3 4 } naturals { 2 4 5 } naturals matmul shape>>
] unit-test
{ float-array{ 70.0 76.0 82.0 88.0 94.0 190.0 212.0 234.0 256.0
278.0 310.0 348.0 386.0 424.0 462.0 1510.0 1564.0 1618.0
1672.0 1726.0 1950.0 2020.0 2090.0 2160.0 2230.0 2390.0 2476.0
2562.0 2648.0 2734.0 4870.0 4972.0 5074.0 5176.0 5278.0 5630.0
5748.0 5866.0 5984.0 6102.0 6390.0 6524.0 6658.0 6792.0 6926.0
10150.0 10300.0 10450.0 10600.0 10750.0 11230.0 11396.0 11562.0
11728.0 11894.0 12310.0 12492.0 12674.0 12856.0 13038.0 } } [
{ 2 2 3 4 } naturals { 2 2 4 5 } naturals matmul vec>>
] unit-test
{ { 2 2 3 5 } } [
{ 2 2 3 4 } naturals { 2 2 4 5 } naturals matmul shape>>
] unit-test
! test transpose
{ float-array{ 0.0 2.0 1.0 3.0 } } [
{ 2 2 } naturals transpose vec>>
] unit-test
{ float-array{ 0.0 12.0 4.0 16.0 8.0 20.0 1.0
13.0 5.0 17.0 9.0 21.0 2.0 14.0 6.0 18.0
10.0 22.0 3.0 15.0 7.0 19.0 11.0 23.0 } } [
{ 2 3 4 } naturals transpose vec>>
] unit-test
{ { 4 3 2 } } [
{ 2 3 4 } naturals transpose shape>>
] unit-test
{ t } [
{ 2 3 4 5 6 } naturals dup transpose transpose =
] unit-test

245
extra/tensors/tensors.factor Normal file
View File

@ -0,0 +1,245 @@
! 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 ;
QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAY: c:float
IN: tensors
! Tensor class definition
TUPLE: tensor
{ shape array }
{ vec float-array } ;
! Errors
ERROR: non-positive-shape-error shape ;
ERROR: shape-mismatch-error shape1 shape2 ;
<PRIVATE
! Check that the shape has only positive values
: check-shape ( shape -- shape )
dup [ 1 < ] map-find drop [ non-positive-shape-error ] when ;
! Construct a tensor of zeros
: <tensor> ( shape seq -- tensor )
tensor boa ;
: >float-array ( seq -- float-array )
c:float >c-array ;
: repetition ( shape const -- tensor )
[ check-shape dup product ] dip <repetition>
>float-array <tensor> ;
PRIVATE>
! Construct a tensor of zeros
: zeros ( shape -- tensor )
0 repetition ;
! Construct a tensor of ones
: ones ( shape -- tensor )
1 repetition ;
! Construct a one-dimensional tensor with values start, start+step,
! ..., stop (inclusive)
: arange ( a b step -- tensor )
<range> [ length 1array ] keep >float-array <tensor> ;
! Construct a tensors with vec { 0 1 2 ... } and reshape to the desired shape
: naturals ( shape -- tensor )
check-shape [ ] [ product [0,b) >float-array ] bi <tensor> ;
<PRIVATE
: check-reshape ( shape1 shape2 -- shape1 shape2 )
2dup [ product ] bi@ = [ shape-mismatch-error ] unless ;
PRIVATE>
! Reshape the tensor to conform to the new shape
: reshape ( tensor shape -- tensor )
[ dup shape>> ] [ check-shape ] bi* check-reshape nip >>shape ;
! Flatten the tensor so that it is only one-dimensional
: flatten ( tensor -- tensor )
dup shape>>
product { } 1sequence >>shape ;
! outputs the number of dimensions of a tensor
: dims ( tensor -- n )
shape>> length ;
! Turn into Factor ND array form
! Source: shaped-array>array
TYPED: tensor>array ( tensor: tensor -- seq: array )
[ vec>> >array ] [ shape>> ] bi
[ rest-slice reverse [ group ] each ] unless-empty ;
<PRIVATE
: check-bop-shape ( shape1 shape2 -- shape )
2dup = [ shape-mismatch-error ] unless drop ;
! Apply the binary operator bop to combine the tensors
TYPED:: t-bop ( tensor1: tensor tensor2: tensor quot: ( x y -- z ) -- tensor: tensor )
tensor1 shape>> tensor2 shape>> check-bop-shape
tensor1 vec>> tensor2 vec>> quot 2map <tensor> ; inline
! Apply the operation to the tensor
TYPED:: t-uop ( tensor: tensor quot: ( x -- y ) -- tensor: tensor )
tensor vec>> quot map [ tensor shape>> ] dip <tensor> ; inline
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 ;
! 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 ;
! 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 ;
! 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 ;
! 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 ;
<PRIVATE
! Check that the tensor has an acceptable shape for matrix multiplication
: check-matmul-shape ( tensor1 tensor2 -- )
[let [ shape>> ] bi@ :> shape2 :> shape1
! Check that the matrices can be multiplied
shape1 last shape2 [ length 2 - ] keep nth =
! Check that the other dimensions are equal
shape1 2 head* shape2 2 head* = and
! If either is false, raise an error
[ shape1 shape2 shape-mismatch-error ] unless ] ;
! Slice out a row from the array
: row ( arr n i p -- slice )
! Compute the starting index
/ truncate dupd *
! Compute the ending index
swap over +
! Take a slice
rot <slice> ;
! Perform matrix multiplication muliplying an
! mxn matrix with a nxp matrix
TYPED:: 2d-matmul ( vec1: slice vec2: slice res: slice n: number p: number -- )
! 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 <step-slice> ] bi
! Take the dot product
[ * ] [ + ] 2map-reduce
]
map! drop ;
PRIVATE>
! Perform matrix multiplication muliplying an
! ...xmxn matrix with a ...xnxp matrix
TYPED:: matmul ( tensor1: tensor tensor2: tensor -- tensor3: tensor )
! First check the shape
tensor1 tensor2 check-matmul-shape
! Now save all of the sizes
tensor1 shape>> unclip-last-slice :> n
unclip-last-slice :> m :> top-shape
tensor2 shape>> last :> p
top-shape product :> rest
! Now create the new tensor with { 0 ... m*p-1 } repeating
top-shape { m p } append naturals m p * t% :> tensor3
! Now update the tensor3 to contain the multiplied matricies
rest [0,b)
[
:> i
! First make vec1
m n * i * dup m n * + tensor1 vec>> <slice>
! Now make vec2
n p * i * dup n p * + tensor2 vec>> <slice>
! Now make the resulting vector
m p * i * dup m p * + tensor3 vec>> <slice>
! Push n and p and multiply the clices
n p 2d-matmul
0
] map drop
tensor3 ;
<PRIVATE
! helper for transpose: gets the turns a shape into a list of things
! by which to multiply indices to get a full index
: ind-mults ( shape -- seq )
rest-slice <reversed> cum-product { 1 } prepend ;
! 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 ;
PRIVATE>
! Transpose an n-dimensional tensor
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
! find index in original tensor
newshape mults trans-index old-mults [ * ] 2map sum >fixnum
! get that index in original tensor
tensor vec>> nth
] map! >>vec ;

2
removed/talks/tc-lisp-talk/tc-lisp-talk.factor
View File

@ -454,7 +454,7 @@ end: return;
\"TIME_ZONE_INFORMATION\" <c-object>
dup GetTimeZoneInformation {
{ TIME_ZONE_ID_INVALID [
win32-error-string throw
win32-error
] }
{ TIME_ZONE_ID_STANDARD [
TIME_ZONE_INFORMATION-Bias