---\r
\r
- i/o: don't keep creating new sbufs\r
-- rollovers broken with menus\r
-- menu dragging\r
-- fix up the min thumb size hack\r
-- gaps in pack layout\r
- fix listener prompt display after presentation commands invoked\r
- theme abstraction in ui\r
\r
+ ui:\r
\r
+- menu dragging\r
+- fix up the min thumb size hack\r
+- gaps in pack layout\r
- find out why so many small bignums get consed\r
- repaint only dirty regions of the screen\r
- faster mouse tracking\r
<book-browser> ;\r
\r
: tutorial ( -- )\r
- ensure-ui <tutorial> gadget. ;\r
+ <tutorial> gadget. ;\r
SYMBOL: drag
SYMBOL: button-up
SYMBOL: button-down
+SYMBOL: mouse-enter
+SYMBOL: mouse-leave
-: hierarchy-gesture ( gadget ? gesture -- ? )
- swap [ 2drop f ] [ swap handle-gesture* drop t ] ifte ;
-
-: mouse-enter ( point gadget -- )
- #! If the old point is inside the new gadget, do not fire an
- #! enter gesture, since the mouse did not enter. Otherwise,
- #! fire an enter gesture and go on to the parent.
- [
- [ rectangle-loc v+ ] keep
- 2dup inside? [ mouse-enter ] hierarchy-gesture
- ] each-parent 2drop ;
-
-: mouse-leave ( point gadget -- )
- #! If the new point is inside the old gadget, do not fire a
- #! leave gesture, since the mouse did not leave. Otherwise,
- #! fire a leave gesture and go on to the parent.
- [
- [ rectangle-loc v+ ] keep
- 2dup inside? [ mouse-leave ] hierarchy-gesture
- ] each-parent 2drop ;
-
-: lose-focus ( new old -- )
- #! If the old focus owner is a child of the new owner, do
- #! not fire a focus lost gesture, since the focus was not
- #! lost. Otherwise, fire a focus lost gesture and go to the
- #! parent.
- [
- 2dup child? [ lose-focus ] hierarchy-gesture
- ] each-parent 2drop ;
-
-: gain-focus ( old new -- )
- #! If the old focus owner is a child of the new owner, do
- #! not fire a focus gained gesture, since the focus was not
- #! gained. Otherwise, fire a focus gained gesture and go on
- #! to the parent.
- [
- 2dup child? [ gain-focus ] hierarchy-gesture
- ] each-parent 2drop ;
+SYMBOL: lose-focus
+SYMBOL: gain-focus
: button\ ( n hand -- )
[ hand-buttons remove ] keep set-hand-buttons ;
-: fire-leave ( hand gadget -- )
- [ swap rectangle-loc swap screen-loc v- ] keep mouse-leave ;
-
-: fire-enter ( oldpos hand -- )
- hand-gadget [ screen-loc v- ] keep mouse-enter ;
-
-: update-hand-gadget ( hand -- )
- [ rectangle-loc world get pick-up ] keep set-hand-gadget ;
-
-: motion-gesture ( hand gadget gesture -- )
+: drag-gesture ( hand gadget gesture -- )
#! Send a gesture like [ drag 2 ].
rot hand-buttons car add swap handle-gesture drop ;
#! gadget that was clicked.
[ motion ] over hand-gadget handle-gesture drop
dup hand-buttons
- [ dup hand-clicked [ drag ] motion-gesture ] [ drop ] ifte ;
+ [ dup hand-clicked [ drag ] drag-gesture ] [ drop ] ifte ;
+
+: drop-prefix ( l1 l2 -- l1 l2 )
+ 2dup and [ 2dup 2car eq? [ 2cdr drop-prefix ] when ] when ;
+
+: each-gesture ( gesture seq -- )
+ [ handle-gesture* drop ] each-with ;
+
+: hand-gestures ( hand new old -- )
+ drop-prefix
+ reverse [ mouse-leave ] swap each-gesture
+ swap fire-motion
+ [ mouse-enter ] swap each-gesture ;
: move-hand ( loc hand -- )
- dup rectangle-loc >r
- [ set-rectangle-loc ] keep
- dup hand-gadget >r
- dup update-hand-gadget
- dup r> fire-leave
- dup fire-motion
- r> swap fire-enter ;
+ dup hand-gadget parents-down >r
+ 2dup set-rectangle-loc
+ [ >r world get pick-up r> set-hand-gadget ] keep
+ dup hand-gadget parents-down r> hand-gestures ;
: update-hand ( hand -- )
#! Called when a gadget is removed or added.
dup rectangle-loc swap move-hand ;
+: focus-gestures ( new old -- )
+ drop-prefix
+ reverse [ lose-focus ] swap each-gesture
+ [ gain-focus ] swap each-gesture ;
+
: request-focus ( gadget -- )
focusable-child
- hand hand-focus
- 2dup lose-focus
- swap dup hand set-hand-focus
- gain-focus ;
+ hand dup hand-focus parents-down >r
+ dupd set-hand-focus parents-down r> focus-gestures ;
#! Add a gadget to a parent gadget.
[ (add-gadget) ] keep relayout ;
-: parents ( gadget -- list )
+: (parents-down) ( list gadget -- list )
+ [ [ swons ] keep gadget-parent (parents-down) ] when* ;
+
+: parents-down ( gadget -- list )
+ #! A list of all parents of the gadget, the last element
+ #! is the gadget itself.
+ f swap (parents-down) ;
+
+: parents-up ( gadget -- list )
#! A list of all parents of the gadget, the first element
#! is the gadget itself.
- dup [ dup gadget-parent parents cons ] when ;
+ dup [ dup gadget-parent parents-up cons ] when ;
: each-parent ( gadget quot -- ? )
- >r parents r> all? ; inline
+ >r parents-up r> all? ; inline
: find-parent ( gadget quot -- ? )
- >r parents r> find nip ; inline
+ >r parents-up r> find nip ; inline
: screen-loc ( gadget -- point )
#! The position of the gadget on the screen.
- parents { 0 0 0 } [ rectangle-loc v+ ] reduce ;
+ parents-up { 0 0 0 } [ rectangle-loc v+ ] reduce ;
: relative ( g1 g2 -- g2-g1 )
screen-loc swap screen-loc v- ;
: child? ( parent child -- ? )
- dup [
- 2dup eq? [ 2drop t ] [ gadget-parent child? ] ifte
- ] [
- 2drop f
- ] ifte ;
+ parents-down memq? ;
[ 2nip ] [ drop <styled-label> dup init-commands ] ifte ;
: gadget. ( gadget -- )
- gadget swons unit "" swap write-attr terpri ;
+ gadget swons unit
+ "This stream does not support live gadgets"
+ swap write-attr terpri ;
[ drop t ] "Prettyprint" [ prettyprint ] define-command
[ drop t ] "Inspect" [ inspect ] define-command
[ drop t ] "References" [ references inspect ] define-command
[ word? ] "See" [ see ] define-command
-[ word? ] "Execute" [ execute ] define-command
[ word? ] "Usage" [ usage . ] define-command
[ word? ] "jEdit" [ jedit ] define-command
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 ;
+
: viewport-dim gadget-child pref-dim ;
: fix-scroll ( origin viewport -- origin )
swap viewport-dim { 1 1 1 } vmax
v/ { 1 1 1 } vmin ;
-! A slider scrolls a viewport.
-
-! The offset slot is the y co-ordinate of the mouse relative to
-! the thumb when it was clicked.
-TUPLE: slider thumb vector ;
-
: slider-scroller ( slider -- scroller )
[ scroller? ] find-parent ;
dup thumb-dim over slider-vector v* slider-dim vmax
swap slider-thumb set-gadget-dim ;
-TUPLE: scroller viewport x y ;
-
: add-viewport 2dup set-scroller-viewport add-center ;
: add-x-slider 2dup set-scroller-x add-bottom ;
TUPLE: world running? hand glass invalid ;
DEFER: <hand>
+DEFER: update-hand
C: world ( -- world )
f <stack> over set-delegate
- t over set-world-running?
t over set-gadget-root?
dup <hand> over set-world-hand ;
: world-step ( -- ? )
world get dup world-invalid >r layout-world r>
- [ hand update-hand draw-world ] [ drop ] ifte ;
+ [ dup world-hand update-hand draw-world ] [ drop ] ifte ;
: next-event ( -- event ? )
<event> dup SDL_PollEvent ;
world get world-running? [ yield run-world ] when
] ifte ;
-: ensure-ui ( -- )
- #! Raise an error if the UI is not running.
- world get dup [ world-running? ] when [
- "UI not running." throw
- ] unless ;
-
: start-world ( -- )
world get t over set-world-running? relayout ;