Tabs gadget improved

TODO.FACTOR.txt

@@ -23,7 +23,6 @@
 
 + ui:
 
-- help viewer in ui: show title
 - x11 title bars are funny
 - cocoa: starting the UI with +foo switches opens them as files
 - if the listener is running a command when the image is saved, it
@@ -43,7 +42,6 @@
   - need actions for reloading the source file and opening word in jEdit
   - highlight showing panes in originating list
   - single set of tabs across the top
-- toggle/radio buttons/tabs or something
 - make-frame should compile
 - speed up ideas:
   - only do clipping for certain gadgets

contrib/httpd/browser-responder.factor

@@ -33,7 +33,7 @@ prettyprint sequences words xml ;
 
 : word-source ( -- )
     #! Write the source for the given word from the vocab as HTML.
-    current-word [ [ word-help ] with-html-stream ] when* ;
+    current-word [ [ see-help ] with-html-stream ] when* ;
 
 : browser-body ( -- )
     #! Write out the HTML for the body of the main browser page.

library/ui/gadgets/buttons.factor

@@ -4,7 +4,7 @@ IN: gadgets-buttons
 USING: gadgets gadgets-borders gadgets-theme generic io kernel
 math namespaces sequences styles threads ;
 
-TUPLE: button rollover? pressed? quot ;
+TUPLE: button rollover? pressed? selected? quot ;
 
 : buttons-down? ( -- ? )
     hand-buttons get-global empty? not ;
@@ -71,11 +71,12 @@ C: repeat-button ( gadget quot -- button )
 
 M: repeat-button tick ( ms object -- ) nip button-clicked ;
 
-TUPLE: button-paint plain rollover pressed ;
+TUPLE: button-paint plain rollover pressed selected ;
 
 : 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 ] }
     } cond ;

library/ui/gadgets/tabs.factor

@@ -7,42 +7,71 @@ gadgets-theme kernel sequences ;
 
 TUPLE: book page pages ;
 
-: show-page ( n book -- )
-    dup book-page unparent
-    [ book-pages nth ] keep
-    [ set-book-page ] 2keep
-    add-gadget ;
+: show-page ( gadget book -- )
+    dup book-page unparent [ set-book-page ] 2keep add-gadget ;
 
 C: book ( pages -- book )
     dup delegate>gadget
     [ set-book-pages ] keep
-    0 over show-page ;
+    dup book-pages first over show-page ;
 
 M: book pref-dim* ( book -- dim ) book-page pref-dim ;
 
 M: book layout* ( book -- )
     dup rect-dim swap book-page set-gadget-dim ;
 
-: <tab> ( name n book -- button )
-    [ show-page drop ] curry curry
-    >r <label> r> <bevel-button> ;
+TUPLE: radio-box value buttons quot ;
 
-: make-tabs ( book names -- gadget )
-    dup length [ pick <tab> ] 2map make-shelf
-    dup highlight-theme nip ;
+: update-selection ( radio-box -- )
+    dup radio-box-buttons [
+        second f swap set-button-selected?
+    ] each
+    dup radio-box-value over radio-box-buttons assoc
+    t swap set-button-selected?
+    dup dup radio-box-quot call
+    relayout-1 ;
+
+: find-radio-box [ radio-box? ] find-parent ;
+
+: set-radio-box-value* ( value gadget -- )
+    [ set-radio-box-value ] keep update-selection ;
+
+: select-value ( button value -- )
+    swap find-radio-box set-radio-box-value* ;
+
+: <radio-button> ( string value -- gadget )
+    [ select-value ] curry >r <label> r> <bevel-button> ;
+
+C: radio-box ( assoc quot -- gadget )
+    { 1 0 0 } over delegate>pack
+    [ set-radio-box-quot ] keep
+    >r [ first2 tuck <radio-button> 2array ] map r>
+    [ >r [ second ] map r> add-gadgets ] 2keep
+    [ set-radio-box-buttons ] 2keep
+    [ >r first first r> set-radio-box-value* ] keep
+    dup highlight-theme ;
 
 TUPLE: tabs buttons book ;
 
 C: tabs dup delegate>frame ;
 
-: set-tabs ( names pages tabs -- )
+: find-tabs [ tabs? ] find-parent ;
+
+: update-tabs ( tabs -- )
+    dup tabs-buttons radio-box-value swap tabs-book show-page ;
+
+: make-tabs ( assoc -- gadget )
+    [ find-tabs [ update-tabs ] when* ] <radio-box> ;
+
+: set-tabs ( assoc tabs -- )
     {
-        { [ <book> tuck ] set-tabs-book @center }
+        { [ dup [ second ] map <book> ] set-tabs-book @center }
         { [ make-tabs ] set-tabs-buttons @top }
     } build-grid ;
 
-: set-pages ( obj assoc tabs -- )
-    >r flip first2 swapd [ make-pane <scroller> ] map-with
-    r> set-tabs ;
+: make-pages ( obj assoc -- assoc )
+    [ first2 swapd make-pane <scroller> 2array ] map-with ;
+
+: set-pages ( obj assoc tabs -- ) >r make-pages r> set-tabs ;
 
 : <pages> ( obj assoc -- tabs ) <tabs> [ set-pages ] keep ;

library/ui/gadgets/theme.factor

@@ -42,11 +42,22 @@ USING: arrays gadgets kernel sequences styles ;
         { 1.0 1.0 1.0 1.0 }
     } } ;
 
+: selected-gradient
+    T{ gradient f {
+        { 0.65 0.65 0.65 1.0 }
+        { 0.8 0.8 0.8 1.0 }
+        { 0.8 0.8 0.8 1.0 }
+        { 1.0 1.0 1.0 1.0 }
+    } } ;
+
 : faint-boundary
     T{ solid f { 0.62 0.62 0.62 0.8 } } swap set-gadget-boundary ;
 
 : bevel-button-theme ( gadget -- )
-    plain-gradient rollover-gradient pressed-gradient
+    plain-gradient
+    rollover-gradient
+    pressed-gradient
+    selected-gradient
     <button-paint> over set-gadget-interior
     faint-boundary ;
 
@@ -54,8 +65,10 @@ USING: arrays gadgets kernel sequences styles ;
     plain-gradient over set-gadget-interior faint-boundary ;
 
 : roll-button-theme ( button -- )
-    f solid-black solid-black <button-paint> over set-gadget-boundary
-    f f pressed-gradient <button-paint> swap set-gadget-interior ;
+    f solid-black solid-black f
+    <button-paint> over set-gadget-boundary
+    f f pressed-gradient solid-black
+    <button-paint> swap set-gadget-interior ;
 
 : caret-theme ( caret -- )
     T{ solid f { 1.0 0.0 0.0 1.0 } } swap set-gadget-interior ;

library/ui/tools/help.factor

@@ -49,13 +49,10 @@ M: help-gadget focusable-child*
     swap help-gadget-showing dup
     [ over history-seq push-new update-history ] [ 2drop ] if ;
 
-: fancy-help ( obj -- )
-    link-name dup word? [ see-help ] [ help ] if ;
-
 : show-help ( link help -- )
     dup add-history [ set-help-gadget-showing ] 2keep
     dup update-title {
-        { "Article" [ fancy-help ] }
+        { "Article" [ help ] }
         { "Links in" [ links-in. ] }
     } swap help-gadget-tabs set-pages ;