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

clean up sequences and matrices

cvs
Slava Pestov 2005-07-30 06:08:59 +00:00
parent 33e2ee1c96
commit d7dfeea419
14 changed files with 126 additions and 302 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
library/bootstrap/boot-stage1.factor
View File

@ -32,6 +32,7 @@ parser prettyprint sequences io vectors words ;
"/library/collections/growable.factor"
"/library/collections/cons.factor"
"/library/collections/vectors.factor"
"/library/collections/virtual-sequences.factor"
"/library/collections/sequences-epilogue.factor"
"/library/collections/strings.factor"
"/library/collections/sbuf.factor"

23
library/collections/sequences-epilogue.factor
View File

@ -4,19 +4,6 @@ IN: sequences
USING: generic kernel kernel-internals lists math strings
vectors ;
! A reversal of an underlying sequence.
TUPLE: reversed ;
C: reversed [ set-delegate ] keep ;
: reversed@ delegate [ length swap - 1 - ] keep ;
M: reversed nth ( n seq -- elt ) reversed@ nth ;
M: reversed set-nth ( elt n seq -- ) reversed@ set-nth ;
M: reversed thaw ( seq -- seq ) delegate reverse ;
! A repeated sequence is the same element n times.
TUPLE: repeated length object ;
M: repeated length repeated-length ;
M: repeated nth nip repeated-object ;
! Combinators
M: object each ( seq quot -- )
swap dup length [
@ -102,8 +89,6 @@ M: object find ( seq quot -- i elt )
[ 2drop t ] [ >r [ first ] keep r> all-with? ] ifte ; inline
! Operations
M: object thaw clone ;
M: object like drop ;
M: object empty? ( seq -- ? ) length 0 = ;
@ -217,12 +202,10 @@ M: object reverse ( seq -- seq ) [ <reversed> ] keep like ;
#! lexicographically.
lexi 0 > ;
: seq-transpose ( seq -- seq )
: flip ( seq -- seq )
#! An example illustrates this word best:
#! { { 1 2 3 } { 4 5 6 } } ==> { { 1 2 } { 3 4 } { 5 6 } }
dup empty? [
dup first length [ swap [ nth ] map-with ] map-with
] unless ;
<flipped> [ dup like ] map ;
: max-length ( seq -- n )
#! Longest sequence length in a sequence of sequences.
@ -238,6 +221,8 @@ M: object reverse ( seq -- seq ) [ <reversed> ] keep like ;
: copy-into ( to from -- )
dup length [ pick set-nth ] 2each drop ;
M: flipped set-nth ( elt n flipped -- ) nth swap copy-into ;
IN: kernel
: depth ( -- n )

41
library/collections/slicing.factor
View File

@ -4,46 +4,6 @@ IN: sequences
USING: generic kernel kernel-internals lists math namespaces
strings vectors ;
! A range of integers.
TUPLE: range from to step ;
C: range ( from to -- range )
>r 2dup > -1 1 ? r>
[ set-range-step ] keep
[ set-range-to ] keep
[ set-range-from ] keep ;
M: range length ( range -- n )
dup range-to swap range-from - abs ;
M: range nth ( n range -- n )
[ range-step * ] keep range-from + ;
M: range like ( seq range -- range )
drop >vector ;
M: range thaw ( range -- seq )
>vector ;
! A slice of another sequence.
TUPLE: slice seq ;
C: slice ( from to seq -- )
[ set-slice-seq ] keep
[ >r <range> r> set-delegate ] keep ;
M: slice nth ( n slice -- obj )
[ delegate nth ] keep slice-seq nth ;
M: slice set-nth ( obj n slice -- )
[ delegate nth ] keep slice-seq set-nth ;
M: slice like ( seq slice -- seq )
slice-seq like ;
M: slice thaw ( slice -- seq )
>vector ;
: head-slice ( n seq -- slice )
0 -rot <slice> ;
@ -115,6 +75,7 @@ M: object tail ( index seq -- seq )
[ head ] 2keep >r 1 + r> tail ;
: group-advance subseq , >r tuck + swap r> ;
: group-finish nip dup length swap subseq , ;
: (group) ( start n seq -- )

6
library/collections/vectors-epilogue.factor
View File

@ -10,16 +10,16 @@ IN: vectors
: >vector ( list -- vector )
dup length <vector> [ swap nappend ] keep ;
M: repeated thaw >vector ;
M: object thaw >vector ;
M: vector clone ( vector -- vector ) >vector ;
: zero-vector ( n -- vector ) 0 <repeated> >vector ;
M: general-list thaw >vector ;
M: general-list like drop >list ;
M: range like drop >vector ;
M: vector like drop >vector ;
: (1vector) [ push ] keep ; inline

2
library/inference/branches.factor
View File

@ -18,7 +18,7 @@ namespaces prettyprint sequences strings vectors words ;
: unify-stacks ( seq -- stack )
#! Replace differing literals in stacks with unknown
#! results.
unify-lengths seq-transpose [ unify-results ] map ;
unify-lengths flip [ unify-results ] map ;
: balanced? ( in out -- ? )
[ swap length swap length - ] 2map [ = ] every? ;

6
library/inference/class-infer.factor
View File

@ -14,6 +14,9 @@ SYMBOL: value-classes
! Current value --> literal mapping
SYMBOL: value-literals
! Maps ties to ties
SYMBOL: ties
GENERIC: apply-tie ( tie -- )
M: f apply-tie ( f -- ) drop ;
@ -39,9 +42,6 @@ M: literal-tie apply-tie ( tie -- )
dup literal-tie-literal swap literal-tie-value
set-value-literal ;
! Maps ties to ties
SYMBOL: ties
GENERIC: infer-classes* ( node -- )
M: node infer-classes* ( node -- ) drop ;

6
library/inference/inference.factor
View File

@ -77,11 +77,7 @@ M: object apply-object apply-literal ;
: infer-quot ( quot -- )
#! Recursive calls to this word are made for nested
#! quotations.
active? [
[ unswons apply-object infer-quot ] when*
] [
drop
] ifte ;
[ active? [ apply-object t ] [ drop f ] ifte ] all? drop ;
: infer-quot-value ( rstate quot -- )
recursive-state get >r

2
library/inference/optimizer.factor
View File

@ -192,7 +192,7 @@ SYMBOL: branch-returns
: branch-values ( branches -- )
[ last-node node-in-d ] map
unify-lengths seq-transpose branch-returns set ;
unify-lengths flip branch-returns set ;
: can-kill-branches? ( literal node -- ? )
#! Check if the literal appears in either branch. This

182
library/math/matrices.factor
View File

@ -4,29 +4,28 @@ IN: matrices
USING: errors generic kernel lists math namespaces sequences
vectors ;
! Vector operations
! Vectors
: vneg ( v -- v ) [ neg ] map ;
: n*v ( n vec -- vec ) [ * ] map-with ;
: v*n ( vec n -- vec ) swap n*v ;
: n/v ( n vec -- vec ) [ / ] map-with ;
: v/n ( vec n -- vec ) swap [ swap / ] map-with ;
: n*v ( n v -- v ) [ * ] map-with ;
: v*n ( v n -- v ) swap n*v ;
: n/v ( n v -- v ) [ / ] map-with ;
: v/n ( v n -- v ) swap [ swap / ] map-with ;
: v+ ( v v -- v ) [ + ] 2map ;
: v- ( v v -- v ) [ - ] 2map ;
: v* ( v v -- v ) [ * ] 2map ;
: v/ ( v v -- v ) [ / ] 2map ;
: v+ ( v v -- v ) [ + ] 2map ;
: v- ( v v -- v ) [ - ] 2map ;
: v* ( v v -- v ) [ * ] 2map ;
: v/ ( v v -- v ) [ / ] 2map ;
: vmax ( v v -- v ) [ max ] 2map ;
: vmin ( v v -- v ) [ min ] 2map ;
: vand ( v v -- v ) [ and ] 2map ;
: vor ( v v -- v ) [ or ] 2map ;
: v< ( v v -- v ) [ < ] 2map ;
: v<= ( v v -- v ) [ <= ] 2map ;
: v> ( v v -- v ) [ > ] 2map ;
: v>= ( v v -- v ) [ >= ] 2map ;
: vor ( v v -- v ) [ or ] 2map ;
: v< ( v v -- v ) [ < ] 2map ;
: v<= ( v v -- v ) [ <= ] 2map ;
: v> ( v v -- v ) [ > ] 2map ;
: v>= ( v v -- v ) [ >= ] 2map ;
: vbetween? ( v from to -- v )
>r over >r v>= r> r> v<= vand ;
: vbetween? ( v from to -- v ) >r over >r v>= r> r> v<= vand ;
: sum ( v -- n ) 0 [ + ] reduce ;
: product ( v -- n ) 1 [ * ] reduce ;
@ -52,136 +51,41 @@ vectors ;
: cross ( { x1 y1 z1 } { x2 y2 z2 } -- { z1 z2 z3 } )
#! Cross product of two 3-dimensional vectors.
3 <vector>
[ >r 2dup 1 2 cross-minor 0 r> set-nth ] keep
[ >r 2dup 2 0 cross-minor 1 r> set-nth ] keep
[ >r 2dup 0 1 cross-minor 2 r> set-nth ] keep
2nip ;
[ 1 2 cross-minor ] 2keep
[ 2 0 cross-minor ] 2keep
0 1 cross-minor 3vector ;
! Matrices
! The major dimension is the number of elements per row.
TUPLE: matrix rows cols sequence ;
: zero-matrix ( m n -- matrix )
swap [ drop zero-vector ] map-with ;
: >matrix<
[ matrix-rows ] keep
[ matrix-cols ] keep
matrix-sequence ;
M: matrix clone ( matrix -- matrix )
clone-tuple
dup matrix-sequence clone over set-matrix-sequence ;
: matrix@ ( row col matrix -- n ) matrix-cols rot * + ;
: matrix-get ( row col matrix -- elt )
[ matrix@ ] keep matrix-sequence nth ;
: matrix-set ( elt row col matrix -- )
[ matrix@ ] keep matrix-sequence set-nth ;
: <zero-matrix> ( rows cols -- matrix )
2dup * zero-vector <matrix> ;
: <row-matrix> ( vector -- matrix )
#! Turn a vector into a matrix of one row.
[ 1 swap length ] keep <matrix> ;
: <col-matrix> ( vector -- matrix )
#! Turn a vector into a matrix of one column.
[ length 1 ] keep <matrix> ;
: make-matrix ( rows cols quot -- matrix | quot: i j -- elt )
-rot [
[ [ [ rot call , ] 3keep ] 2repeat ] make-vector nip
] 2keep rot <matrix> ; inline
: <identity-matrix> ( n -- matrix )
: identity-matrix ( n -- matrix )
#! Make a nxn identity matrix.
dup [ = 1 0 ? ] make-matrix ;
: transpose ( matrix -- matrix )
dup matrix-cols over matrix-rows [
swap pick matrix-get
] make-matrix nip ;
! Sequence of elements in a row of a matrix.
TUPLE: row index matrix ;
: >row< dup row-index swap row-matrix ;
M: row length row-matrix matrix-cols ;
M: row nth ( n row -- n ) >row< swapd matrix-get ;
M: row thaw >vector ;
! Sequence of elements in a column of a matrix.
TUPLE: col index matrix ;
: >col< dup col-index swap col-matrix ;
M: col length col-matrix matrix-rows ;
M: col nth ( n column -- n ) >col< matrix-get ;
M: col thaw >vector ;
! Sequence of elements on a diagonal. Positive indices are above
! and negative indices are below the main diagonal. Only for
! square matrices.
TUPLE: diagonal index matrix ;
: >diagonal< dup diagonal-index swap diagonal-matrix ;
M: diagonal length ( daig -- n )
>diagonal< matrix-rows swap abs - ;
M: diagonal nth ( n diag -- n )
>diagonal< >r [ neg 0 max over + ] keep 0 max rot + r>
matrix-get ;
: trace ( matrix -- tr )
#! Product of diagonal elements.
0 swap <diagonal> product ;
: +check ( matrix matrix -- )
#! Check if the two matrices have dimensions compatible
#! for being added or subtracted.
over matrix-rows over matrix-rows = >r
swap matrix-cols swap matrix-cols = r> and [
"Matrix dimensions do not equal" throw
] unless ;
: element-wise ( m m -- rows cols v v )
2dup +check >r >matrix< r> matrix-sequence ;
dup zero-matrix 0 over <diagonal> [ drop 1 ] nmap ;
! Matrix operations
: m+ ( m m -- m ) element-wise v+ <matrix> ;
: m- ( m m -- m ) element-wise v- <matrix> ;
: mneg ( m -- m ) [ vneg ] map ;
: m* ( m m -- m )
#! Multiply two matrices element-wise. This is NOT matrix
#! multiplication in the usual mathematical sense. For that,
#! see the m. word.
element-wise v* <matrix> ;
: n*m ( n m -- m ) [ n*v ] map-with ;
: m*n ( m n -- m ) swap n*m ;
: n/m ( n m -- m ) [ n/v ] map-with ;
: m/n ( m n -- m ) swap [ swap v/n ] map-with ;
: *check ( matrix matrix -- )
swap matrix-cols swap matrix-rows = [
"Matrix dimensions inappropriate for composition" throw
] unless ;
: m+ ( m m -- m ) [ v+ ] 2map ;
: m- ( m m -- m ) [ v- ] 2map ;
: m* ( m m -- m ) [ v* ] 2map ;
: m/ ( m m -- m ) [ v/ ] 2map ;
: mmax ( m m -- m ) [ vmax ] 2map ;
: mmin ( m m -- m ) [ vmin ] 2map ;
: mand ( m m -- m ) [ vand ] 2map ;
: mor ( m m -- m ) [ vor ] 2map ;
: m< ( m m -- m ) [ v< ] 2map ;
: m<= ( m m -- m ) [ v<= ] 2map ;
: m> ( m m -- m ) [ v> ] 2map ;
: m>= ( m m -- m ) [ v>= ] 2map ;
: *dimensions ( m m -- rows cols )
swap matrix-rows swap matrix-cols ;
: v.m ( v m -- v ) <flipped> [ v. ] map-with ;
: m.v ( m v -- v ) swap [ v. ] map-with ;
: m. ( m m -- m ) >r <flipped> r> [ m.v ] map-with ;
: m. ( m1 m2 -- m )
#! Composition of two matrices.
2dup *check 2dup *dimensions [
( m1 m2 row col -- m1 m2 )
pick <col> >r pick <row> r> v.
] make-matrix 2nip ;
: n*m ( n m -- m )
#! Multiply a matrix by a scalar.
>matrix< >r rot r> n*v <matrix> ;
: m.v ( m v -- v )
#! Multiply a matrix by a column vector.
<col-matrix> m. matrix-sequence ;
: v.m ( v m -- v )
#! Multiply a row vector by a matrix.
>r <row-matrix> r> m. matrix-sequence ;
: row-list ( matrix -- list )
#! A list of lists, where each sublist is a row of the
#! matrix.
dup matrix-rows [ swap <row> >vector ] map-with >list ;
: trace ( matrix -- tr ) 0 swap <diagonal> product ;

13
library/syntax/math.factor
View File

@ -2,12 +2,11 @@
! See http://factor.sf.net/license.txt for BSD license.
IN: !syntax
USING: kernel lists math matrices parser sequences syntax
vectors ;
USING: kernel lists math parser sequences syntax vectors ;
! Complex numbers
: #{ f ; parsing
: }# 2unlist swap rect> swons ; parsing
: }# dup first swap second rect> swons ; parsing
! Reading integers in other bases
: (BASE) ( base -- )
@ -18,11 +17,3 @@ vectors ;
: DEC: 10 (BASE) ; parsing
: OCT: 8 (BASE) ; parsing
: BIN: 2 (BASE) ; parsing
! Matrices
: M{ f ; parsing
: }M
reverse
[ dup length swap car length ] keep
concat >vector <matrix> swons ; parsing

11
library/syntax/prettyprint.factor
View File

@ -2,7 +2,7 @@
! See http://factor.sf.net/license.txt for BSD license.
IN: prettyprint
USING: alien errors generic hashtables io kernel lists math
matrices memory namespaces parser presentation sequences strings
memory namespaces parser presentation sequences strings
styles unparser vectors words ;
SYMBOL: prettyprint-limit
@ -120,15 +120,6 @@ M: tuple prettyprint* ( indent tuple -- indent )
M: alien prettyprint* ( alien -- str )
\ ALIEN: unparse. bl alien-address unparse write ;
: matrix-rows. ( indent list -- indent )
uncons >r [ one-line on prettyprint* ] with-scope r>
[ over ?prettyprint-newline matrix-rows. ] when* ;
M: matrix prettyprint* ( indent obj -- indent )
\ M{ unparse. bl >r 3 + r>
row-list matrix-rows.
bl \ }M unparse. 3 - ;
: prettyprint ( obj -- )
[
recursion-check off

126
library/test/math/matrices.factor
View File

@ -2,57 +2,48 @@ IN: temporary
USING: kernel lists math matrices namespaces sequences test
vectors ;
[ [ { 1 4 } { 2 5 } { 3 6 } ] ]
[ M{ { 1 4 } { 2 5 } { 3 6 } }M row-list ] unit-test
[
M{ { 0 } { 0 } { 0 } }M
{ { 0 } { 0 } { 0 } }
] [
3 1 <zero-matrix>
3 1 zero-matrix
] unit-test
[
M{ { 1 } { 2 } { 3 } }M
] [
{ 1 2 3 } <col-matrix>
] unit-test
[
M{ { 1 0 0 }
{ { 1 0 0 }
{ 0 1 0 }
{ 0 0 1 } }M
{ 0 0 1 } }
] [
3 <identity-matrix>
3 identity-matrix
] unit-test
[
M{ { 1 0 4 }
{ { 1 0 4 }
{ 0 7 0 }
{ 6 0 3 } }M
{ 6 0 3 } }
] [
M{ { 1 0 0 }
{ { 1 0 0 }
{ 0 2 0 }
{ 0 0 3 } }M
{ 0 0 3 } }
M{ { 0 0 4 }
{ { 0 0 4 }
{ 0 5 0 }
{ 6 0 0 } }M
{ 6 0 0 } }
m+
] unit-test
[
M{ { 1 0 4 }
{ { 1 0 4 }
{ 0 7 0 }
{ 6 0 3 } }M
{ 6 0 3 } }
] [
M{ { 1 0 0 }
{ { 1 0 0 }
{ 0 2 0 }
{ 0 0 3 } }M
{ 0 0 3 } }
M{ { 0 0 -4 }
{ { 0 0 -4 }
{ 0 -5 0 }
{ -6 0 0 } }M
{ -6 0 0 } }
m-
] unit-test
@ -63,29 +54,11 @@ vectors ;
10 { 1 2 3 } n*v
] unit-test
[
M{ { 6 } }M
] [
M{ { 3 } }M M{ { 2 } }M m.
] unit-test
[
M{ { 11 } }M
] [
M{ { 1 3 } }M M{ { 5 } { 2 } }M m.
] unit-test
[
[ [[ 0 0 ]] [[ 1 0 ]] ]
] [
[ 2 1 [ 2dup cons , ] 2repeat ] make-list
] unit-test
[
{ 3 4 }
] [
M{ { 1 0 }
{ 0 1 } }M
{ { 1 0 }
{ 0 1 } }
{ 3 4 }
@ -95,46 +68,41 @@ vectors ;
[
{ 4 3 }
] [
M{ { 0 1 }
{ 1 0 } }M
{ { 0 1 }
{ 1 0 } }
{ 3 4 }
m.v
] unit-test
[
{ { 8 2 3 } { 9 5 6 } }
] [
{ { 1 2 3 } { 4 5 6 } } clone
dup <flipped> { 8 9 } 0 rot set-nth
] 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
[ M{ { 1 2 } { 3 4 } { 5 6 } }M ]
[ M{ { 1 2 } { 3 4 } { 5 6 } }M transpose transpose ]
[ { { 1 2 } { 3 4 } { 5 6 } } ]
[ { { 1 2 } { 3 4 } { 5 6 } } flip flip ]
unit-test
[ M{ { 1 3 5 } { 2 4 6 } }M ]
[ M{ { 1 3 5 } { 2 4 6 } }M transpose transpose ]
[ { { 1 3 5 } { 2 4 6 } } ]
[ { { 1 3 5 } { 2 4 6 } } flip flip ]
unit-test
[ M{ { 1 3 5 } { 2 4 6 } }M ]
[ M{ { 1 2 } { 3 4 } { 5 6 } }M transpose ]
[ { { 1 3 5 } { 2 4 6 } } ]
[ { { 1 2 } { 3 4 } { 5 6 } } flip ]
unit-test
[
M{ { 28 } }M
] [
M{ { 2 4 6 } }M
M{ { 1 }
{ 2 }
{ 3 } }M
m.
] unit-test
[
{ { 7 } { 4 8 } { 1 5 9 } { 2 6 } { 3 } }
] [
M{ { 1 2 3 } { 4 5 6 } { 7 8 9 } }M
{ { 1 2 3 } { 4 5 6 } { 7 8 9 } }
5 [ 2 - swap <diagonal> >vector ] map-with
] unit-test
@ -145,3 +113,27 @@ unit-test
[ { t f t } ]
[ { 1 10 3 } { -1 -2 -3 } { 4 5 6 } vbetween? ]
unit-test
[
{ { 6 } }
] [
{ { 3 } } { { 2 } } m.
] unit-test
[
{ { 11 } }
] [
{ { 1 3 } } { { 5 } { 2 } } m.
] unit-test
[
{ { 28 } }
] [
{ { 2 4 6 } }
{ { 1 }
{ 2 }
{ 3 } }
m.
] unit-test

7
library/test/sequences.factor
View File

@ -68,6 +68,9 @@ unit-test
[ { 1 2 } ] [ 1 2 2vector ] unit-test
[ { 1 2 3 } ] [ 1 2 3 3vector ] unit-test
[ { } ] [ { } seq-transpose ] unit-test
[ { } ] [ { } flip ] unit-test
[ [ 1 2 3 ] [ 3 4 5 ] [ 6 ] 3vector [ reverse ] map ] unit-test
[ { "b" "e" } ] [ 1 { { "a" "b" "c" } { "d" "e" "f" } } <column> >vector ] unit-test
[ { { 1 4 } { 2 5 } { 3 6 } } ]
[ { { 1 2 3 } { 4 5 6 } } flip ] unit-test

2
library/tools/inspector.factor
View File

@ -34,7 +34,7 @@ M: hashtable sheet dup hash-keys swap hash-values 2list ;
dup first length >vector swons
dup peek over first [ set ] 2each
[ column ] map
seq-transpose
flip
[ " | " join ] map ;
: vocab-banner ( word -- )