fixed UI bootstrap

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 928e67e71b3091804fdcaa50eb4557be95d75f63..0fabe98632f8af344cdbda161c784c45022604e2 100644 (file)
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -1,6 +1,9 @@
 + ui:\r
 \r
 - if gadgets are moved, added or deleted, update hand.\r
+- keyboard focus\r
+- keyboard gestures\r
+- text fields\r
 \r
 + compiler:\r
 \r

diff --git a/library/math/complex.factor b/library/math/complex.factor
index 99551d4a6f0c60b1fef69154f8453a140d0a4898..87e03626603db4f39e82a300779edc32bf8788bc 100644 (file)
--- a/library/math/complex.factor
+++ b/library/math/complex.factor
@@ -66,7 +66,7 @@ M: complex imaginary 1 slot %real ;
     >rect swap fatan2 ;
 
 : >polar ( z -- abs arg )
-    >rect 2dup swap fatan2 >r mag2 r> ;
+    dup abs swap >rect swap fatan2 ;
 
 : cis ( theta -- cis )
     dup fcos swap fsin rect> ;
@@ -74,6 +74,16 @@ M: complex imaginary 1 slot %real ;
 : polar> ( abs arg -- z )
     cis * ;
 
+: absq >rect swap sq swap sq + ;
+
+: dot ( #{ x1 x2 }# #{ y1 y2 }# -- x1*y1+x2*y2 )
+    over real over real * >r swap imaginary swap imaginary * r>
+    + ;
+
+: proj ( u v -- w )
+    #! Orthogonal projection of u onto v.
+    [ [ dot ] keep absq /f ] keep * ;
+
 IN: math-internals
 
 : 2>rect ( x y -- xr yr xi yi )
@@ -90,15 +100,14 @@ M: complex + 2>rect + >r + r> (rect>) ;
 M: complex - 2>rect - >r - r> (rect>) ;
 M: complex * ( x y -- x*y ) 2dup *re - -rot *im + (rect>) ;
 
-: abs^2 ( x -- y ) >rect sq swap sq + ; inline
 : complex/ ( x y -- r i m )
     #! r = xr*yr+xi*yi, i = xi*yr-xr*yi, m = yr*yr+yi*yi
-    dup abs^2 >r 2dup *re + -rot *im - r> ; inline
+    dup absq >r 2dup *re + -rot *im - r> ; inline
 
 M: complex / ( x y -- x/y ) complex/ tuck / >r / r> (rect>) ;
 M: complex /f ( x y -- x/y ) complex/ tuck /f >r /f r> (rect>) ;
 
-M: complex abs ( z -- |z| ) >rect mag2 ;
+M: complex abs ( z -- |z| ) absq fsqrt ;
 
 M: complex hashcode ( n -- n )
     >rect >fixnum swap >fixnum bitxor ;

diff --git a/library/math/math.factor b/library/math/math.factor
index 69abeb22fb5847a5fc1912345183d32d158ddf56..a9cf93667043715906f94002ebdecac70175183e 100644 (file)
--- a/library/math/math.factor
+++ b/library/math/math.factor
@@ -98,10 +98,6 @@ M: number = ( n n -- ? ) number= ;
     #! Push the sign of a real number.
     dup 0 = [ drop 0 ] [ 1 < -1 1 ? ] ifte ;
 
-: mag2 ( x y -- mag )
-    #! Returns the magnitude of the vector (x,y).
-    swap sq swap sq + fsqrt ;
-
 GENERIC: abs ( z -- |z| )
 M: real abs dup 0 < [ neg ] when ;
 

diff --git a/library/test/gadgets.factor b/library/test/gadgets.factor
index 737d4762d263e40aabc37f7733bc792128c7f750..b645804943ec2509e3383bc9be7f314af3dd2d0f 100644 (file)
--- a/library/test/gadgets.factor
+++ b/library/test/gadgets.factor
@@ -23,33 +23,43 @@ USING: gadgets kernel lists math namespaces test ;
     ] with-scope
 ] unit-test
 [ 11 11 41 41 ] [
-    default-paint [
-        [
-            1 x set
-            1 y set
-            10 10 30 30 <rectangle> <gadget> shape>screen
-        ] with-scope
-    ] bind
+    [
+        1 x set
+        1 y set
+        10 10 30 30 <rectangle> <gadget> shape>screen
+    ] with-scope
 ] unit-test
 [ t ] [
-    default-paint [
+    [
+        0 x set
+        0 y set
         0 0 rect> -10 -10 20 20 <rectangle> <gadget> [ pick-up ] keep =
-    ] bind
+    ] with-scope
 ] unit-test
 
 : funny-rect ( x -- rect )
     10 10 30 <rectangle> <gadget>
-    dup [ 255 0 0 ] color set-paint-property ;
+    dup [ 255 0 0 ] foreground set-paint-property ;
     
 [ f ] [
-    default-paint [
+    [
+        0 x set
+        0 y set
         35 0 rect>
         [ 10 30 50 70 ] [ funny-rect ] map
-        pick-up
-    ] bind
+        pick-up-list
+    ] with-scope
 ] unit-test
 
 [ 1 3 2 ] [ #{ 1 2 }# #{ 3 4 }# x1/x2/y1 ] unit-test
 [ 1 3 4 ] [ #{ 1 2 }# #{ 3 4 }# x1/x2/y2 ] unit-test
 [ 1 2 4 ] [ #{ 1 2 }# #{ 3 4 }# x1/y1/y2 ] unit-test
 [ 3 2 4 ] [ #{ 1 2 }# #{ 3 4 }# x2/y1/y2 ] unit-test
+
+[ -90 ] [ 10 10 -100 -200 <line> shape-x ] unit-test
+[ 20 ] [ 10 10 100 200 <line> [ 20 30 rot move-shape ] keep shape-x ] unit-test
+[ 30 ] [ 10 10 100 200 <line> [ 20 30 rot move-shape ] keep shape-y ] unit-test
+[ 20 ] [ 110 110 -100 -200 <line> [ 20 30 rot move-shape ] keep shape-x ] unit-test
+[ 30 ] [ 110 110 -100 -200 <line> [ 20 30 rot move-shape ] keep shape-y ] unit-test
+[ 10 ] [ 110 110 -100 -200 <line> [ 400 400 rot resize-shape ] keep shape-x ] unit-test
+[ 400 ] [ 110 110 -100 -200 <line> [ 400 400 rot resize-shape ] keep shape-w ] unit-test

diff --git a/library/ui/events.factor b/library/ui/events.factor
index d7c5dbb57b7f197a52d99182b35aeabb7fb6b909..566d9a7ecbc6d1da2f04e332f855ae1f6576dddb 100644 (file)
--- a/library/ui/events.factor
+++ b/library/ui/events.factor
@@ -2,7 +2,7 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
 USING: alien generic kernel lists math namespaces sdl sdl-event
-sdl-video ;
+sdl-keyboard sdl-video ;
 
 GENERIC: handle-event ( event -- )
 
@@ -34,3 +34,6 @@ M: button-up-event handle-event ( event -- )
 
 M: motion-event handle-event ( event -- )
     motion-event-pos my-hand move-hand ;
+
+M: key-down-event handle-event ( event -- )
+    keyboard-event>binding my-hand hand-gadget handle-gesture ;

diff --git a/library/ui/paint.factor b/library/ui/paint.factor
index e6be95a10d793bfd8a4e2a541bafcbb05bbf7c92..77ddf0cd47fc3a8417dcd048f8a07d2f55f414ee 100644 (file)
--- a/library/ui/paint.factor
+++ b/library/ui/paint.factor
@@ -24,12 +24,6 @@ SYMBOL: bevel-up?
 
 SYMBOL: font  ! a list of two elements, a font name and size.
 
-: shape>screen ( shape -- x1 y1 x2 y2 )
-    [ shape-x x get + ] keep
-    [ shape-y y get + ] keep
-    [ shape-w pick + ] keep
-    shape-h pick + ;
-
 GENERIC: draw-shape ( obj -- )
 
 ! Actual rectangles don't draw; use a hollow-rect, plain-rect
@@ -103,12 +97,6 @@ M: line draw-shape ( line -- )
 
 M: ellipse draw-shape drop ;
 
-: ellipse>screen ( shape -- x y rx ry )
-    [ dup shape-x swap shape-w 2 /i + x get + ] keep
-    [ dup shape-y swap shape-h 2 /i + y get + ] keep
-    [ shape-w 2 /i ] keep
-    shape-h 2 /i ;
-
 TUPLE: hollow-ellipse delegate ;
 
 C: hollow-ellipse ( x y w h -- ellipse )

diff --git a/library/ui/shapes.factor b/library/ui/shapes.factor
index 3b144a399b67f9cd0a7032782531d317072bb39d..6fef31edfd0e04befaabc4ba0e6107a93424bf4d 100644 (file)
--- a/library/ui/shapes.factor
+++ b/library/ui/shapes.factor
@@ -23,6 +23,12 @@ GENERIC: shape-h
 GENERIC: move-shape ( x y shape -- )
 GENERIC: resize-shape ( w h shape -- )
 
+: shape>screen ( shape -- x1 y1 x2 y2 )
+    [ shape-x x get + ] keep
+    [ shape-y y get + ] keep
+    [ shape-w pick + ] keep
+    shape-h pick + ;
+
 : with-translation ( shape quot -- )
     #! All drawing done inside the quotation is translated
     #! relative to the shape's origin.
@@ -92,38 +98,73 @@ M: rectangle resize-shape ( w h rect -- )
     tuck set-rectangle-h set-rectangle-w ;
 
 : rectangle-x-extents ( rect -- x1 x2 )
-    dup rectangle-x x get + swap rectangle-w 1 - dupd + ;
+    dup shape-x x get + swap shape-w 1 - dupd + ;
 
 : rectangle-y-extents ( rect -- x1 x2 )
-    dup rectangle-y y get + swap rectangle-h 1 - dupd + ;
+    dup shape-y y get + swap shape-h 1 - dupd + ;
 
-M: rectangle inside? ( point rect -- ? )
+: inside-rect? ( point rect -- ? )
     over shape-x over rectangle-x-extents between? >r
     swap shape-y swap rectangle-y-extents between? r> and ;
 
+M: rectangle inside? ( point rect -- ? )
+    inside-rect? ;
+
 ! A line.
 TUPLE: line x y w h ;
-M: line shape-x line-x ;
-M: line shape-y line-y ;
-M: line shape-w line-w ;
-M: line shape-h line-h ;
-
 C: line ( x y w h -- line )
-    #! We handle negative w/h for convinience.
-    >r fix-neg >r fix-neg r> r>
     [ set-line-h ] keep
     [ set-line-w ] keep
     [ set-line-y ] keep
     [ set-line-x ] keep ;
 
+M: line shape-x dup line-x dup rot line-w + min ;
+M: line shape-y dup line-y dup rot line-h + min ;
+M: line shape-w line-w abs ;
+M: line shape-h line-h abs ;
+
+: line-pos ( line -- #{ x y }# ) dup line-x swap line-y rect> ;
+: line-dir ( line -- #{ w h }# ) dup line-w swap line-h rect> ;
+
+: move-line-x ( x line -- )
+    [ line-w dupd - max ] keep set-line-x ;
+
+: move-line-y ( y line -- )
+    [ line-h dupd - max ] keep set-line-y ;
+
 M: line move-shape ( x y line -- )
-    tuck set-line-y set-line-x ;
+    tuck move-line-y move-line-x ;
+
+: resize-line-w ( w line -- )
+    dup line-w 0 >= [
+        set-line-w
+    ] [
+        2dup
+        [ [ line-w + ] keep line-x + ] keep set-line-x
+        >r neg r> set-line-w
+    ] ifte ;
+
+: resize-line-h ( w line -- )
+    dup line-h 0 >= [
+        set-line-h
+    ] [
+        2dup
+        [ [ line-h + ] keep line-y + ] keep set-line-y
+        >r neg r> set-line-h
+    ] ifte ;
 
 M: line resize-shape ( w h line -- )
-    tuck set-line-h set-line-w ;
+    tuck resize-line-h resize-line-w ;
+
+: line-inside? ( p d -- ? )
+    tuck proj - absq 2 < ;
 
 M: line inside? ( point line -- ? )
-    2drop t ;
+    2dup inside-rect? [
+        [ line-pos - ] keep line-dir line-inside?
+    ] [
+        2drop f
+    ] ifte ;
 
 ! An ellipse.
 TUPLE: ellipse x y w h ;
@@ -146,6 +187,12 @@ M: ellipse move-shape ( x y line -- )
 M: ellipse resize-shape ( w h line -- )
     tuck set-ellipse-h set-ellipse-w ;
 
+: ellipse>screen ( shape -- x y rx ry )
+    [ dup shape-x swap shape-w 2 /i + x get + ] keep
+    [ dup shape-y swap shape-h 2 /i + y get + ] keep
+    [ shape-w 2 /i ] keep
+    shape-h 2 /i ;
+
 M: ellipse inside? ( point ellipse -- ? )
     ellipse>screen swap sq swap sq
     2dup * >r >r >r