[[ [ button-up 1 ] [ my-hand shape-x my-hand shape-y pick move-gadget world get add-gadget ] ]]
}} swap set-gadget-gestures ;
+: filled? "filled" get checkbox-selected? ;
+
: <funny-rect>
- <plain-rect> <gadget> dup moving-actions ;
+ filled? [ <plain-rect> ] [ <hollow-rect> ] ifte <gadget> dup moving-actions ;
: <funny-ellipse>
- <plain-ellipse> <gadget> dup moving-actions ;
+ filled? [ <plain-ellipse> ] [ <hollow-ellipse> ] ifte <gadget> dup moving-actions ;
: <funny-line>
<line> <gadget> dup moving-actions ;
-: check-box ( label -- checkbox )
- 0 0 0 0 <rectangle> <shelf>
- [ >r <label> r> add-gadget ] keep
- [ >r f bevel-border r> add-gadget ] keep ;
-
: make-shapes ( -- )
f world get set-gadget-children
"New Rectangle" [ drop 100 100 100 100 <funny-rect> dup [ 255 255 0 ] background set-paint-property world get add-gadget ] <button> "shelf" get add-gadget
"New Ellipse" [ drop 100 100 200 100 <funny-ellipse> dup [ 0 255 0 ] background set-paint-property world get add-gadget ] <button> "shelf" get add-gadget
"New Line" [ drop 100 100 200 100 <funny-line> dup [ 255 0 0 ] background set-paint-property world get add-gadget ] <button> "shelf" get add-gadget
- "A check box" [ drop ] <check-box> "shelf" get add-gadget
+ "Filled?" <checkbox> dup "filled" set "shelf" get add-gadget
"shelf" get "pile" get add-gadget
"Welcome to Factor " version cat2 <label> "pile" get add-gadget
[ 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
+
+[ t ] [
+ [
+ 100 x set
+ 100 y set
+ #{ 110 115 }# << line 0 0 100 150 >> inside?
+ ] with-scope
+] unit-test
: <button> ( label quot -- button )
>r <label> bevel-border dup r> button-actions ;
-: <cross> ( w h -- cross )
+: <check> ( w h -- cross )
2dup >r >r 0 0 r> r> <line> <gadget>
- >r tuck neg >r >r >r 0 r> r> r> <line> <gadget> r> 2list <stack> ;
+ >r tuck neg >r >r >r 0 r> r> r> <line> <gadget> r>
+ 2list <stack> ;
-: <check-box> ( label quot -- checkbox )
- >r 0 0 0 0 <rectangle> <shelf>
+TUPLE: checkbox bevel selected? delegate ;
+
+: 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? [
+ 11 11 <check>
+ ] [
+ 0 0 11 11 <rectangle> <gadget>
+ ] ifte swap checkbox-bevel add-gadget ;
+
+: toggle-checkbox ( checkbox -- )
+ dup checkbox-selected? not over set-checkbox-selected?
+ update-checkbox ;
+
+C: checkbox ( label -- checkbox )
+ 0 0 0 0 <rectangle> <shelf> over set-checkbox-delegate
[ >r <label> r> add-gadget ] keep
- [ >r 11 11 <cross> bevel-border r> add-gadget ] keep dup
- r> button-actions ;
+ [ f bevel-border swap init-checkbox-bevel ] keep
+ dup [ toggle-checkbox ] button-actions
+ dup update-checkbox ;
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-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>screen ( shape -- x1 y1 x2 y2 )
[ line-x x get + ] keep
[ line-y y get + ] keep
- [ dup line-w swap line-x + pick + ] keep
- dup line-h swap line-y + pick + ;
+ [ line-w pick + ] keep
+ line-h pick + ;
: line-inside? ( p d -- ? )
- dupd proj - absq 2 < ;
+ dupd proj - absq 4 < ;
M: line inside? ( point line -- ? )
2dup inside-rect? [