+ ui:\r
\r
- faster layout\r
-- tiled window manager\r
- faster repaint\r
-- console with presentations\r
- ui browser\r
- auto-updating inspector, mirrors abstraction\r
- mouse enter onto overlapping with interior, but not child, gadget\r
- rollovers broken in inspector\r
- menu dragging\r
- fix up the min thumb size hack\r
-- frame gap\r
\r
+ ffi:\r
\r
: || ;
! Install arithmetic operators into words
-[ + - / * ^ and or xor mod +- min gcd max bitand polar> align shift /mod /i /f rect> bitor proj
- bitxor dot rem || ] [
+[ + - / * ^ and or xor mod +- min gcd max bitand polar> align shift /mod /i /f rect> bitor
+ bitxor rem || ] [
dup arith-2 set-word-prop
] each
[ [[ = new= ]] [[ > new> ]] [[ < new< ]] [[ >= new>= ]] [[ <= new<= ]] ] [
] 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
: 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 )
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 ;
! : 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> * ;
! Matrices
! The major dimension is the number of elements per row.
TUPLE: matrix rows cols sequence ;
+
: >matrix<
[ matrix-rows ] keep
[ matrix-cols ] keep
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 )
[ 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> ;
-
-: filled-border ( child -- border )
- <plain-gadget> 5 <border> ;
-
-: gadget-child gadget-children car ;
+ 0 0 0 0 <etched-rect> <gadget> { 5 5 0 } <border> ;
-: layout-border-x/y ( border -- )
- dup border-size dup rot gadget-child move-gadget ;
+: layout-border-loc ( border -- )
+ dup border-size swap gadget-child set-gadget-loc ;
-: layout-border-w/h ( border -- )
- [ border-size 2 * ] keep
- [ shape-w over - ] keep
- [ shape-h rot - ] keep
- gadget-child resize-gadget ;
+: layout-border-dim ( border -- )
+ dup shape-dim over border-size 2 v*n v-
+ swap gadget-child set-gadget-dim ;
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 ;
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 ;
+++ /dev/null
-! 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 ;
! 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
-sequences strings styles vectors ;
+USING: generic kernel line-editor lists math matrices namespaces
+sdl sequences strings styles vectors ;
! An editor gadget wraps a line editor object and passes
! gestures to the line 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
+++ /dev/null
-! 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 ;
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 ;
! 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
M: gadget pref-dim shape-dim ;
-: pref-size pref-dim 3unseq drop ;
-
GENERIC: layout* ( gadget -- )
: prefer ( gadget -- ) dup pref-dim swap set-gadget-dim ;
C: label ( text -- label )
<empty-gadget> over set-delegate [ set-label-text ] keep ;
-: label-size ( gadget text -- w h )
- >r gadget-font r> size-string ;
+: label-size ( gadget text -- dim )
+ >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
+++ /dev/null
-! 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/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"
"/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"
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 ;