diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index fe5a44167d..58086029ec 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -52,13 +52,13 @@ sequences io vectors words ; "/library/collections/tree-each.factor" "/library/collections/queues.factor" - "/library/math/matrices.factor" - "/library/math/parse-numbers.factor" - "/library/math/constants.factor" "/library/math/pow.factor" "/library/math/trig-hyp.factor" "/library/math/arc-trig-hyp.factor" + "/library/math/matrices.factor" + "/library/math/quaternions.factor" + "/library/math/parse-numbers.factor" "/library/words.factor" "/library/vocabularies.factor" diff --git a/library/math/matrices.factor b/library/math/matrices.factor index 4247464223..3554c51d4a 100644 --- a/library/math/matrices.factor +++ b/library/math/matrices.factor @@ -11,20 +11,12 @@ USING: arrays generic kernel sequences ; : 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 ; - -: vbetween? ( v from to -- v ) >r over >r v>= r> r> v<= vand ; : sum ( v -- n ) 0 [ + ] reduce ; : product ( v -- n ) 1 [ * ] reduce ; @@ -32,29 +24,25 @@ USING: arrays generic kernel sequences ; : set-axis ( x y axis -- v ) 2dup v* >r >r drop dup r> v* v- r> v+ ; -: v. ( v v -- x ) 0 [ * + ] 2reduce ; -: c. ( v v -- x ) 0 [ ** + ] 2reduce ; +: v. ( v v -- x ) + #! Real inner product. + 0 [ * + ] 2reduce ; + +: c. ( v v -- x ) + #! Complex inner product. + 0 [ ** + ] 2reduce ; : norm-sq ( v -- n ) 0 [ absq + ] reduce ; +: norm ( vec -- n ) norm-sq sqrt ; + +: normalize ( vec -- vec ) dup norm v/n ; + : proj ( u v -- w ) #! Orthogonal projection of u onto v. [ [ v. ] keep norm-sq v/n ] keep n*v ; -: cross-trace ( v1 v2 i1 i2 -- v1 v2 n ) - pick nth >r pick nth r> * ; - -: cross-minor ( v1 v2 i1 i2 -- n ) - [ cross-trace -rot ] 2keep swap cross-trace 2nip - ; - -: cross ( { x1 y1 z1 } { x2 y2 z2 } -- { z1 z2 z3 } ) - #! Cross product of two 3-dimensional vectors. - [ 1 2 cross-minor ] 2keep - [ 2 0 cross-minor ] 2keep - 0 1 cross-minor 3array ; - ! Matrices - : zero-matrix ( m n -- matrix ) swap [ drop zero-array ] map-with ; @@ -70,18 +58,10 @@ USING: arrays generic kernel sequences ; : n/m ( n m -- m ) [ n/v ] map-with ; : m/n ( m n -- m ) swap [ swap v/n ] map-with ; -: 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 ; +: m+ ( m m -- m ) [ v+ ] 2map ; +: m- ( m m -- m ) [ v- ] 2map ; +: m* ( m m -- m ) [ v* ] 2map ; +: m/ ( m m -- m ) [ v/ ] 2map ; : v.m ( v m -- v ) flip [ v. ] map-with ; : m.v ( m v -- v ) swap [ v. ] map-with ; diff --git a/library/math/pow.factor b/library/math/pow.factor index a10ef52168..fbe07b343d 100644 --- a/library/math/pow.factor +++ b/library/math/pow.factor @@ -15,10 +15,6 @@ M: complex sqrt >polar swap fsqrt swap 2 / polar> ; M: real sqrt dup 0 < [ neg fsqrt 0 swap rect> ] [ fsqrt ] if ; -: norm ( vec -- n ) norm-sq sqrt ; - -: normalize ( vec -- vec ) dup norm v/n ; - GENERIC: ^ ( z w -- z^w ) foldable : ^mag ( w abs arg -- magnitude ) diff --git a/library/math/quaternions.factor b/library/math/quaternions.factor index 95bc848441..b9cdb90fd4 100644 --- a/library/math/quaternions.factor +++ b/library/math/quaternions.factor @@ -2,8 +2,10 @@ ! See http://factor.sf.net/license.txt for BSD license. ! Everybody's favorite non-commutative skew field, the -! quaternions! Represented as pairs of complex numbers, -! that is, (a+bi)+(c+di)j. +! quaternions! + +! Quaternions are represented as pairs of complex numbers, +! using the identity: (a+bi)+(c+di)j = a+bi+cj+dk. USING: arrays kernel math sequences ; IN: math-internals @@ -15,13 +17,6 @@ IN: math-internals IN: math -: quaternion? ( seq -- ? ) - dup length 2 = [ - first2 [ number? ] 2apply and - ] [ - drop f - ] if ; - : q* ( u v -- u*v ) #! Multiply quaternions. [ q*a ] 2keep q*b 2array ; @@ -30,9 +25,13 @@ IN: math #! Quaternion conjugate. first2 neg >r conjugate r> 2array ; +: qrecip ( u -- 1/u ) + #! Quaternion inverse. + qconjugate dup norm-sq v/n ; + : q/ ( u v -- u/v ) #! Divide quaternions. - [ qconjugate q* ] keep norm-sq v/n ; + qrecip q* ; : q*n ( q n -- q ) #! Note: you will get the wrong result if you try to @@ -54,20 +53,25 @@ IN: math #! part. first2 >r imaginary r> >rect 3array ; +: cross ( u v -- u*v ) + #! Cross product of two 3-vectors can be computed using + #! quaternion multiplication. + [ v>q ] 2apply q* q>v ; + ! Zero -: q0 Q{ 0 0 0 0 }Q ; +: q0 @{ 0 0 }@ ; ! Units -: q1 Q{ 1 0 0 0 }Q ; -: qi Q{ 0 1 0 0 }Q ; -: qj Q{ 0 0 1 0 }Q ; -: qk Q{ 0 0 0 1 }Q ; +: q1 @{ 1 0 }@ ; +: qi @{ #{ 0 1 }# 0 }@ ; +: qj @{ 0 1 }@ ; +: qk @{ 0 #{ 0 1 }# }@ ; ! Euler angles -- see ! http://www.mathworks.com/access/helpdesk/help/toolbox/aeroblks/euleranglestoquaternions.html : (euler) ( theta unit -- q ) - >r -0.5 * dup cos c>q swap sin r> n*q v- ; + >r -0.5 * dup cos c>q swap sin r> n*v v- ; : euler ( phi theta psi -- q ) qk (euler) >r qj (euler) >r qi (euler) r> q* r> q* ; diff --git a/library/syntax/parse-syntax.factor b/library/syntax/parse-syntax.factor index e7d73c6f5b..29ef2b568f 100644 --- a/library/syntax/parse-syntax.factor +++ b/library/syntax/parse-syntax.factor @@ -153,9 +153,3 @@ SYMBOL: t : DEC: 10 (BASE) ; parsing : OCT: 8 (BASE) ; parsing : BIN: 2 (BASE) ; parsing - -: Q{ f ; parsing - -: }Q - reverse 2 swap cut - [ first2 rect> ] 2apply 2array swons ; parsing diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index ca26b9a097..8f15cb9129 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -278,15 +278,7 @@ M: cons pprint* ( list -- ) ] check-recursion ; M: array pprint* ( vector -- ) - #! This does a hack for printing quaternions. - [ - dup quaternion? [ - [ >rect 2array ] map concat - \ Q{ \ }Q - ] [ - \ @{ \ }@ - ] if pprint-sequence - ] check-recursion ; + [ \ @{ \ }@ pprint-sequence ] check-recursion ; M: vector pprint* ( vector -- ) [ \ { \ } pprint-sequence ] check-recursion ; diff --git a/library/syntax/see.factor b/library/syntax/see.factor index bc36538360..5a00d4bc17 100644 --- a/library/syntax/see.factor +++ b/library/syntax/see.factor @@ -71,7 +71,6 @@ M: compound (see) dup word-def swap see-body ; : method. ( word [[ class method ]] -- ) - newline \ M: pprint-word unswons pprint-word swap pprint-word @@ -80,7 +79,7 @@ M: compound (see) M: generic (see) dup dup "combination" word-prop swap see-body - dup methods [ method. ] each-with ; + dup methods [ newline method. ] each-with ; GENERIC: class. ( word -- ) @@ -88,6 +87,7 @@ GENERIC: class. ( word -- ) #! List all methods implemented for this class. dup class? [ dup implementors [ + newline dup in. tuck "methods" word-prop hash* method. ] each-with ] [ @@ -95,23 +95,26 @@ GENERIC: class. ( word -- ) ] if ; M: union class. + newline \ UNION: pprint-word dup pprint-word - members pprint-elements pprint-; newline ; + members pprint-elements pprint-; ; M: predicate class. + newline \ PREDICATE: pprint-word dup superclass pprint-word dup pprint-word v v>q qi = ] unit-test +[ t ] [ qj q>v v>q qj = ] unit-test +[ t ] [ qk q>v v>q qk = ] unit-test +[ t ] [ 1 c>q q1 = ] unit-test +[ t ] [ i c>q qi = ] unit-test diff --git a/library/ui/editors.factor b/library/ui/editors.factor index 61507f4c70..ab55470367 100644 --- a/library/ui/editors.factor +++ b/library/ui/editors.factor @@ -130,7 +130,7 @@ C: editor ( text -- ) rect-dim @{ 0 1 1 }@ v* @{ 1 0 0 }@ v+ ; M: editor user-input* ( ch editor -- ? ) - [ insert-char ] with-editor t ; + [ insert-char ] with-editor f ; M: editor pref-dim ( editor -- dim ) dup editor-text label-size @{ 1 0 0 }@ v+ ; diff --git a/library/ui/events.factor b/library/ui/events.factor index d7b0d3f5ce..54e14bd622 100644 --- a/library/ui/events.factor +++ b/library/ui/events.factor @@ -35,10 +35,13 @@ M: button-up-event handle-event ( event -- ) M: motion-event handle-event ( event -- ) motion-event-loc hand move-hand ; +: control-char? ( ch -- ? ) + "\0\e\r\u0008\u007f" member? ; + M: key-down-event handle-event ( event -- ) dup keyboard-event>binding hand hand-focus handle-gesture [ - keyboard-event-unicode dup 0 = [ + keyboard-event-unicode dup control-char? [ drop ] [ hand hand-focus user-input drop