checkboxes

examples/gadget-test.factor

@@ -42,20 +42,17 @@ USE: words
         [[ [ 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
     
@@ -65,7 +62,7 @@ USE: words
     "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
 

library/test/gadgets.factor

@@ -63,3 +63,11 @@ USING: gadgets kernel lists math namespaces 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
+
+[ t ] [
+    [
+        100 x set
+        100 y set
+        #{ 110 115 }# << line 0 0 100 150 >> inside?
+    ] with-scope
+] unit-test

library/ui/buttons.factor

@@ -51,12 +51,32 @@ USING: generic kernel lists math namespaces sdl ;
 : <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 ;

library/ui/shapes.factor

@@ -123,7 +123,9 @@ 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-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 -- )
@@ -159,11 +161,11 @@ M: line resize-shape ( w h 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? [