: branch-values ( branches -- )
[ last-node node-in-d >list ] map
- unify-lengths vector-transpose >list branch-returns set ;
+ unify-lengths dual branch-returns set ;
: can-kill-branches? ( literal node -- ? )
#! Check if the literal appears in either branch. This
: dispatcher% "dispatcher" word-prop % ;
+: error-method ( generic -- method )
+ [ literal, \ no-method , ] make-list ;
+
: empty-method ( generic -- method )
- [
- [ dup delegate ] %
- [ dup , ] make-list ,
- [ literal, \ no-method , ] make-list ,
- \ ?ifte ,
- ] make-list ;
+ dup "picker" word-prop [ dup ] = [
+ [
+ [ dup delegate ] %
+ [ dup , ] make-list ,
+ error-method ,
+ \ ?ifte ,
+ ] make-list
+ ] [
+ error-method
+ ] ifte ;
: <empty-vtable> ( generic -- vtable )
empty-method num-types swap <repeated> >vector ;
[ value-class ] map class-or-list <computed>
] ifte ;
-: vector-transpose ( list -- vector )
- #! Turn a list of same-length vectors into a vector of lists.
- dup car length [
- over [ nth ] map-with
- ] project >vector nip ;
+: dual ( list -- list )
+ 0 over nth length [ swap [ nth ] map-with ] project-with ;
: unify-stacks ( list -- stack )
#! Replace differing literals in stacks with unknown
#! results.
- unify-lengths vector-transpose [ unify-results ] map ;
+ unify-lengths dual [ unify-results ] map >vector ;
: balanced? ( list -- ? )
#! Check if a list of [[ instack outstack ]] pairs is
] extend ;
: (infer-branches) ( branchlist -- list )
- [
- [
- inferring-base-case get [
- [ infer-branch , ] [ [ drop ] when ] catch
- ] [
- infer-branch ,
- ] ifte
- ] each
- ] make-list ;
+ [ infer-branch ] map dup unify-effects unify-dataflow ;
: infer-branches ( branches node -- )
#! Recursive stack effect inference is done here. If one of
#! the branches has an undecidable stack effect, we set the
#! base case to this stack effect and try again.
- [
- >r (infer-branches) dup unify-effects unify-dataflow
- r> set-node-children
- ] keep node, ;
+ [ >r (infer-branches) r> set-node-children ] keep node, ;
\ ifte [
2 #drop node, pop-d pop-d swap 2list
nip consume/produce
] [
inferring-base-case get [
- drop no-base-case
+ 2drop terminate
] [
car base-case
] ifte
USING: errors generic kernel lists math namespaces sequences
vectors ;
-: n*v ( n vec -- vec )
- #! Multiply a vector by a scalar.
- [ * ] map-with ;
+: n*v ( n vec -- vec ) [ * ] map-with ;
! Vector operations
: v+ ( v v -- v ) [ + ] 2map ;
: v** ( v v -- v ) [ conjugate * ] 2map ;
! Later, this will fixed when 2each works properly
-! : v. ( v v -- x ) 0 swap [ * + ] 2each ;
+! : v. ( v v -- x ) 0 swap [ conjugate * + ] 2each ;
: v. ( v v -- x ) v** 0 swap [ + ] each ;
: cross-trace ( v1 v2 i1 i2 -- v1 v2 n )
clone-tuple
dup matrix-sequence clone over set-matrix-sequence ;
-: matrix@ ( row col matrix -- n ) matrix-rows * + ;
+: matrix@ ( row col matrix -- n ) matrix-cols rot * + ;
: matrix-get ( row col matrix -- elt )
[ matrix@ ] keep matrix-sequence nth ;
#! Composition of two matrices.
2dup *check 2dup *dimensions [
( m1 m2 row col -- m1 m2 )
- >r >r 2dup r> rot <row> r> rot <col> v.
+ pick <col> >r pick <row> r> v.
] make-matrix 2nip ;
: n*m ( n m -- m )
: infinite-loop infinite-loop ;
-[ [ infinite-loop ] infer old-effect ] unit-test-fails
+! [ [ infinite-loop ] infer old-effect ] unit-test-fails
: simple-recursion-1
dup [ simple-recursion-1 ] [ ] ifte ;
IN: temporary
USING: kernel lists math matrices namespaces test ;
+[ [ [ 1 4 ] [ 2 5 ] [ 3 6 ] ] ]
+[ M[ [ 1 4 ] [ 2 5 ] [ 3 6 ] ]M row-list ] unit-test
+
[
M[ [ 0 ] [ 0 ] [ 0 ] ]M
] [
[ { 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 ]
+unit-test
+
+[ M[ [ 1 3 5 ] [ 2 4 6 ] ]M ]
+[ M[ [ 1 3 5 ] [ 2 4 6 ] ]M transpose transpose ]
+unit-test
+
[ M[ [ 1 3 5 ] [ 2 4 6 ] ]M ]
[ M[ [ 1 2 ] [ 3 4 ] [ 5 6 ] ]M transpose ]
unit-test
+
+[
+ M[ [ 28 ] ]M
+] [
+ M[ [ 2 4 6 ] ]M
+
+ M[ [ 1 ]
+ [ 2 ]
+ [ 3 ] ]M
+
+ m.
+] unit-test