diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index 763606cebf..51ab80daa3 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -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" diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor index 6e19104fe1..2d146e81ac 100644 --- a/library/collections/sequences-epilogue.factor +++ b/library/collections/sequences-epilogue.factor @@ -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 ) [ ] 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 ; + [ dup like ] map ; : max-length ( seq -- n ) #! Longest sequence length in a sequence of sequences. @@ -238,6 +221,8 @@ M: object reverse ( seq -- seq ) [ ] 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 ) diff --git a/library/collections/slicing.factor b/library/collections/slicing.factor index 52130e46e8..667d2dbd5a 100644 --- a/library/collections/slicing.factor +++ b/library/collections/slicing.factor @@ -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 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 ; @@ -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 -- ) diff --git a/library/collections/vectors-epilogue.factor b/library/collections/vectors-epilogue.factor index 9fdcd677e4..a2eb5c4db9 100644 --- a/library/collections/vectors-epilogue.factor +++ b/library/collections/vectors-epilogue.factor @@ -10,16 +10,16 @@ IN: vectors : >vector ( list -- vector ) dup length [ swap nappend ] keep ; -M: repeated thaw >vector ; +M: object thaw >vector ; M: vector clone ( vector -- vector ) >vector ; : zero-vector ( n -- vector ) 0 >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 diff --git a/library/inference/branches.factor b/library/inference/branches.factor index d4df13cc91..67e509949e 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -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? ; diff --git a/library/inference/class-infer.factor b/library/inference/class-infer.factor index 39524f0d3f..cd31d24ce3 100644 --- a/library/inference/class-infer.factor +++ b/library/inference/class-infer.factor @@ -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 ; diff --git a/library/inference/inference.factor b/library/inference/inference.factor index b437e7d365..efb501ac97 100644 --- a/library/inference/inference.factor +++ b/library/inference/inference.factor @@ -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 diff --git a/library/inference/optimizer.factor b/library/inference/optimizer.factor index ef1b788d6c..c65d883f75 100644 --- a/library/inference/optimizer.factor +++ b/library/inference/optimizer.factor @@ -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 diff --git a/library/math/matrices.factor b/library/math/matrices.factor index 7792b25dfe..41b50f072a 100644 --- a/library/math/matrices.factor +++ b/library/math/matrices.factor @@ -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 - [ >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 ; - -: ( rows cols -- matrix ) - 2dup * zero-vector ; - -: ( vector -- matrix ) - #! Turn a vector into a matrix of one row. - [ 1 swap length ] keep ; - -: ( vector -- matrix ) - #! Turn a vector into a matrix of one column. - [ length 1 ] keep ; - -: make-matrix ( rows cols quot -- matrix | quot: i j -- elt ) - -rot [ - [ [ [ rot call , ] 3keep ] 2repeat ] make-vector nip - ] 2keep rot ; inline - -: ( 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 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 [ drop 1 ] nmap ; ! Matrix operations -: m+ ( m m -- m ) element-wise v+ ; -: m- ( m m -- m ) element-wise v- ; +: 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* ; +: 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 ) [ v. ] map-with ; +: m.v ( m v -- v ) swap [ v. ] map-with ; +: m. ( m m -- m ) >r r> [ m.v ] map-with ; -: m. ( m1 m2 -- m ) - #! Composition of two matrices. - 2dup *check 2dup *dimensions [ - ( m1 m2 row col -- m1 m2 ) - pick >r pick r> v. - ] make-matrix 2nip ; - -: n*m ( n m -- m ) - #! Multiply a matrix by a scalar. - >matrix< >r rot r> n*v ; - -: m.v ( m v -- v ) - #! Multiply a matrix by a column vector. - m. matrix-sequence ; - -: v.m ( v m -- v ) - #! Multiply a row vector by a matrix. - >r 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 >vector ] map-with >list ; +: trace ( matrix -- tr ) 0 swap product ; diff --git a/library/syntax/math.factor b/library/syntax/math.factor index daf3425145..92db6ee6f8 100644 --- a/library/syntax/math.factor +++ b/library/syntax/math.factor @@ -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 swons ; parsing diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index cb7b5f38df..b743764a17 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -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 diff --git a/library/test/math/matrices.factor b/library/test/math/matrices.factor index ad133aa195..1bf9f75762 100644 --- a/library/test/math/matrices.factor +++ b/library/test/math/matrices.factor @@ -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 + 3 1 zero-matrix ] unit-test [ - M{ { 1 } { 2 } { 3 } }M -] [ - { 1 2 3 } -] unit-test - -[ - M{ { 1 0 0 } + { { 1 0 0 } { 0 1 0 } - { 0 0 1 } }M + { 0 0 1 } } ] [ - 3 + 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 { 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 >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 diff --git a/library/test/sequences.factor b/library/test/sequences.factor index bf40857b14..32f09f9868 100644 --- a/library/test/sequences.factor +++ b/library/test/sequences.factor @@ -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" } } >vector ] unit-test + +[ { { 1 4 } { 2 5 } { 3 6 } } ] +[ { { 1 2 3 } { 4 5 6 } } flip ] unit-test diff --git a/library/tools/inspector.factor b/library/tools/inspector.factor index 2dd2e824d0..f1079ca323 100644 --- a/library/tools/inspector.factor +++ b/library/tools/inspector.factor @@ -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 -- )