namespaces opengl opengl.textures sequences io combinators
combinators.short-circuit fry math.vectors math.rectangles cache
ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
-ui.commands ui.pixel-formats destructors ;
+ui.commands ui.pixel-formats destructors literals ;
IN: ui.gadgets.worlds
+CONSTANT: default-world-pixel-format-attributes
+ { windowed double-buffered T{ depth-bits { value 16 } } }
+
TUPLE: world < track
-active? focused?
-layers
-title status status-owner
-text-handle handle images
-window-loc ;
+ active? focused?
+ layers
+ title status status-owner
+ text-handle handle images
+ window-loc
+ pixel-format-attributes ;
+
+TUPLE: world-attributes
+ { world-class initial: world }
+ title
+ status
+ gadgets
+ { pixel-format-attributes initial: $ default-world-pixel-format-attributes } ;
+C: <world-attributes> world-attributes
: find-world ( gadget -- world/f ) [ world? ] find-parent ;
2dup eq?
[ 2drop ] [ dup focused?>> (request-focus) ] if ;
-: new-world ( gadget title status class -- world )
+: new-world ( class -- world )
vertical swap new-track
t >>root?
t >>active?
- { 0 0 } >>window-loc
- swap >>status
- swap >>title
- swap 1 track-add
+ { 0 0 } >>window-loc ;
+
+: apply-world-attributes ( world attributes -- world )
+ {
+ [ title>> >>title ]
+ [ status>> >>status ]
+ [ pixel-format-attributes>> >>pixel-format-attributes ]
+ [ gadgets>> [ 1 track-add ] each ]
+ } cleave ;
+
+: <world> ( world-attributes -- world )
+ [ world-class>> new-world ] keep apply-world-attributes
dup request-focus ;
-: <world> ( gadget title status -- world )
- world new-world ;
-
: as-big-as-possible ( world gadget -- )
dup [ { 0 0 } >>loc over dim>> >>dim ] when 2drop ; inline
flush-layout-cache-hook [ [ ] ] initialize
-: (draw-world) ( world -- )
+GENERIC: begin-world ( world -- )
+GENERIC: end-world ( world -- )
+
+M: world begin-world
+ drop ;
+M: world end-world
+ drop ;
+
+GENERIC: draw-world* ( world -- )
+
+M: world draw-world*
dup handle>> [
check-extensions
{
: draw-world ( world -- )
dup draw-world? [
dup world [
- [ (draw-world) ] [
+ [ draw-world* ] [
over <world-error> ui-error
f >>active? drop
] recover
[ get-global find-world eq? ] keep '[ f _ set-global ] when ;
M: world world-pixel-format-attributes
- drop
- { windowed double-buffered T{ depth-bits { value 16 } } } ;
+ pixel-format-attributes>> ;
M: world check-world-pixel-format
2drop ;
: with-world-pixel-format ( world quot -- )
[ dup dup world-pixel-format-attributes <pixel-format> ]
dip [ 2dup check-world-pixel-format ] prepose with-disposal ; inline
+
deques sequences threads sequences words continuations init
combinators combinators.short-circuit hashtables concurrency.flags
sets accessors calendar fry destructors ui.gadgets ui.gadgets.private
-ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render ;
+ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render
+strings ;
IN: ui
<PRIVATE
f >>focused?
focus-path f swap focus-gestures ;
-M: world graft*
+: try-to-open-window ( world -- )
[ (open-window) ]
+ [ handle>> select-gl-context ]
+ [
+ [ begin-world ]
+ [ [ handle>> (close-window) ] [ ui-error ] bi* ]
+ recover
+ ] tri ;
+
+M: world graft*
+ [ try-to-open-window ]
[ [ title>> ] keep set-title ]
[ request-focus ] tri ;
[ images>> [ dispose ] when* ]
[ hand-clicked close-global ]
[ hand-gadget close-global ]
+ [ end-world ]
} cleave ;
M: world ungraft*
: restore-windows? ( -- ? )
windows get empty? not ;
+: ?attributes ( gadget title/attributes -- attributes )
+ dup string? [ world-attributes new swap >>title ] when
+ swap [ [ [ 1array ] [ f ] if* ] curry unless* ] curry change-gadgets ;
+
PRIVATE>
: open-world-window ( world -- )
dup pref-dim >>dim dup relayout graft ;
-: open-window ( gadget title -- )
- f <world> open-world-window ;
+: open-window ( gadget title/attributes -- )
+ ?attributes <world> open-world-window ;
: set-fullscreen? ( ? gadget -- )
find-world set-fullscreen* ;