stack display hooks for single-stepper and inspector, reworking scrolling

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index fcce0145afeb8af366b8671daedac94eb0b7a7e2..3ca847bf001bc89c6512b8867ff0a56b6b423d7b 100644 (file)
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -25,6 +25,7 @@
 - opengl rendering\r
 - text selection\r
 - clipboard support\r
+- clicking outside menu doesn't close\r
 \r
 + tutorial:\r
 \r

diff --git a/library/help/tutorial.factor b/library/help/tutorial.factor
index c7a6fbb03113eed6ab8ccbfa678039b96b7c5169..5114ba09264680c7a5b3929455d5292642ff783c 100644 (file)
--- a/library/help/tutorial.factor
+++ b/library/help/tutorial.factor
@@ -2,7 +2,7 @@ IN: help
 USING: gadgets generic kernel lists math matrices namespaces sdl\r
 sequences strings styles ;\r
 \r
-: <title> ( text -- gadget )\r
+: <slide-title> ( text -- gadget )\r
     <label> dup 36 font-size set-paint-prop ;\r
 \r
 : <underline> ( -- gadget )\r
@@ -25,7 +25,7 @@ M: general-list tutorial-line
 \r
 : <page> ( list -- gadget )\r
     0 1 <pile>\r
-    over car <title> over add-gadget\r
+    over car <slide-title> over add-gadget\r
     <underline> over add-gadget\r
     swap cdr [ tutorial-line over add-gadget ] each\r
     empty-border ;\r
@@ -274,7 +274,8 @@ M: general-list tutorial-line
             ""\r
             [ "-1 sqrt ." ]\r
             ""\r
-            [ "M{ { 10 3 } { 7 5 } { -2 0 } }M M{ { 11 2 } { 4 8 } }M m." ]\r
+            [ "{ { 10 3 } { 7 5 } { -2 0 } }" ]\r
+            [ "{ { 11 2 } { 4 8 } } m." ]\r
             ""\r
             "... and there is much more for the math geeks."\r
         ] [\r

diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor
index c4da50c4c5072f3dccb248eaacbd5a5db0390fa8..db123a815b2db516b5cfb58d0c8fb4e04485a5db 100644 (file)
--- a/library/syntax/prettyprint.factor
+++ b/library/syntax/prettyprint.factor
@@ -310,7 +310,7 @@ M: wrapper pprint* ( wrapper -- )
 : pprint-short ( object -- string )
     [
         1 line-limit set
-        5 length-limit set
+        20 length-limit set
         2 nesting-limit set
         string-limit on
         pprint

diff --git a/library/tools/inspector.factor b/library/tools/inspector.factor
index ee1019cbeeb8d1804d676d4774452377d72122b8..11a99e0d978143deb09377de3fb1f9b7d331199d 100644 (file)
--- a/library/tools/inspector.factor
+++ b/library/tools/inspector.factor
@@ -95,6 +95,7 @@ SYMBOL: inspector-stack
         inspector-help
         terpri
         "inspector " listener-prompt set
+        [ inspector-stack get "Inspector history:" ] callstack-hook set
         { } clone inspector-stack set
         (inspect)
         listener

diff --git a/library/tools/listener.factor b/library/tools/listener.factor
index c4808a43a911b7b58b6d711e755c9aafb7d2a748..76a2a1972637640ef8ca7d82db0ef182e200b23b 100644 (file)
--- a/library/tools/listener.factor
+++ b/library/tools/listener.factor
@@ -6,7 +6,10 @@ presentation sequences strings styles vectors words ;
 
 SYMBOL: listener-prompt
 SYMBOL: quit-flag
+
 SYMBOL: listener-hook
+SYMBOL: datastack-hook
+SYMBOL: callstack-hook
 
 global [ "  " listener-prompt set ] bind
 
@@ -33,9 +36,10 @@ global [ "  " listener-prompt set ] bind
 
 : listen ( -- )
     #! Wait for user input, and execute.
+    listener-hook get call
     listener-prompt get write flush [
         read-multiline
-        [ call listener-hook get call ] [ bye ] ifte
+        [ call ] [ bye ] ifte
     ] try ;
 
 : listener ( -- )

diff --git a/library/tools/walker.factor b/library/tools/walker.factor
index ed97dbedd0bbb6ce0ac498aa971d43dd4c55fc83..dd8085bec699bb4aaf9008d284c63ccd840578f9 100644 (file)
--- a/library/tools/walker.factor
+++ b/library/tools/walker.factor
@@ -12,10 +12,15 @@ sequences io strings vectors words ;
     #! Print stepper data stack.
     meta-d get stack. ;
 
+: meta-r*
+    #! Stepper call stack, as well as the currently
+    #! executing quotation.
+    [ meta-r get % meta-executing get , meta-cf get , ] { } make ;
+
 : &r
     #! Print stepper call stack, as well as the currently
     #! executing quotation.
-    meta-cf get short. meta-executing get . meta-r get stack. ;
+    meta-r* stack. ;
 
 : &get ( var -- value )
     #! Get stepper variable value.
@@ -53,6 +58,8 @@ sequences io strings vectors words ;
 : walk-listener walk-banner "walk " listener-prompt set listener ;
 
 : init-walk ( quot callstack namestack -- )
+    [ meta-d get "Stepper data stack:" ] datastack-hook set
+    [ meta-r* "Stepper return stack:" ] callstack-hook set
     init-interpreter
     meta-n set
     meta-r set

diff --git a/library/ui/frames.factor b/library/ui/frames.factor
index b4acd73c45779d083dc9daef8ffbeec79680b36a..90e12be8281144887f333faa8e83e17340e91d4b 100644 (file)
--- a/library/ui/frames.factor
+++ b/library/ui/frames.factor
@@ -25,6 +25,12 @@ C: frame ( -- frame )
 : add-top    ( gadget frame -- ) 1 0 set-frame-child ;
 : add-bottom ( gadget frame -- ) 1 2 set-frame-child ;
 
+: get-center ( frame -- gadget ) 1 1 frame-child ;
+: get-left   ( frame -- gadget ) 0 1 frame-child ;
+: get-right  ( frame -- gadget ) 2 1 frame-child ;
+: get-top    ( frame -- gadget ) 1 0 frame-child ;
+: get-bottom ( frame -- gadget ) 1 2 frame-child ;
+
 : reduce-grid ( grid -- seq )
     [ { 0 0 0 } [ vmax ] reduce ] map ;
 

diff --git a/library/ui/listener.factor b/library/ui/listener.factor
new file mode 100644 (file)
index 0000000..f451f7c
--- /dev/null
+++ b/library/ui/listener.factor
@@ -0,0 +1,62 @@
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: help
+DEFER: <tutorial-button>
+
+IN: gadgets
+USING: generic help io kernel listener lists math namespaces
+prettyprint sdl sequences shells styles threads words ;
+
+SYMBOL: datastack-display
+SYMBOL: callstack-display
+
+TUPLE: display title pane ;
+
+: <display-title> ( text -- label )
+    <label>
+    dup << solid f >> interior set-paint-prop
+    dup { 216 232 255 } background set-paint-prop ;
+
+: add-display-title ( title display -- )
+    2dup set-display-title add-top ;
+
+C: display ( -- display )
+    <frame> over set-delegate
+    "" <display-title> over add-display-title
+    <line-pile> 2dup swap set-display-pane
+    <scroller> over add-center ;
+
+: present-stack ( seq title display -- )
+    [ display-title set-label-text ] keep
+    [
+        display-pane
+        dup clear-gadget swap reverse-slice [
+            dup presented swons unit swap unparse-short
+            <presentation> swap add-gadget
+        ] each-with
+    ] keep relayout ;
+
+: ui-listener-hook ( -- )
+    datastack-hook get call datastack-display get present-stack
+    callstack-hook get call callstack-display get present-stack ;
+
+: listener-thread
+    pane get [
+        [ datastack "Data stack:" ] datastack-hook set
+        [ callstack "Return stack:" ] callstack-hook set
+        [ ui-listener-hook ] listener-hook set
+        <tutorial-button> gadget.
+        tty
+    ] with-stream* ;
+
+: <stack-display> ( -- gadget )
+    <display> dup datastack-display set
+    <display> dup callstack-display set
+    1/2 <x-splitter> ;
+
+: listener-application ( -- )
+    <pane> dup pane set <scroller>
+    <stack-display>
+    2/3 <x-splitter> add-layer
+    [ clear listener-thread ] in-thread
+    pane get request-focus ;

diff --git a/library/ui/load.factor b/library/ui/load.factor
index b996162deb62f2f349ed0f53dd571cd0c95bbe7a..1bd46c6d5a2e315cec83a64793d6cb05471d50df 100644 (file)
--- a/library/ui/load.factor
+++ b/library/ui/load.factor
@@ -15,6 +15,7 @@ USING: kernel parser sequences io ;
     "/library/ui/buttons.factor"
     "/library/ui/line-editor.factor"
     "/library/ui/events.factor"
+    "/library/ui/sliders.factor"
     "/library/ui/scrolling.factor"
     "/library/ui/editors.factor"
     "/library/ui/menus.factor"
@@ -23,6 +24,7 @@ USING: kernel parser sequences io ;
     "/library/ui/panes.factor"
     "/library/ui/presentations.factor"
     "/library/ui/books.factor"
+    "/library/ui/listener.factor"
     "/library/ui/ui.factor"
 ] [
     dup print run-resource

diff --git a/library/ui/panes.factor b/library/ui/panes.factor
index 8ee2fe2a6a434813850b22a160e4dd07e60b59e7..69ad0f68f52f0dee1234b4564bcd41e375e7148f 100644 (file)
--- a/library/ui/panes.factor
+++ b/library/ui/panes.factor
@@ -25,9 +25,6 @@ TUPLE: pane output active current input continuation ;
     [ dup pane-input swap pane-current <active-line> ] keep
     2dup set-pane-active add-gadget ;
 
-: pane-paint ( pane -- )
-    "Monospaced" font set-paint-prop ;
-
 : pop-continuation ( pane -- quot )
     dup pane-continuation f rot set-pane-continuation ;
 
@@ -38,7 +35,7 @@ SYMBOL: structured-input
 
 : elements. ( quot -- )
     [
-        1 nesting-limit set
+        2 nesting-limit set
         5 length-limit set
         <block pprint-elements block> t newline
     ] with-pprint ;
@@ -70,7 +67,6 @@ C: pane ( -- pane )
     <line-shelf> over set-pane-current
     "" <editor> over set-pane-input
     dup init-active-line
-    dup pane-paint
     dup pane-actions ;
 
 M: pane focusable-child* ( pane -- editor )

diff --git a/library/ui/scrolling.factor b/library/ui/scrolling.factor
index 9ddec29cb9ffb722bdc85db545593640dbe1cf1b..a07a8ecbc946d7624e35ae8fc1222da11a2b681a 100644 (file)
--- a/library/ui/scrolling.factor
+++ b/library/ui/scrolling.factor
@@ -7,9 +7,6 @@ threads vectors styles ;
 ! A viewport can be scrolled.
 TUPLE: viewport origin bottom? ;
 
-! A slider scrolls a viewport.
-TUPLE: slider thumb vector ;
-
 ! A scroller combines a viewport with two x and y sliders.
 TUPLE: scroller viewport x y ;
 
@@ -18,9 +15,6 @@ TUPLE: scroller viewport x y ;
 : fix-scroll ( origin viewport -- origin )
     dup rect-dim swap viewport-dim v- vmax { 0 0 0 } vmin ;
 
-: scroll-viewport ( origin viewport -- )
-    [ fix-scroll ] keep [ set-viewport-origin ] keep relayout ;
-
 C: viewport ( content -- viewport )
     <gadget> over set-delegate
     t over set-gadget-root?
@@ -46,86 +40,21 @@ M: viewport layout* ( viewport -- )
 M: viewport focusable-child* ( viewport -- gadget )
     gadget-child ;
 
-: visible-portion ( viewport -- vector )
-    dup rect-dim { 1 1 1 } vmax
-    swap viewport-dim { 1 1 1 } vmax
-    v/ { 1 1 1 } vmin ;
-
-: slider-scroller ( slider -- scroller )
-    [ scroller? ] find-parent ;
-
-: slider-viewport ( slider -- viewport )
-    slider-scroller scroller-viewport ;
-
-: >thumb ( pos slider -- pos )
-    slider-viewport visible-portion v* ;
-
-: >viewport ( pos slider -- pos )
-    slider-viewport visible-portion v/ ;
-
-: slider-current ( slider -- pos )
-    dup slider-viewport viewport-origin*
-    dup rot slider-vector v* v- ;
+: update-slider ( slider scroller -- )
+    dup rect-dim pick slider-vector v. pick set-slider-page
+    dup viewport-dim over rect-dim vmax pick slider-vector v. pick set-slider-max
+    slider-viewport dup viewport-origin over fix-scroll vneg pick slider-vector v. pick set-slider-value
+    drop slider-elevator relayout ;
 
-: slider-pos ( slider pos -- pos )
-    hand pick relative v+ over slider-vector v* swap >viewport ;
+: update-sliders ( scroller -- )
+    dup scroller-x over update-slider
+    dup scroller-y swap update-slider ;
 
 : scroll ( origin scroller -- )
-    [ scroller-viewport scroll-viewport ] keep
-    dup scroller-x relayout scroller-y relayout ;
-
-: slider-click ( slider pos -- )
-    dupd slider-pos over slider-current v+
-    swap slider-scroller scroll ;
-
-: slider-motion ( slider -- )
-    hand hand-click-rel slider-click ;
-
-: thumb-actions ( thumb -- )
-    dup [ drop ] [ button-down 1 ] set-action
-    dup [ drop ] [ button-up 1 ] set-action
-    [ gadget-parent slider-motion ] [ drag 1 ] set-action ;
-
-: <thumb> ( -- thumb )
-    <bevel-gadget>
-    t over set-gadget-root?
-    dup { 192 192 192 } background set-paint-prop
-    dup thumb-actions ;
-
-: add-thumb ( thumb slider -- )
-    2dup add-gadget set-slider-thumb ;
-
-: slider-actions ( slider -- )
-    [ { 0 0 0 } slider-click ] [ button-down 1 ] set-action ;
-
-C: slider ( vector -- slider )
-    <plain-gadget> over set-delegate
-    dup { 128 128 128 } background set-paint-prop
-    [ set-slider-vector ] keep
-    <thumb> over add-thumb
-    dup slider-actions ;
-
-: <x-slider> ( -- slider ) { 1 0 0 } <slider> ;
-
-: <y-slider> ( -- slider ) { 0 1 0 } <slider> ;
-
-: thumb-loc ( slider -- loc )
-    dup slider-viewport
-    dup viewport-origin* swap fix-scroll
-    vneg swap >thumb ;
-
-: slider-dim { 12 12 12 } ;
-
-: thumb-dim ( slider -- h )
-    [ rect-dim dup ] keep >thumb slider-dim vmax vmin ;
-
-M: slider pref-dim drop slider-dim ;
-
-M: slider layout* ( slider -- )
-    dup thumb-loc over slider-vector v*
-    over slider-thumb set-rect-loc
-    dup thumb-dim over slider-vector v* slider-dim vmax
-    swap slider-thumb set-gadget-dim ;
+    [
+        scroller-viewport [ fix-scroll ] keep
+        [ set-viewport-origin ] keep
+    ] keep relayout ;
 
 : add-viewport 2dup set-scroller-viewport add-center ;
 
@@ -134,8 +63,7 @@ M: slider layout* ( slider -- )
 : add-y-slider 2dup set-scroller-y add-right ;
 
 : (scroll>bottom) ( scroller -- )
-    t over scroller-viewport set-viewport-bottom?
-    dup scroller-x relayout scroller-y relayout ;
+    t swap scroller-viewport set-viewport-bottom? ;
 
 : scroll>bottom ( gadget -- )
     [ scroll>bottom ] swap handle-gesture drop ;
@@ -143,10 +71,14 @@ M: slider layout* ( slider -- )
 : scroll-by ( scroller amount -- )
     over scroller-viewport viewport-origin v+ swap scroll ;
 
+: scroll-up-line { 0 32 0 } scroll-by ;
+
+: scroll-down-line { 0 -32 0 } scroll-by ;
+
 : scroller-actions ( scroller -- )
     dup [ (scroll>bottom) ] [ scroll>bottom ] set-action
-    dup [ { 0 32 0 } scroll-by ] [ button-down 4 ] set-action
-    [ { 0 -32 0 } scroll-by ] [ button-down 5 ] set-action ;
+    dup [ scroll-up-line ] [ button-down 4 ] set-action
+    [ scroll-down-line ] [ button-down 5 ] set-action ;
 
 C: scroller ( gadget -- scroller )
     #! Wrap a scrolling pane around the gadget.
@@ -158,3 +90,6 @@ C: scroller ( gadget -- scroller )
 
 M: scroller focusable-child* ( viewport -- gadget )
     scroller-viewport ;
+
+M: scroller layout* ( scroller -- )
+    dup update-sliders delegate layout* ;

diff --git a/library/ui/sliders.factor b/library/ui/sliders.factor
new file mode 100644 (file)
index 0000000..58c670d
--- /dev/null
+++ b/library/ui/sliders.factor
@@ -0,0 +1,95 @@
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: gadgets
+USING: generic kernel lists math matrices namespaces sequences
+threads vectors styles ;
+
+! An elevator has a thumb that may be moved up and down.
+TUPLE: elevator ;
+
+: find-elevator [ elevator? ] find-parent ;
+
+! A slider scrolls a viewport.
+TUPLE: slider vector elevator thumb value max page ;
+
+: find-slider [ slider? ] find-parent ;
+
+: elevator-click ( elevator pos -- )
+    2drop ;
+
+: elevator-motion ( elevator -- )
+    hand hand-click-rel elevator-click ;
+
+: thumb-actions ( thumb -- )
+    dup [ drop ] button-gestures
+    [ find-elevator elevator-motion ] [ drag 1 ] set-action ;
+
+: <thumb> ( -- thumb )
+    <bevel-gadget>
+    t over set-gadget-root?
+    dup button-theme
+    dup thumb-actions ;
+
+: elevator-theme ( elevator -- )
+    dup << solid f >> interior set-paint-prop
+    { 128 128 128 } background set-paint-prop ;
+
+: elevator-actions ( elevator -- )
+    [ { 0 0 0 } elevator-click ] [ button-down 1 ] set-action ;
+
+C: elevator ( -- elevator )
+    <plain-gadget> over set-delegate
+    dup elevator-theme dup elevator-actions ;
+
+: >thumb ( n slider -- n )
+    [ slider-max 1 max / ] keep
+    dup slider-elevator rect-dim swap slider-vector v. * ;
+
+: thumb-loc ( slider -- loc ) dup slider-value swap >thumb ;
+
+: thumb-dim ( slider -- h ) dup slider-page swap >thumb ;
+
+: thumb-min { 12 12 0 } ;
+
+: layout-thumb ( slider -- )
+    dup thumb-loc over slider-vector n*v
+    over slider-thumb set-rect-loc
+    dup thumb-dim over slider-vector n*v thumb-min vmax
+    swap slider-thumb set-rect-dim ;
+
+M: elevator layout* ( elevator -- )
+    find-slider layout-thumb ;
+
+M: elevator pref-dim drop thumb-min ;
+
+: <empty-button> ( quot -- )
+    >r <bevel-gadget> { 12 12 0 } over set-gadget-dim
+    dup button-theme dup r> button-gestures ;
+
+: <up-button> [ drop ] <empty-button> ;
+
+: add-up { 1 1 1 } over slider-vector v- 2unseq set-frame-child ;
+
+: <down-button> [ drop ] <empty-button>  ;
+
+: add-down { 1 1 1 } over slider-vector v+ 2unseq set-frame-child ;
+
+: add-elevator 2dup set-slider-elevator add-center ;
+
+: add-thumb 2dup slider-elevator add-gadget set-slider-thumb ;
+
+C: slider ( vector -- slider )
+    [ set-slider-vector ] keep
+    <frame> over set-delegate
+    0 over set-slider-value
+    0 over set-slider-page
+    0 over set-slider-max
+    <elevator> over add-elevator
+    <up-button> over add-up
+    <down-button> over add-down
+    <thumb> over add-thumb
+    dup slider-actions ;
+
+: <x-slider> ( -- slider ) { 1 0 0 } <slider> ;
+
+: <y-slider> ( -- slider ) { 0 1 0 } <slider> ;

diff --git a/library/ui/ui.factor b/library/ui/ui.factor
index 4c1030eb32be395f163aaceda2f80476edf6a068..4ed7a747af9683f1a5e4304c9266563227d4982f 100644 (file)
--- a/library/ui/ui.factor
+++ b/library/ui/ui.factor
@@ -1,42 +1,22 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: help
-DEFER: <tutorial-button>
-
 IN: gadgets
-USING: generic help io kernel listener math namespaces
-prettyprint sdl sequences styles threads words shells ;
-
-SYMBOL: stack-display
-
-: ui.s ( -- )
-    stack-display get dup pane-clear [ .s ] with-stream* ;
-
-: listener-thread
-    pane get [
-        [ ui.s ] listener-hook set <tutorial-button> gadget. tty
-    ] with-stream* ;
-
-: listener-application
-    <pane> dup pane set <scroller>
-    <pane> dup stack-display set <scroller>
-    5/6 <x-splitter> add-layer
-    [ clear listener-thread ] in-thread
-    pane get request-focus ;
+USING: generic help io kernel listener lists math namespaces
+prettyprint sdl sequences shells styles threads words ;
 
 : init-world
     global [
         <world> world set
-        { 700 800 0 } world get set-gadget-dim
+        { 600 800 0 } world get set-gadget-dim
         
         {{
             [[ background { 255 255 255 } ]]
             [[ rollover-bg { 236 230 232 } ]]
             [[ bevel-1 { 160 160 160 } ]]
-            [[ bevel-2 { 216 216 216 } ]]
+            [[ bevel-2 { 232 232 232 } ]]
             [[ foreground { 0 0 0 } ]]
             [[ reverse-video f ]]
-            [[ font "Sans Serif" ]]
+            [[ font "Monospaced" ]]
             [[ font-size 12 ]]
             [[ font-style plain ]]
         }} world get set-gadget-paint