From 58545d5756d8300796a3ef4a0175ebbf055dae40 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Wed, 31 Oct 2007 01:04:54 -0400
Subject: [PATCH] Radio buttons and check boxes

---
 extra/opengl/opengl.factor                   | 19 +++-
 extra/ui/gadgets/buttons/buttons-docs.factor | 21 ++---
 extra/ui/gadgets/buttons/buttons.factor      | 98 ++++++++++++++++----
 extra/ui/gadgets/editors/editors.factor      |  9 ++
 extra/ui/gadgets/labels/labels-docs.factor   |  8 +-
 extra/ui/gadgets/labels/labels.factor        | 16 +++-
 extra/ui/render/render.factor                | 27 ++++++
 extra/ui/tools/tools.factor                  |  7 +-
 8 files changed, 164 insertions(+), 41 deletions(-)

diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor
index 13ce47ba52..d796c2611d 100644
--- a/extra/opengl/opengl.factor
+++ b/extra/opengl/opengl.factor
@@ -2,7 +2,7 @@
 ! Portions copyright (C) 2007 Eduardo Cavazos.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types io kernel math namespaces
-sequences math.vectors opengl.gl opengl.glu combinators ;
+sequences math.vectors math.constants math.functions opengl.gl opengl.glu combinators arrays ;
 IN: opengl
 
 : coordinates [ first2 ] 2apply ;
@@ -63,6 +63,23 @@ IN: opengl
 : gl-poly ( points -- )
     GL_LINE_LOOP (gl-poly) ;
 
+: circle-steps dup length v/n 2 pi * v*n ;
+
+: unit-circle dup [ sin ] map swap [ cos ] map ;
+
+: adjust-points [ [ 1 + 0.5 * ] map ] 2apply ;
+
+: scale-points 2array flip [ v* ] curry* map [ v+ ] curry* map ;
+
+: circle-points ( loc dim steps -- points )
+    circle-steps unit-circle adjust-points scale-points ;
+
+: gl-circle ( loc dim steps -- )
+    circle-points gl-poly ;
+
+: gl-fill-circle ( loc dim steps -- )
+    circle-points gl-fill-poly ;
+
 : prepare-gradient ( direction dim -- v1 v2 )
     tuck v* [ v- ] keep ;
 
diff --git a/extra/ui/gadgets/buttons/buttons-docs.factor b/extra/ui/gadgets/buttons/buttons-docs.factor
index d791e7e192..d398255bc4 100644
--- a/extra/ui/gadgets/buttons/buttons-docs.factor
+++ b/extra/ui/gadgets/buttons/buttons-docs.factor
@@ -7,11 +7,7 @@ HELP: button
 $nl
 "A button's appearance can vary depending on the state of the mouse button if the " { $link gadget-interior } " or " { $link gadget-boundary } " slots are set to instances of " { $link button-paint } "."
 $nl
-"A button can be selected, which is distinct from being pressed. This state is held in the " { $link button-selected? } " slot, and is used by the " { $link <radio-box> } " word to construct a row of buttons for choosing among several alternatives." } ;
-
-HELP: >label
-{ $values { "obj" "a label specifier" } { "gadget" "a new " { $link gadget } } }
-{ $description "Convert the object into a gadget suitable for use as the label of a button. If " { $snippet "obj" } " is already a gadget, does nothing. Otherwise creates a " { $link label } " gadget if it is a string and an empty gadget if " { $snippet "obj" } " is " { $link f } "." } ;
+"A button can be selected, which is distinct from being pressed. This state is held in the " { $link button-selected? } " slot, and is used by the " { $link <toggle-buttons> } " word to construct a row of buttons for choosing among several alternatives." } ;
 
 HELP: <button>
 { $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" "a new " { $link button } } }
@@ -35,20 +31,20 @@ HELP: button-paint
         { { $link button-paint-plain } " - the button is inactive" }
         { { $link button-paint-rollover } " - the button is under the mouse" }
         { { $link button-paint-pressed } " - the button is under the mouse and a mouse button is held down" }
-        { { $link button-paint-selected } " - the button is selected (see " { $link <radio-box> }  }
+        { { $link button-paint-selected } " - the button is selected (see " { $link <toggle-buttons> }  }
     }
 "The " { $link <roll-button> } " and " { $link <bevel-button> } " words create " { $link button } " instances with specific " { $link button-paint } "." } ;
 
-HELP: <radio-control>
+HELP: <toggle-button>
 { $values { "model" model } { "value" object } { "label" "a label specifier" } { "gadget" gadget } }
 { $description
     "Creates a " { $link <bevel-button> } " which sets the model's value to " { $snippet "value" } " when pressed. After being pressed, the button becomes selected until the value of the model changes again."
 }
-{ $notes "Typically a row of radio controls should be built together using " { $link <radio-box> } "." } ;
+{ $notes "Typically a row of radio controls should be built together using " { $link <toggle-buttons> } "." } ;
 
-HELP: <radio-box>
+HELP: <toggle-buttons>
 { $values { "model" model } { "assoc" "an association list mapping labels to objects" } { "gadget" gadget } }
-{ $description "Creates a row of labelled " { $link <radio-control> } " gadgets which change the value of the model." } ;
+{ $description "Creates a row of labelled " { $link <toggle-button> } " gadgets which change the value of the model." } ;
 
 HELP: <command-button>
 { $values { "target" object } { "gesture" "a gesture" } { "command" "a command" } { "button" "a new " { $link button } } }
@@ -74,11 +70,8 @@ ARTICLE: "ui.gadgets.buttons" "Button gadgets"
 { $subsection <command-button> }
 { $subsection <toolbar> }
 "A radio box is a row of buttons for choosing amongst several distinct possibilities:"
-{ $subsection <radio-box> }
+{ $subsection <toggle-buttons> }
 "Button appearance can be customized:"
 { $subsection button-paint }
 "Button constructors take " { $emphasis "label specifiers" } " as input. A label specifier is either a string, an array of strings, a gadget or " { $link f } "."
-$nl
-"A generic word used to convert label specifiers to gadgets:"
-{ $subsection >label }
 { $see-also <command-button> "ui-commands" } ;
diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor
index 18e812e609..bd5591fa32 100644
--- a/extra/ui/gadgets/buttons/buttons.factor
+++ b/extra/ui/gadgets/buttons/buttons.factor
@@ -4,7 +4,7 @@ USING: arrays ui.commands ui.gadgets ui.gadgets.borders
 ui.gadgets.controls ui.gadgets.labels ui.gadgets.theme
 ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
 ui.render kernel math models namespaces sequences strings
-quotations assocs combinators classes colors ;
+quotations assocs combinators classes colors tuples ;
 IN: ui.gadgets.buttons
 
 TUPLE: button pressed? selected? quot ;
@@ -38,12 +38,6 @@ button H{
     { T{ mouse-enter } [ button-update ] }
 } set-gestures
 
-GENERIC: >label ( obj -- gadget )
-M: string >label <label> ;
-M: array >label <label> ;
-M: object >label ;
-M: f >label drop <gadget> ;
-
 : <button> ( gadget quot -- button )
     button construct-empty
     [ set-button-quot ] keep
@@ -53,12 +47,14 @@ TUPLE: button-paint plain rollover pressed selected ;
 
 C: <button-paint> button-paint
 
+: find-button [ [ button? ] is? ] find-parent ;
+
 : button-paint ( button paint -- button paint )
-    {
-        { [ over button-pressed? ] [ button-paint-pressed ] }
-        { [ over button-selected? ] [ button-paint-selected ] }
-        { [ over button-rollover? ] [ button-paint-rollover ] }
-        { [ t ] [ button-paint-plain ] }
+    over find-button {
+        { [ dup button-pressed? ] [ drop button-paint-pressed ] }
+        { [ dup button-selected? ] [ drop button-paint-selected ] }
+        { [ dup button-rollover? ] [ drop button-paint-rollover ] }
+        { [ t ] [ drop button-paint-plain ] }
     } cond ;
 
 M: button-paint draw-interior
@@ -99,14 +95,78 @@ repeat-button H{
     repeat-button construct-empty
     [ >r <bevel-button> r> set-gadget-delegate ] keep ;
 
-: <radio-control> ( model value label -- gadget )
-    over [ swap set-control-value ] curry <bevel-button>
-    swap [ swap >r = r> set-button-selected? ] curry <control> ;
+: checkmark-theme ( gadget -- )
+    f
+    f
+    black <solid>
+    black <checkmark-paint>
+    <button-paint>
+    over set-gadget-interior
+    black <solid>
+    swap set-gadget-boundary ;
 
-: <radio-box> ( model assoc -- gadget )
-    [
-        swap [ -rot <radio-control> gadget, ] curry assoc-each
-    ] make-shelf ;
+: <checkmark> ( -- gadget )
+    <gadget>
+    dup checkmark-theme
+    { 14 14 } over set-gadget-dim ;
+
+: toggle-model ( model -- )
+    [ not ] change-model ;
+
+: checkbox-theme
+    f over set-gadget-interior
+    { 5 5 } over set-pack-gap
+    1/2 swap set-pack-align ;
+
+: <checkbox> ( model label -- checkbox )
+    <checkmark>
+    label-on-right
+    over [ toggle-model drop ] curry <button>
+    [ set-button-selected? ] <control>
+    dup checkbox-theme ;
+
+: radio-knob-theme ( gadget -- )
+    f
+    f
+    black <radio-paint>
+    black <radio-paint>
+    <button-paint>
+    over set-gadget-interior
+    black <radio-paint>
+    swap set-gadget-boundary ;
+
+: <radio-knob> ( -- gadget )
+    <gadget>
+    dup radio-knob-theme
+    { 16 16 } over set-gadget-dim ;
+
+: <radio-control> ( model value gadget quot -- control )
+    >r dupd [ set-control-value ] curry* r> call
+    [ >r = r> set-button-selected? ] curry* <control> ; inline
+
+: <radio-controls> ( model assoc quot -- gadget )
+    swapd [ >r -rot r> call gadget, ] 2curry assoc-each ; inline
+
+: radio-button-theme
+    { 5 5 } over set-pack-gap 1/2 swap set-pack-align ;
+
+: <radio-button> ( model value label -- gadget )
+    <radio-knob> label-on-right
+    [ <button> ] <radio-control>
+    dup radio-button-theme ;
+
+: radio-buttons-theme
+    { 5 5 } swap set-pack-gap ;
+
+: <radio-buttons> ( model assoc -- gadget )
+    [ [ <radio-button> ] <radio-controls> ] make-filled-pile
+    dup radio-buttons-theme ;
+
+: <toggle-button> ( model value label -- gadget )
+    [ <bevel-button> ] <radio-control> ;
+
+: <toggle-buttons> ( model assoc -- gadget )
+    [ [ <toggle-button> ] <radio-controls> ] make-shelf ;
 
 : command-button-quot ( target command -- quot )
     [ invoke-command drop ] 2curry ;
diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor
index 214572b0d8..0c5e5cee3c 100644
--- a/extra/ui/gadgets/editors/editors.factor
+++ b/extra/ui/gadgets/editors/editors.factor
@@ -34,6 +34,15 @@ TUPLE: loc-monitor editor ;
     dup init-editor-locs
     dup editor-theme ;
 
+: field-theme ( gadget -- )
+    gray <solid> swap set-gadget-boundary ;
+
+: <field> ( model -- )
+    drop
+    <editor>
+    2 <border>
+    dup field-theme ;
+
 : construct-editor ( class -- tuple )
     >r <editor> { set-gadget-delegate } r>
     (construct-control) ; inline
diff --git a/extra/ui/gadgets/labels/labels-docs.factor b/extra/ui/gadgets/labels/labels-docs.factor
index 2672261b97..874227a9b8 100644
--- a/extra/ui/gadgets/labels/labels-docs.factor
+++ b/extra/ui/gadgets/labels/labels-docs.factor
@@ -30,6 +30,12 @@ ARTICLE: "ui.gadgets.labels" "Label gadgets"
 { $subsection <label> }
 { $subsection <label-control> }
 { $subsection label-string }
-{ $subsection set-label-string } ;
+{ $subsection set-label-string }
+"Label specifiers are used by buttons, checkboxes and radio buttons:"
+{ $subsection >label } ;
 
 ABOUT: "ui.gadgets.labels"
+
+HELP: >label
+{ $values { "obj" "a label specifier" } { "gadget" "a new " { $link gadget } } }
+{ $description "Convert the object into a gadget suitable for use as the label of a button. If " { $snippet "obj" } " is already a gadget, does nothing. Otherwise creates a " { $link label } " gadget if it is a string and an empty gadget if " { $snippet "obj" } " is " { $link f } "." } ;
diff --git a/extra/ui/gadgets/labels/labels.factor b/extra/ui/gadgets/labels/labels.factor
index 9dd2c21b56..580d67d17a 100644
--- a/extra/ui/gadgets/labels/labels.factor
+++ b/extra/ui/gadgets/labels/labels.factor
@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays hashtables io kernel math namespaces
 opengl sequences io.streams.lines strings splitting
-ui.gadgets ui.gadgets.controls ui.gadgets.theme ui.render
-colors ;
+ui.gadgets ui.gadgets.controls ui.gadgets.packs ui.gadgets.theme
+ui.render colors ;
 IN: ui.gadgets.labels
 
 ! A label gadget draws a string.
@@ -47,3 +47,15 @@ M: label gadget-text* label-string % ;
 : reverse-video-theme ( label -- )
     white over set-label-color
     black solid-interior ;
+
+GENERIC: >label ( obj -- gadget )
+M: string >label <label> ;
+M: array >label <label> ;
+M: object >label ;
+M: f >label drop <gadget> ;
+
+: label-on-left ( gadget label -- button )
+    [ >label gadget, gadget, ] make-shelf ;
+
+: label-on-right ( label gadget -- button )
+    [ gadget, >label gadget, ] make-shelf ;
diff --git a/extra/ui/render/render.factor b/extra/ui/render/render.factor
index 7b872dc49f..2c2f84c067 100644
--- a/extra/ui/render/render.factor
+++ b/extra/ui/render/render.factor
@@ -140,6 +140,33 @@ M: polygon draw-interior
     >r <polygon> <gadget> r> over set-rect-dim
     [ set-gadget-interior ] keep ;
 
+! Checkbox and radio button pens
+TUPLE: checkmark-paint color ;
+
+C: <checkmark-paint> checkmark-paint
+
+M: checkmark-paint draw-interior
+    checkmark-paint-color gl-color
+    origin get [
+        rect-dim
+        { 0 0 } over gl-line
+        dup { 0 1 } v* swap { 1 0 } v* gl-line
+    ] with-translation ;
+
+
+TUPLE: radio-paint color ;
+
+C: <radio-paint> radio-paint
+
+M: radio-paint draw-interior
+    radio-paint-color gl-color
+    origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ;
+
+M: radio-paint draw-boundary
+    radio-paint-color gl-color
+    origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
+
+! Font rendering
 SYMBOL: font-renderer
 
 HOOK: open-font font-renderer ( font -- open-font )
diff --git a/extra/ui/tools/tools.factor b/extra/ui/tools/tools.factor
index 3e59583eb6..7a8b64aa4f 100644
--- a/extra/ui/tools/tools.factor
+++ b/extra/ui/tools/tools.factor
@@ -9,7 +9,7 @@ ui.gadgets.books ui.gadgets.buttons ui.gadgets.controls
 ui.gadgets.labelled ui.gadgets.scrollers ui.gadgets.tracks
 ui.gadgets.worlds ui.gadgets.presentations ui.gestures words
 vocabs.loader tools.test ui.gadgets.buttons
-ui.gadgets.status-bar ;
+ui.gadgets.status-bar mirrors ;
 IN: ui.tools
 
 : workspace-tabs ( -- seq )
@@ -24,9 +24,8 @@ IN: ui.tools
 : <workspace-tabs> ( -- tabs )
     g control-model
     "tool-switching" workspace command-map
-    [ command-string ] { } assoc>map
-    [ length ] keep 2array flip
-    <radio-box> ;
+    [ command-string ] { } assoc>map <enum> >alist
+    <toggle-buttons> ;
 
 : <workspace-book> ( -- gadget )
     workspace-tabs [ execute ] map g control-model <book> ;