added norm, proj words for vectors, removed dot/proj for complex numbers, more UI strippage

TODO.FACTOR.txt

@@ -32,16 +32,13 @@
 + ui:
 
 - faster layout
-- tiled window manager
 - faster repaint
-- console with presentations
 - ui browser
 - auto-updating inspector, mirrors abstraction
 - mouse enter onto overlapping with interior, but not child, gadget
 - rollovers broken in inspector
 - menu dragging
 - fix up the min thumb size hack
-- frame gap
 
 + ffi:
 

contrib/algebra/infix.factor

@@ -175,8 +175,8 @@ M: infix-word see
 : || ;
 
 ! Install arithmetic operators into words
-[ + - / * ^ and or xor mod +- min gcd max bitand polar> align shift /mod /i /f rect> bitor proj
+[ + - / * ^ and or xor mod +- min gcd max bitand polar> align shift /mod /i /f rect> bitor
-  bitxor dot rem || ] [
+  bitxor rem || ] [
     dup arith-2 set-word-prop
 ] each
 [ [[ = new= ]] [[ > new> ]] [[ < new< ]] [[ >= new>= ]] [[ <= new<= ]] ] [

examples/mandel.factor

@@ -94,8 +94,6 @@ USE: test
         ] repeat
     ] make-vector nip ;
 
-: absq >rect swap sq swap sq + ; inline
-
 : iter ( c z nb-iter -- x )
     over absq 4 >= over 0 = or [
         nip nip

library/math/complex.factor

@@ -46,14 +46,6 @@ M: number = ( n n -- ? ) number= ;
 
 : 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 )

library/math/matrices.factor

@@ -4,10 +4,12 @@ IN: matrices
 USING: errors generic kernel lists math namespaces sequences
 vectors ;
 
+! Vector operations
 : 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 ;
 
-! Vector operations
 : v+ ( v v -- v ) [ + ] 2map ;
 : v- ( v v -- v ) [ - ] 2map ;
 : v* ( v v -- v ) [ * ] 2map ;
@@ -27,6 +29,13 @@ vectors ;
 ! : v. ( v v -- x ) 0 swap [ conjugate * + ] 2each ;
 : v. ( v v -- x ) v** sum ;
 
+: norm-sq ( v -- n ) 0 [ absq + ] reduce ;
+: norm ( v -- n ) norm-sq sqrt ;
+
+: 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> * ;
 
@@ -44,6 +53,7 @@ vectors ;
 ! Matrices
 ! The major dimension is the number of elements per row.
 TUPLE: matrix rows cols sequence ;
+
 : >matrix<
     [ matrix-rows ] keep
     [ matrix-cols ] keep

library/ui/borders.factor

@@ -4,8 +4,6 @@ IN: gadgets
 USING: errors generic hashtables kernel lists math matrices
 namespaces sdl vectors ;
 
-! A border lays out its children on top of each other, all with
-! a 5-pixel padding.
 TUPLE: border size ;
 
 C: border ( child delegate size -- border )
@@ -13,29 +11,19 @@ C: border ( child delegate size -- border )
     [ set-delegate ] keep
     [ over [ add-gadget ] [ 2drop ] ifte ] keep ;
 
-: empty-border ( child -- border )
-    <empty-gadget> 5 <border> ;
-
 : line-border ( child -- border )
-    0 0 0 0 <etched-rect> <gadget> 5 <border> ;
+    0 0 0 0 <etched-rect> <gadget> { 5 5 0 } <border> ;
 
-: filled-border ( child -- border )
+: layout-border-loc ( border -- )
-    <plain-gadget> 5 <border> ;
+    dup border-size swap gadget-child set-gadget-loc ;
 
-: gadget-child gadget-children car ;
+: layout-border-dim ( border -- )
-
+    dup shape-dim over border-size 2 v*n v-
-: layout-border-x/y ( border -- )
+    swap gadget-child set-gadget-dim ;
-    dup border-size dup rot gadget-child move-gadget ;
-
-: layout-border-w/h ( border -- )
-    [ border-size 2 * ] keep
-    [ shape-w over - ] keep
-    [ shape-h rot - ] keep
-    gadget-child resize-gadget ;
 
 M: border pref-dim ( border -- dim )
-    [ border-size dup dup 3vector 2 v*n ] keep
+    [ border-size 2 v*n ] keep
     gadget-child pref-dim v+ ;
 
 M: border layout* ( border -- )
-    dup layout-border-x/y layout-border-w/h ;
+    dup layout-border-loc layout-border-dim ;

library/ui/buttons.factor

@@ -40,6 +40,3 @@ sequences io sequences styles ;
     dup [ button-update ] [ mouse-leave ] set-action
     dup [ button-update ] [ mouse-enter ] set-action
     [ drop ] [ drag 1 ] set-action ;
-
-: <button> ( label action -- button )
-    >r <label> line-border dup r> button-action button-gestures ;

library/ui/checkboxes.factor

@@ -1,48 +0,0 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets
-USING: generic kernel lists math namespaces sdl sequences
-styles ;
-
-: check-size 8 ;
-
-: <check> ( -- cross )
-    0 0 check-size dup <line> <gadget>
-    >r check-size 0 check-size neg check-size <line> <gadget> r>
-    2list <stack> ;
-
-TUPLE: checkbox bevel selected? ;
-
-: init-checkbox-bevel ( bevel checkbox -- )
-    2dup set-checkbox-bevel add-gadget ;
-
-: update-checkbox ( checkbox -- )
-    #! Really, there should only be one child.
-    dup checkbox-bevel gadget-children [ unparent ] each
-    dup checkbox-selected? [
-        <check>
-    ] [
-        0 0 check-size dup <rectangle> <gadget>
-    ] ifte swap checkbox-bevel add-gadget ;
-
-: toggle-checkbox ( checkbox -- )
-    dup checkbox-selected? not over set-checkbox-selected?
-    update-checkbox ;
-
-: checkbox-update ( checkbox -- )
-    dup button-pressed? >r checkbox-bevel r>
-    reverse-video set-paint-prop ;
-
-: checkbox-actions ( checkbox -- )
-    dup [ toggle-checkbox ] [ action ] set-action
-    dup [ dup checkbox-update button-clicked ] [ button-up 1 ] set-action
-    dup [ checkbox-update ] [ button-down 1 ] set-action
-    dup [ checkbox-update ] [ mouse-leave ] set-action
-    [ checkbox-bevel button-update ] [ mouse-enter ] set-action ;
-
-C: checkbox ( label -- checkbox )
-    <line-shelf> over set-delegate
-    [ f line-border swap init-checkbox-bevel ] keep
-    [ >r <label> r> add-gadget ] keep
-    dup checkbox-actions
-    dup update-checkbox ;

library/ui/editors.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: generic kernel line-editor lists math namespaces sdl
+USING: generic kernel line-editor lists math matrices namespaces
-sequences strings styles vectors ;
+sdl sequences strings styles vectors ;
 
 ! An editor gadget wraps a line editor object and passes
 ! gestures to the line editor.
@@ -89,7 +89,7 @@ M: editor user-input* ( ch editor -- ? )
     scroll>bottom  t ;
 
 M: editor pref-dim ( editor -- dim )
-    dup editor-text label-size >r 1 + r> 0 3vector ;
+    dup editor-text label-size { 1 0 0 } v+ ;
 
 M: editor layout* ( editor -- )
     dup editor-caret over caret-size rot resize-gadget

library/ui/ellipses.factor

@@ -1,58 +0,0 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets
-USING: generic kernel lists math namespaces sdl styles ;
-
-! An ellipse.
-TUPLE: ellipse x y w h ;
-M: ellipse shape-x ellipse-x ;
-M: ellipse shape-y ellipse-y ;
-M: ellipse shape-w ellipse-w ;
-M: ellipse shape-h ellipse-h ;
-
-C: ellipse ( x y w h -- line )
-    #! We handle negative w/h for convenience.
-    >r fix-neg >r fix-neg r> r>
-    [ set-ellipse-h ] keep
-    [ set-ellipse-w ] keep
-    [ set-ellipse-y ] keep
-    [ set-ellipse-x ] keep ;
-
-M: ellipse move-shape ( x y line -- )
-    tuck set-ellipse-y set-ellipse-x ;
-
-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
-    pick shape-y - sq
-    >r swap shape-x - sq r>
-    r> * r> rot * + r> <= ;
-
-M: ellipse draw-shape drop ;
-
-TUPLE: hollow-ellipse ;
-
-C: hollow-ellipse ( x y w h -- ellipse )
-    [ >r <ellipse> r> set-delegate ] keep ;
-
-M: hollow-ellipse draw-shape ( ellipse -- )
-    >r surface get r> ellipse>screen fg rgb
-    ellipseColor ;
-
-TUPLE: plain-ellipse ;
-
-C: plain-ellipse ( x y w h -- ellipse )
-    [ >r <ellipse> r> set-delegate ] keep ;
-
-M: plain-ellipse draw-shape ( ellipse -- )
-    >r surface get r> ellipse>screen bg rgb
-    filledEllipseColor ;

library/ui/frames.factor

@@ -37,6 +37,8 @@ C: frame ( -- frame )
         dup frame-left , dup frame-center , frame-right ,
     ] make-list ;
 
+: pref-size pref-dim 3unseq drop ;
+
 : max-h pref-size nip height [ max ] change ;
 : max-w pref-size drop width [ max ] change ;
 

library/ui/gadgets.factor

@@ -9,6 +9,8 @@ sequences vectors ;
 ! delegates to its shape.
 TUPLE: gadget paint gestures relayout? redraw? parent children ;
 
+: gadget-child gadget-children car ;
+
 C: gadget ( shape -- gadget )
     [ set-delegate ] keep
     [ <namespace> swap set-gadget-paint ] keep
@@ -77,8 +79,6 @@ GENERIC: pref-dim ( gadget -- dim )
 
 M: gadget pref-dim shape-dim ;
 
-: pref-size pref-dim 3unseq drop ;
-
 GENERIC: layout* ( gadget -- )
 
 : prefer ( gadget -- ) dup pref-dim swap set-gadget-dim ;

library/ui/labels.factor

@@ -10,11 +10,11 @@ TUPLE: label text ;
 C: label ( text -- label )
     <empty-gadget> over set-delegate [ set-label-text ] keep ;
 
-: label-size ( gadget text -- w h )
+: label-size ( gadget text -- dim )
-    >r gadget-font r> size-string ;
+    >r gadget-font r> size-string 0 3vector ;
 
 M: label pref-dim ( label -- dim )
-    dup label-text label-size 0 3vector ;
+    dup label-text label-size ;
 
 M: label draw-shape ( label -- )
     [ dup gadget-font swap label-text ] keep

library/ui/lines.factor

@@ -1,71 +0,0 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets
-USING: generic kernel lists math namespaces sdl styles ;
-
-! A line.
-TUPLE: line x y w h ;
-
-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 1 + ;
-M: line shape-h line-h abs 1 + ;
-
-: line-pos ( line -- #{ x y }# )
-    dup line-x x get + swap line-y y get + 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 move-line-y move-line-x ;
-
-: resize-line-w ( w line -- )
-    >r 1 - r>
-    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 -- )
-   >r 1 - r>
-    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 resize-line-h resize-line-w ;
-
-: line>screen ( shape -- x1 y1 x2 y2 )
-    [ line-x x get + ] keep
-    [ line-y y get + ] keep
-    [ line-w pick + ] keep
-    line-h pick + ; 
-
-: line-inside? ( p d -- ? )
-    dupd proj - absq 4 < ;
-
-M: line inside? ( point line -- ? )
-    2dup inside-rect? [
-        [ line-pos - ] keep line-dir line-inside?
-    ] [
-        2drop f
-    ] ifte ;
-
-M: line draw-shape ( line -- )
-    >r surface get r>
-    line>screen
-    fg rgb
-    aalineColor ;

library/ui/load.factor

@@ -4,8 +4,6 @@ USING: kernel parser sequences io ;
     "/library/ui/shapes.factor"
     "/library/ui/points.factor"
     "/library/ui/rectangles.factor"
-    "/library/ui/lines.factor"
-    "/library/ui/ellipses.factor"
     "/library/ui/gadgets.factor"
     "/library/ui/hierarchy.factor"
     "/library/ui/paint.factor"
@@ -19,7 +17,6 @@ USING: kernel parser sequences io ;
     "/library/ui/world.factor"
     "/library/ui/labels.factor"
     "/library/ui/buttons.factor"
-    "/library/ui/checkboxes.factor"
     "/library/ui/line-editor.factor"
     "/library/ui/events.factor"
     "/library/ui/scrolling.factor"

library/ui/menus.factor

@@ -16,7 +16,7 @@ USING: generic kernel lists math namespaces sequences ;
     show-glass ;
 
 : menu-item-border ( child -- border )
-    <plain-gadget> 1 <border> ;
+    <plain-gadget> { 1 1 0 } <border> ;
 
 : <menu-item> ( label quot -- gadget )
     >r <label> menu-item-border dup r> button-gestures ;