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

UI user input fix

cvs
Slava Pestov 2005-10-05 06:01:06 +00:00
parent 0e148687ad
commit 47da70e5a8
11 changed files with 62 additions and 93 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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"

42
library/math/matrices.factor
View File

@ -17,14 +17,6 @@ USING: arrays generic kernel sequences ;
: 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 ;
@ -74,14 +62,6 @@ USING: arrays generic kernel sequences ;
: 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 ;
: v.m ( v m -- v ) flip [ v. ] map-with ;
: m.v ( m v -- v ) swap [ v. ] map-with ;

4
library/math/pow.factor
View File

@ -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 )

36
library/math/quaternions.factor
View File

@ -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* ;

6
library/syntax/parse-syntax.factor
View File

@ -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

10
library/syntax/prettyprint.factor
View File

@ -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 ;

15
library/syntax/see.factor
View File

@ -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
<block
"definition" word-prop pprint-elements
pprint-; block; newline ;
pprint-; block; ;
M: tuple-class class.
newline
\ TUPLE: pprint-word
dup pprint-word
"slot-names" word-prop [ f text ] each
pprint-; newline ;
pprint-; ;
M: word class. drop ;
@ -119,9 +122,9 @@ M: word class. drop ;
[
dup (synopsis)
dup (see)
newline
dup class.
methods.
newline
] with-pprint ;
: (apropos) ( substring -- seq )

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

@ -92,14 +92,6 @@ unit-test
[ @{ @{ 1 2 }@ @{ 3 4 }@ @{ 5 6 }@ }@ flip ]
unit-test
[ @{ t t t }@ ]
[ @{ 1 2 3 }@ @{ -1 -2 -3 }@ @{ 4 5 6 }@ vbetween? ]
unit-test
[ @{ t f t }@ ]
[ @{ 1 10 3 }@ @{ -1 -2 -3 }@ @{ 4 5 6 }@ vbetween? ]
unit-test
[
@{ @{ 6 }@ }@
] [

5
library/test/math/quaternions.factor
View File

@ -18,3 +18,8 @@ USING: kernel math test ;
[ t ] [ qk qj q/ qi = ] unit-test
[ t ] [ qi qk q/ qj = ] unit-test
[ t ] [ qj qi q/ qk = ] unit-test
[ t ] [ qi q>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

2
library/ui/editors.factor
View File

@ -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+ ;

5
library/ui/events.factor
View File

@ -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