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

fixing sloppy code

cvs
Daniel Ehrenberg 2005-10-02 04:34:31 +00:00
parent 850d040b65
commit cf7665bb9b
1 changed files with 11 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
library/ui/gadgets.factor
View File

@ -23,13 +23,14 @@ M: array rect-dim drop @{ 0 0 0 }@ ;
: |v-| ( vec vec -- vec ) v- [ 0 max ] map ; : |v-| ( vec vec -- vec ) v- [ 0 max ] map ;
: (intersect) ( rect rect -- array array )
[ rect-extent ] 2apply swapd vmin >r vmax r> ;
: intersect ( rect rect -- rect ) : intersect ( rect rect -- rect )
[ rect-extent ] 2apply swapd vmin >r vmax dup r> (intersect) dupd swap |v-| <rect> ;
swap |v-| <rect> ;
: intersects? ( rect/point rect -- ? ) : intersects? ( rect/point rect -- ? )
[ rect-extent ] 2apply swapd vmin >r vmax r> v- (intersect) v- [ 0 <= ] all? ;
[ 0 <= ] all? ;
! A gadget is a rectangle, a paint, a mapping of gestures to ! A gadget is a rectangle, a paint, a mapping of gestures to
! actions, and a reference to the gadget's parent. ! actions, and a reference to the gadget's parent.
@ -73,12 +74,13 @@ M: gadget children-on ( rect/point gadget -- list )
: translate ( rect/point -- ) : translate ( rect/point -- )
rect-loc origin [ v+ ] change ; rect-loc origin [ v+ ] change ;
: pick-up ( rect/point gadget -- gadget ) : (pick-up) ( rect/point gadget -- gadget )
2dup inside? [ 2dup inside? [
[ dup translate 2dup pick-up-list dup
dup translate 2dup pick-up-list dup [ nip (pick-up) ] [ rot 2drop ] if
[ nip pick-up ] [ rot 2drop ] if
] with-scope
] [ 2drop f ] if ; ] [ 2drop f ] if ;
: pick-up ( rect/point gadget -- gadget )
[ (pick-up) ] with-scope ;
: max-dim ( dims -- dim ) @{ 0 0 0 }@ [ vmax ] reduce ; : max-dim ( dims -- dim ) @{ 0 0 0 }@ [ vmax ] reduce ;