UI cleanups

TODO.FACTOR.txt

@@ -33,8 +33,11 @@
 
 + ui/help:
 
+- track:
+  - don't allow negative dimensions
+  - support removing items
+  - fix round-off error
 - zooming doesn't work
-- sort out various round-off issues
 - implement handlers for open, quit events, and whatever else
 - fix top level window positioning
 - changing window titles

library/ui/apropos.factor

@@ -3,17 +3,11 @@ USING: gadgets gadgets-editors gadgets-labels gadgets-layouts
 gadgets-panes gadgets-scrolling gadgets-theme generic inspector
 kernel ;
 
-TUPLE: apropos-gadget pane input ;
+TUPLE: apropos-gadget scroller input ;
 
 : apropos-pane ( gadget -- pane )
-    [ apropos-gadget? ] find-parent apropos-gadget-pane ;
+    [ apropos-gadget? ] find-parent
-
+    apropos-gadget-scroller scroller-gadget ;
-: add-apropos-gadget-pane ( pane gadget -- )
-    2dup set-apropos-gadget-pane
-    >r <scroller> r> @center frame-add ;
-
-: add-apropos-gadget-input ( input gadget -- )
-    2dup set-apropos-gadget-input @top frame-add ;
 
 : <prompt> ( quot -- editor )
     "" <editor> [
@@ -24,11 +18,14 @@ TUPLE: apropos-gadget pane input ;
     dup commit-editor-text
     swap apropos-pane [ apropos ] with-pane ;
 
+: <apropos-prompt> ( -- gadget )
+    [ show-apropos ] <prompt> dup faint-boundary ;
+
 C: apropos-gadget ( -- )
-    <frame> over set-delegate
+    {
-    <pane> over add-apropos-gadget-pane
+        { [ <pane> <scroller> ] set-apropos-gadget-scroller @center }
-    [ show-apropos ] <prompt> dup faint-boundary 
+        { [ <apropos-prompt> ] set-apropos-gadget-input @top }
-    over add-apropos-gadget-input ;
+    } make-frame ;
 
 M: apropos-gadget pref-dim* drop { 350 200 0 } ;
 

library/ui/frames.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets-layouts
-USING: arrays gadgets generic kernel math namespaces
+USING: arrays gadgets generic kernel math namespaces sequences
-sequences ;
+words ;
 
 ! A frame arranges gadgets in a 3x3 grid, where the center
 ! gadgets gets left-over space.
@@ -83,3 +83,20 @@ M: frame layout* ( frame -- dim )
         swap reduce-grid [ second ] map
         2dup
     ] keep rect-dim fill-center 3dup position-grid resize-grid ;
+
+: frame-add-spec ( { quot setter loc } -- )
+    first3 >r >r call
+    frame get 2dup r> dup [ execute ] [ 3drop ] if
+    r> execute frame-add ;
+
+: build-frame ( gadget specs -- )
+    #! Specs is an array of triples { quot setter loc }.
+    #! The setter has stack effect ( new gadget -- ),
+    #! the loc is @center, @top, etc.
+    [ swap frame set [ frame-add-spec ] each ] with-scope ;
+
+: make-frame ( gadget specs -- gadget )
+    #! Specs is an array of triples { quot setter loc }.
+    #! The setter has stack effect ( new gadget -- ),
+    #! the loc is @center, @top, etc.
+    over [ delegate>frame build-frame ] keep ;

library/ui/listener.factor

@@ -7,7 +7,10 @@ gadgets-theme generic hashtables io jedit
 kernel listener math namespaces parser prettyprint
 sequences styles threads words ;
 
-TUPLE: listener-gadget pane stack ;
+TUPLE: listener-gadget scroller stack ;
+
+: listener-gadget-pane ( listener -- pane )
+    listener-gadget-scroller scroller-gadget ;
 
 : usable-words ( -- words )
     use get hash-concat hash-values ;
@@ -50,12 +53,10 @@ TUPLE: listener-gadget pane stack ;
     [ >r clear r> listener-thread ] in-thread drop ;
 
 C: listener-gadget ( -- gadget )
-    dup delegate>frame
+    {
-    <input-pane> dup pick set-listener-gadget-pane
+        { [ <stack-bar> ] set-listener-gadget-stack @top }
-    <scroller> over @center frame-add
+        { [ <input-pane> <scroller> ] set-listener-gadget-scroller @center }
-    <stack-bar> dup pick set-listener-gadget-stack
+    } make-frame dup start-listener ;
-    over @top frame-add
-    dup start-listener ;
 
 M: listener-gadget pref-dim* drop { 600 600 0 } ;
 

library/ui/scrolling.factor

@@ -71,12 +71,6 @@ M: viewport layout* ( viewport -- )
 M: viewport focusable-child* ( viewport -- gadget )
     gadget-child ;
 
-: add-viewport 2dup set-scroller-viewport @center frame-add ;
-
-: add-x-slider 2dup set-scroller-x @bottom frame-add ;
-
-: add-y-slider 2dup set-scroller-y @right frame-add ;
-
 : scroll-to ( gadget -- )
     #! Scroll the scroller that contains this gadget, if any, so
     #! that the gadget becomes visible.
@@ -94,11 +88,15 @@ M: viewport focusable-child* ( viewport -- gadget )
 
 C: scroller ( gadget -- scroller )
     #! Wrap a scrolling pane around the gadget.
-    dup delegate>frame
+    {
-    [ >r <viewport> r> add-viewport ] keep
+        { [ <viewport> ] set-scroller-viewport @center }
-    <x-slider> over add-x-slider
+        { [ <x-slider> ] set-scroller-x @bottom }
-    <y-slider> over add-y-slider
+        { [ <y-slider> ] set-scroller-y @right }
-    dup scroller-actions ;
+    } make-frame dup scroller-actions ;
 
 M: scroller focusable-child* ( scroller -- viewport )
     scroller-viewport ;
+
+: scroller-gadget ( scroller -- gadget )
+    #! Gadget being scrolled.
+    scroller-viewport gadget-child ;

library/ui/sliders.factor

@@ -108,44 +108,46 @@ M: elevator layout* ( elevator -- )
 
 : slide-by-line ( -1/1 slider -- ) >r 32 * r> slide-by ;
 
-: slider-vertical? gadget-orientation { 0 1 0 } = ;
+: <slide-button> ( vector polygon amount -- )
-
-: <slide-button> ( orientation polygon amount -- )
     >r { 0.5 0.5 0.5 1.0 } swap <polygon-gadget> r>
     [ swap slide-by-line ] curry <repeat-button>
     [ set-gadget-orientation ] keep ;
 
-: <up-button> ( slider orientation -- button )
+: <left-button> { 0 1 0 } arrow-left -1 <slide-button> ;
-    swap slider-vertical? arrow-up arrow-left ? -1
+: <right-button> { 0 1 0 } arrow-right 1 <slide-button> ;
-    <slide-button> ;
 
-: add-up { 1 1 1 } over gadget-orientation v- first2 frame-add ;
+: build-x-slider ( slider -- slider )
+    {
+        { [ <left-button> ] f @left }
+        { [ { 0 1 0 } <elevator> ] set-slider-elevator @center }
+        { [ <right-button> ] f @right }
+    } build-frame ;
 
-: <down-button> ( slider orientation -- button )
+: <up-button> { 1 0 0 } arrow-up -1 <slide-button> ;
-    swap slider-vertical? arrow-down arrow-right ? 1
+: <down-button> { 1 0 0 } arrow-down 1 <slide-button> ;
-    <slide-button> ;
 
-: add-down { 1 1 1 } over gadget-orientation v+ first2 frame-add ;
+: build-y-slider ( slider -- slider )
+    {
+        { [ <up-button> ] f @top }
+        { [ { 1 0 0 } <elevator> ] set-slider-elevator @center }
+        { [ <down-button> ] f @bottom }
+    } build-frame ;
 
-: add-elevator 2dup set-slider-elevator @center frame-add ;
+: add-thumb ( slider vector -- )
-
+    <thumb> swap 2dup slider-elevator add-gadget
-: add-thumb 2dup slider-elevator add-gadget set-slider-thumb ;
+    set-slider-thumb ;
-
-: slider-opposite ( slider -- vector )
-    gadget-orientation { 1 1 0 } swap v- ;
 
 C: slider ( vector -- slider )
     dup delegate>frame
     [ set-gadget-orientation ] keep
     0 over set-slider-value
     0 over set-slider-page
-    0 over set-slider-max
+    0 over set-slider-max ;
-    dup slider-opposite
-    dup <elevator> pick add-elevator
-    2dup <up-button> pick add-up
-    2dup <down-button> pick add-down
-    <thumb> over add-thumb ;
 
-: <x-slider> ( -- slider ) { 1 0 0 } <slider> ;
+: <x-slider> ( -- slider )
+    { 1 0 0 } <slider> dup build-x-slider
+    dup { 0 1 0 } add-thumb ;
 
-: <y-slider> ( -- slider ) { 0 1 0 } <slider> ;
+: <y-slider> ( -- slider )
+    { 0 1 0 } <slider> dup build-y-slider
+    dup { 1 0 0 } add-thumb ;

library/ui/world.factor

@@ -9,7 +9,7 @@ math namespaces opengl sequences ;
 
 ! fonts: mapping font tuples to sprite vectors
 ! handle: native resource
-TUPLE: world status focus fonts handle ;
+TUPLE: world gadget status focus fonts handle ;
 
 : free-fonts ( world -- )
     dup world-handle select-gl-context
@@ -19,18 +19,16 @@ TUPLE: world status focus fonts handle ;
 : font-sprites ( font world -- sprites )
     world-fonts [ drop V{ } clone ] cache ;
 
-: add-status ( status world -- )
-    [ set-world-status ] 2keep @bottom frame-add ;
-
 DEFER: request-focus
 
 C: world ( gadget status -- world )
-    dup delegate>frame
+    {
+        { [ ] set-world-status @bottom }
+        { [ ] f @center }
+    } make-frame
     t over set-gadget-root?
     H{ } clone over set-world-fonts
-    [ add-status ] keep
+    dup world-gadget request-focus ;
-    [ @center frame-add ] 2keep
-    swap request-focus ;
 
 GENERIC: find-world ( gadget -- world )
 

native/unix/signal.c

@@ -18,9 +18,6 @@ static bool in_page(void *fault, void *i_area, CELL area_size, int offset)
 
 void signal_handler(int signal, siginfo_t* siginfo, void* uap)
 {
-	printf("fucked\n");
-	fflush(stdout);
-
 	if(in_page(siginfo->si_addr, (void *) ds_bot, 0, -1))
 		general_error(ERROR_DS_UNDERFLOW,F,F,false);
 	else if(in_page(siginfo->si_addr, (void *) ds_bot, ds_size, 0))