Simplifying UI code dealing with worlds
slava
parent
89fb79dbdc
commit
fdfcc34621
|
|
@ -169,9 +169,8 @@ vectors words ;
|
|||
"/library/ui/world.factor"
|
||||
"/library/ui/paint.factor"
|
||||
"/library/ui/theme.factor"
|
||||
"/library/ui/gestures.factor"
|
||||
"/library/ui/labels.factor"
|
||||
"/library/ui/hand.factor"
|
||||
"/library/ui/gestures.factor"
|
||||
"/library/ui/frames.factor"
|
||||
"/library/ui/borders.factor"
|
||||
"/library/ui/buttons.factor"
|
||||
|
|
|
|||
|
|
@ -166,16 +166,13 @@ H{ } clone views set-global
|
|||
FactorView over rect-dim <GLView>
|
||||
[ over set-world-handle dup add-notify register-view ] keep ;
|
||||
|
||||
: <FactorWindow> ( gadget title -- window )
|
||||
>r <FactorView> r> <ViewWindow> dup [contentView] [release] ;
|
||||
|
||||
IN: gadgets
|
||||
|
||||
: redraw-world ( handle -- )
|
||||
world-handle 1 [setNeedsDisplay:] ;
|
||||
|
||||
: in-window ( gadget status dim title -- )
|
||||
>r <world> r> <FactorWindow> drop ;
|
||||
: in-window ( world title -- )
|
||||
>r <FactorView> r> <ViewWindow> [contentView] [release] ;
|
||||
|
||||
: select-gl-context ( handle -- )
|
||||
[openGLContext] [makeCurrentContext] ;
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ DEFER: draw-world ! defined in world.factor
|
|||
|
||||
: redraw-world ( world -- ) draw-world ;
|
||||
|
||||
DEFER: in-window ( gadget status dim title -- )
|
||||
DEFER: in-window ( world title -- )
|
||||
|
||||
DEFER: select-gl-context ( handle -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -72,12 +72,12 @@ C: browser ( obj -- browser )
|
|||
|
||||
TUPLE: browser-button object ;
|
||||
|
||||
: in-browser ( obj -- )
|
||||
: browser-window ( obj -- )
|
||||
<browser> "Browser" simple-window ;
|
||||
|
||||
: browser-button-action ( button -- )
|
||||
[ browser-button-object ] keep find-browser
|
||||
[ dup save-current browse ] [ in-browser ] if* ;
|
||||
[ dup save-current browse ] [ browser-window ] if* ;
|
||||
|
||||
C: browser-button ( gadget object -- button )
|
||||
[ set-browser-button-object ] keep
|
||||
|
|
|
|||
|
|
@ -0,0 +1,39 @@
|
|||
! Copyright (C) 2006 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: gadgets
|
||||
USING: gadgets gadgets-labels gadgets-layouts gadgets-theme
|
||||
hashtables kernel math namespaces queues sequences threads ;
|
||||
|
||||
: layout-queued ( -- )
|
||||
invalid dup queue-empty? [
|
||||
drop
|
||||
] [
|
||||
deque dup layout
|
||||
find-world [ dup world-handle set ] when*
|
||||
layout-queued
|
||||
] if ;
|
||||
|
||||
: init-ui ( -- )
|
||||
H{ } clone \ timers set-global
|
||||
<queue> \ invalid set-global ;
|
||||
|
||||
: ui-step ( -- )
|
||||
do-timers
|
||||
[ layout-queued ] make-hash hash-values
|
||||
[ dup world-handle [ draw-world ] [ drop ] if ] each
|
||||
10 sleep ;
|
||||
|
||||
: close-global ( world global -- )
|
||||
dup get-global find-world rot eq?
|
||||
[ f swap set-global ] [ drop ] if ;
|
||||
|
||||
: close-world ( world -- )
|
||||
dup hand-clicked close-global
|
||||
dup hand-gadget close-global
|
||||
f over request-focus* dup remove-notify
|
||||
dup free-fonts f swap set-world-handle ;
|
||||
|
||||
: <status-bar> ( -- gadget ) "" <label> dup highlight-theme ;
|
||||
|
||||
: simple-window ( gadget title -- )
|
||||
>r <status-bar> <world> dup prefer r> in-window ;
|
||||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
! Copyright (C) 2005, 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: gadgets
|
||||
USING: alien generic hashtables kernel lists math sequences ;
|
||||
USING: gadgets-labels gadgets-layouts hashtables kernel math
|
||||
namespaces queues sequences threads ;
|
||||
|
||||
: action ( gadget gesture -- quot )
|
||||
swap gadget-gestures ?hash ;
|
||||
|
|
@ -41,3 +42,111 @@ SYMBOL: mouse-leave
|
|||
|
||||
SYMBOL: lose-focus
|
||||
SYMBOL: gain-focus
|
||||
|
||||
! Hand state
|
||||
|
||||
! Note that these are only really useful inside an event
|
||||
! handler, and that the locations hand-loc and hand-click-loc
|
||||
! are in the co-ordinate system of the world which contains
|
||||
! the gadget in question.
|
||||
SYMBOL: hand-gadget
|
||||
SYMBOL: hand-loc
|
||||
{ 0 0 0 } hand-loc set-global
|
||||
|
||||
SYMBOL: hand-clicked
|
||||
SYMBOL: hand-click-loc
|
||||
|
||||
SYMBOL: hand-buttons
|
||||
V{ } clone hand-buttons set-global
|
||||
|
||||
: button-gesture ( buttons gesture -- )
|
||||
#! Send a gesture like [ button-down 2 ]; if nobody
|
||||
#! handles it, send [ button-down ].
|
||||
swap hand-clicked get-global 3dup >r add r> handle-gesture
|
||||
[ nip handle-gesture drop ] [ 3drop ] if ;
|
||||
|
||||
: drag-gesture ( -- )
|
||||
#! Send a gesture like [ drag 2 ]; if nobody handles it,
|
||||
#! send [ drag ].
|
||||
hand-buttons get-global first [ drag ] button-gesture ;
|
||||
|
||||
: fire-motion ( -- )
|
||||
#! Fire a motion gesture to the gadget underneath the hand,
|
||||
#! and if a mouse button is down, fire a drag gesture to the
|
||||
#! gadget that was clicked.
|
||||
[ motion ] hand-gadget get-global handle-gesture drop
|
||||
hand-buttons get-global empty? [ drag-gesture ] unless ;
|
||||
|
||||
: each-gesture ( gesture seq -- )
|
||||
[ handle-gesture* drop ] each-with ;
|
||||
|
||||
: hand-gestures ( new old -- )
|
||||
drop-prefix reverse-slice
|
||||
[ mouse-leave ] swap each-gesture
|
||||
fire-motion
|
||||
[ mouse-enter ] swap each-gesture ;
|
||||
|
||||
: focus-gestures ( new old -- )
|
||||
drop-prefix reverse-slice
|
||||
[ lose-focus ] swap each-gesture
|
||||
[ gain-focus ] swap each-gesture ;
|
||||
|
||||
: request-focus* ( gadget world -- )
|
||||
dup focused-ancestors >r
|
||||
[ set-world-focus ] keep
|
||||
focused-ancestors r> focus-gestures ;
|
||||
|
||||
: request-focus ( gadget -- )
|
||||
dup focusable-child swap find-world request-focus* ;
|
||||
|
||||
: modifier ( mod modifiers -- seq )
|
||||
[ second swap bitand 0 > ] subset-with
|
||||
[ first ] map ;
|
||||
|
||||
: drag-loc ( -- loc )
|
||||
hand-loc get-global hand-click-loc get-global v- ;
|
||||
|
||||
: hand-click-rel ( gadget -- loc )
|
||||
hand-click-loc get-global relative-loc ;
|
||||
|
||||
: relevant-help ( seq -- help )
|
||||
[ gadget-help ] map [ ] find nip ;
|
||||
|
||||
: show-message ( string/f -- )
|
||||
#! Show a message in the status bar.
|
||||
world-status [ set-label-text* ] [ drop ] if* ;
|
||||
|
||||
: update-help ( -- )
|
||||
#! Update mouse-over help message.
|
||||
hand-gadget get-global parents [ relevant-help ] keep
|
||||
dup empty? [ 2drop ] [ peek show-message ] if ;
|
||||
|
||||
: under-hand ( -- seq )
|
||||
#! A sequence whose first element is the world and last is
|
||||
#! the current gadget, with all parents in between.
|
||||
hand-gadget get-global parents reverse-slice ;
|
||||
|
||||
: move-hand ( loc world -- )
|
||||
under-hand >r over hand-loc set-global
|
||||
pick-up hand-gadget set-global
|
||||
under-hand r> hand-gestures update-help ;
|
||||
|
||||
: update-clicked ( loc world -- )
|
||||
move-hand
|
||||
hand-gadget get-global hand-clicked set-global
|
||||
hand-loc get-global hand-click-loc set-global ;
|
||||
|
||||
: send-button-down ( button# loc world -- )
|
||||
update-clicked
|
||||
dup hand-buttons get-global push
|
||||
[ button-down ] button-gesture ;
|
||||
|
||||
: send-button-up ( event loc world -- )
|
||||
move-hand
|
||||
dup hand-buttons get-global delete
|
||||
[ button-up ] button-gesture ;
|
||||
|
||||
: send-wheel ( up/down loc world -- )
|
||||
move-hand
|
||||
[ wheel-up ] [ wheel-down ] ?
|
||||
hand-gadget get-global handle-gesture drop ;
|
||||
|
|
|
|||
|
|
@ -1,142 +0,0 @@
|
|||
! Copyright (C) 2005, 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: gadgets
|
||||
USING: gadgets-labels gadgets-layouts hashtables kernel math
|
||||
namespaces queues sequences threads ;
|
||||
|
||||
! Hand state
|
||||
|
||||
! Note that these are only really useful inside an event
|
||||
! handler, and that the locations hand-loc and hand-click-loc
|
||||
! are in the co-ordinate system of the world which contains
|
||||
! the gadget in question.
|
||||
SYMBOL: hand-gadget
|
||||
SYMBOL: hand-loc
|
||||
{ 0 0 0 } hand-loc set-global
|
||||
|
||||
SYMBOL: hand-clicked
|
||||
SYMBOL: hand-click-loc
|
||||
|
||||
SYMBOL: hand-buttons
|
||||
V{ } clone hand-buttons set-global
|
||||
|
||||
: button-gesture ( buttons gesture -- )
|
||||
#! Send a gesture like [ button-down 2 ]; if nobody
|
||||
#! handles it, send [ button-down ].
|
||||
swap hand-clicked get-global 3dup >r add r> handle-gesture
|
||||
[ nip handle-gesture drop ] [ 3drop ] if ;
|
||||
|
||||
: drag-gesture ( -- )
|
||||
#! Send a gesture like [ drag 2 ]; if nobody handles it,
|
||||
#! send [ drag ].
|
||||
hand-buttons get-global first [ drag ] button-gesture ;
|
||||
|
||||
: fire-motion ( -- )
|
||||
#! Fire a motion gesture to the gadget underneath the hand,
|
||||
#! and if a mouse button is down, fire a drag gesture to the
|
||||
#! gadget that was clicked.
|
||||
[ motion ] hand-gadget get-global handle-gesture drop
|
||||
hand-buttons get-global empty? [ drag-gesture ] unless ;
|
||||
|
||||
: each-gesture ( gesture seq -- )
|
||||
[ handle-gesture* drop ] each-with ;
|
||||
|
||||
: hand-gestures ( new old -- )
|
||||
drop-prefix reverse-slice
|
||||
[ mouse-leave ] swap each-gesture
|
||||
fire-motion
|
||||
[ mouse-enter ] swap each-gesture ;
|
||||
|
||||
: focus-gestures ( new old -- )
|
||||
drop-prefix reverse-slice
|
||||
[ lose-focus ] swap each-gesture
|
||||
[ gain-focus ] swap each-gesture ;
|
||||
|
||||
: request-focus* ( gadget world -- )
|
||||
dup focused-ancestors >r
|
||||
[ set-world-focus ] keep
|
||||
focused-ancestors r> focus-gestures ;
|
||||
|
||||
: request-focus ( gadget -- )
|
||||
dup focusable-child swap find-world request-focus* ;
|
||||
|
||||
: modifier ( mod modifiers -- seq )
|
||||
[ second swap bitand 0 > ] subset-with
|
||||
[ first ] map ;
|
||||
|
||||
: drag-loc ( -- loc )
|
||||
hand-loc get-global hand-click-loc get-global v- ;
|
||||
|
||||
: hand-click-rel ( gadget -- loc )
|
||||
hand-click-loc get-global relative-loc ;
|
||||
|
||||
: relevant-help ( seq -- help )
|
||||
[ gadget-help ] map [ ] find nip ;
|
||||
|
||||
: show-message ( string/f -- )
|
||||
#! Show a message in the status bar.
|
||||
world-status [ set-label-text* ] [ drop ] if* ;
|
||||
|
||||
: update-help ( -- )
|
||||
#! Update mouse-over help message.
|
||||
hand-gadget get-global parents [ relevant-help ] keep
|
||||
dup empty? [ 2drop ] [ peek show-message ] if ;
|
||||
|
||||
: under-hand ( -- seq )
|
||||
#! A sequence whose first element is the world and last is
|
||||
#! the current gadget, with all parents in between.
|
||||
hand-gadget get-global parents reverse-slice ;
|
||||
|
||||
: move-hand ( loc world -- )
|
||||
under-hand >r over hand-loc set-global
|
||||
pick-up hand-gadget set-global
|
||||
under-hand r> hand-gestures update-help ;
|
||||
|
||||
: update-clicked ( loc world -- )
|
||||
move-hand
|
||||
hand-gadget get-global hand-clicked set-global
|
||||
hand-loc get-global hand-click-loc set-global ;
|
||||
|
||||
: send-button-down ( button# loc world -- )
|
||||
update-clicked
|
||||
dup hand-buttons get-global push
|
||||
[ button-down ] button-gesture ;
|
||||
|
||||
: send-button-up ( event loc world -- )
|
||||
move-hand
|
||||
dup hand-buttons get-global delete
|
||||
[ button-up ] button-gesture ;
|
||||
|
||||
: send-wheel ( up/down loc world -- )
|
||||
move-hand
|
||||
[ wheel-up ] [ wheel-down ] ?
|
||||
hand-gadget get-global handle-gesture drop ;
|
||||
|
||||
: layout-queued ( -- )
|
||||
invalid dup queue-empty? [
|
||||
drop
|
||||
] [
|
||||
deque dup layout
|
||||
find-world [ dup world-handle set ] when*
|
||||
layout-queued
|
||||
] if ;
|
||||
|
||||
: init-ui ( -- )
|
||||
H{ } clone \ timers set-global
|
||||
<queue> \ invalid set-global ;
|
||||
|
||||
: ui-step ( -- )
|
||||
do-timers
|
||||
[ layout-queued ] make-hash hash-values
|
||||
[ dup world-handle [ draw-world ] [ drop ] if ] each
|
||||
10 sleep ;
|
||||
|
||||
: close-global ( world global -- )
|
||||
dup get-global find-world rot eq?
|
||||
[ f swap set-global ] [ drop ] if ;
|
||||
|
||||
: close-world ( world -- )
|
||||
dup hand-clicked close-global
|
||||
dup hand-gadget close-global
|
||||
f over request-focus* dup remove-notify
|
||||
dup free-fonts f swap set-world-handle ;
|
||||
|
|
@ -98,5 +98,3 @@ IN: gadgets-layouts
|
|||
: make-pile ( children -- pack ) <pile> [ add-gadgets ] keep ;
|
||||
|
||||
: make-shelf ( children -- pack ) <shelf> [ add-gadgets ] keep ;
|
||||
|
||||
: make-stack ( children -- pack ) <stack> [ add-gadgets ] keep ;
|
||||
|
|
|
|||
|
|
@ -17,15 +17,13 @@ C: label ( text -- label )
|
|||
2dup label-text =
|
||||
[ 2dup [ set-label-text ] keep relayout ] unless 2drop ;
|
||||
|
||||
: label-font* ( label -- font )
|
||||
label-font lookup-font ;
|
||||
: label-font* ( label -- font ) label-font lookup-font ;
|
||||
|
||||
: label-size ( gadget text -- dim )
|
||||
dup label-font* dup font-height >r
|
||||
swap label-text string-width r> 0 3array ;
|
||||
|
||||
M: label pref-dim* ( label -- dim )
|
||||
label-size ;
|
||||
M: label pref-dim* ( label -- dim ) label-size ;
|
||||
|
||||
: draw-label ( label -- )
|
||||
dup label-color gl-color
|
||||
|
|
|
|||
|
|
@ -13,10 +13,10 @@ namespaces sequences ;
|
|||
make-pane <scroller> "Scratch" simple-window ;
|
||||
|
||||
: handbook-window ( -- )
|
||||
T{ link f "handbook" } in-browser ;
|
||||
T{ link f "handbook" } browser-window ;
|
||||
|
||||
: tutorial-window ( -- )
|
||||
T{ link f "tutorial" } in-browser ;
|
||||
T{ link f "tutorial" } browser-window ;
|
||||
|
||||
: default-launchpad
|
||||
{
|
||||
|
|
@ -24,7 +24,7 @@ namespaces sequences ;
|
|||
{ "Documentation" [ handbook-window ] }
|
||||
{ "Tutorial" [ tutorial-window ] }
|
||||
{ "Vocabularies" [ [ vocabs. ] scratch-window ] }
|
||||
{ "Globals" [ global in-browser ] }
|
||||
{ "Globals" [ global browser-window ] }
|
||||
{ "Memory" [ [ heap-stats. terpri room. ] scratch-window ] }
|
||||
{ "Save image" [ save ] }
|
||||
{ "Exit" [ 0 exit ] }
|
||||
|
|
|
|||
|
|
@ -142,12 +142,3 @@ M: pack children-on ( rect pack -- list )
|
|||
>r >r rect-loc r> r> fast-children-on 0 max
|
||||
r>
|
||||
] keep <slice> ;
|
||||
|
||||
TUPLE: stack ;
|
||||
|
||||
C: stack ( -- gadget )
|
||||
#! A stack lays out all its children on top of each other.
|
||||
{ 0 0 1 } over delegate>pack 1 over set-pack-fill ;
|
||||
|
||||
M: stack children-on ( point stack -- gadget )
|
||||
nip gadget-children ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
! Copyright (C) 2005, 2006 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: gadgets-listener
|
||||
USING: arrays gadgets gadgets-editors gadgets-labels
|
||||
gadgets-layouts gadgets-panes gadgets-scrolling
|
||||
|
|
@ -7,7 +7,7 @@ gadgets-splitters gadgets-theme generic hashtables
|
|||
io jedit kernel listener lists math
|
||||
namespaces parser prettyprint sequences threads words ;
|
||||
|
||||
TUPLE: listener-gadget pane stack status ;
|
||||
TUPLE: listener-gadget pane stack ;
|
||||
|
||||
: usable-words ( -- words )
|
||||
use get hash-concat hash-values ;
|
||||
|
|
@ -38,21 +38,20 @@ TUPLE: listener-gadget pane stack status ;
|
|||
print-banner listener
|
||||
] with-stream* ;
|
||||
|
||||
: <status-bar> ( -- gadget ) "" <label> dup highlight-theme ;
|
||||
|
||||
: <stack-bar> ( -- gadget ) <shelf> dup highlight-theme ;
|
||||
|
||||
: start-listener ( listener -- )
|
||||
[ >r clear r> listener-thread ] in-thread ;
|
||||
|
||||
C: listener-gadget ( -- gadget )
|
||||
dup delegate>frame
|
||||
<input-pane> dup pick set-listener-gadget-pane
|
||||
<scroller> over @center frame-add
|
||||
<status-bar> dup pick set-listener-gadget-status
|
||||
over @bottom frame-add
|
||||
<stack-bar> dup pick set-listener-gadget-stack
|
||||
over @top frame-add ;
|
||||
over @top frame-add
|
||||
dup start-listener ;
|
||||
|
||||
M: listener-gadget pref-dim* drop { 600 600 0 } ;
|
||||
|
||||
: listener-window ( -- )
|
||||
<listener-gadget> dup dup listener-gadget-status
|
||||
{ 600 700 0 } "Listener" in-window
|
||||
[ >r clear r> listener-thread ] in-thread
|
||||
listener-gadget-pane request-focus ;
|
||||
<listener-gadget> "Listener" simple-window ;
|
||||
|
|
|
|||
|
|
@ -19,13 +19,15 @@ TUPLE: world status focus fonts handle ;
|
|||
: font-sprites ( font world -- sprites )
|
||||
world-fonts [ drop V{ } clone ] cache ;
|
||||
|
||||
C: world ( gadget status dim -- world )
|
||||
<stack> over set-delegate
|
||||
: add-status ( status world -- )
|
||||
[ set-world-status ] 2keep @bottom frame-add ;
|
||||
|
||||
C: world ( gadget status -- world )
|
||||
dup delegate>frame
|
||||
t over set-gadget-root?
|
||||
H{ } clone over set-world-fonts
|
||||
[ set-gadget-dim ] keep
|
||||
[ set-world-status ] keep
|
||||
[ add-gadget ] keep ;
|
||||
[ add-status ] keep
|
||||
[ @center frame-add ] keep ;
|
||||
|
||||
GENERIC: find-world ( gadget -- world )
|
||||
|
||||
|
|
@ -35,8 +37,8 @@ M: gadget find-world gadget-parent find-world ;
|
|||
|
||||
M: world find-world ;
|
||||
|
||||
M: world pref-dim* ( world -- dim )
|
||||
delegate pref-dim* { 1024 768 0 } vmin ;
|
||||
|
||||
: focused-ancestors ( world -- seq )
|
||||
world-focus parents reverse-slice ;
|
||||
|
||||
: simple-window ( gadget title -- )
|
||||
>r f over pref-dim { 800 800 0 } vmin r> in-window ;
|
||||
|
|
|
|||
|
|
@ -110,8 +110,7 @@ M: world client-event ( event world -- )
|
|||
|
||||
IN: gadgets
|
||||
|
||||
: in-window ( gadget status dim title -- )
|
||||
>r <world> gadget-window r> swap set-title ;
|
||||
: in-window ( world title -- ) swap gadget-window set-title ;
|
||||
|
||||
: select-gl-context ( handle -- )
|
||||
dpy get swap first2 glXMakeCurrent
|
||||
|
|
|
|||
Loading…
Reference in New Issue