: gadget-copy ( gadget clipboard -- )
over gadget-selection?
- [ >r [ gadget-selection ] keep r> copy-clipboard ]
+ [ [ [ gadget-selection ] keep ] dip copy-clipboard ]
[ 2drop ]
if ;
cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
cocoa.windows cocoa.classes cocoa.application sequences system
ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
-ui.cocoa.views core-foundation threads math.geometry.rect ;
+ui.cocoa.views core-foundation threads math.geometry.rect fry ;
IN: ui.cocoa
TUPLE: handle view window ;
SINGLETON: cocoa-ui-backend
M: cocoa-ui-backend do-events ( -- )
- [ NSApp [ do-event ] curry loop ui-wait ] with-autorelease-pool ;
+ [ NSApp '[ _ do-event ] loop ui-wait ] with-autorelease-pool ;
TUPLE: pasteboard handle ;
}
{ "application:openFiles:" "void" { "id" "SEL" "id" "id" }
- [ >r 3drop r> finder-run-files ]
+ [ [ 3drop ] dip finder-run-files ]
}
{ "newFactorWorkspace:" "id" { "id" "SEL" "id" }
IN: ui.cocoa.views
: send-mouse-moved ( view event -- )
- over >r mouse-location r> window move-hand fire-motion ;
+ [ mouse-location ] [ drop window ] 2bi move-hand fire-motion ;
: button ( event -- n )
#! Cocoa -> Factor UI button mapping
mouse-location rot window send-button-up ;
: send-wheel$ ( view event -- )
- over >r
- dup -> deltaX sgn neg over -> deltaY sgn neg 2array -rot
- mouse-location
- r> window send-wheel ;
+ [
+ dup -> deltaX sgn neg over -> deltaY sgn neg 2array -rot
+ mouse-location
+ ] [ drop window ] 2bi send-wheel ;
: send-action$ ( view event gesture -- junk )
- >r drop window r> send-action f ;
+ [ drop window ] dip send-action f ;
: add-resize-observer ( observer object -- )
- >r "updateFactorGadgetSize:"
- "NSViewFrameDidChangeNotification" <NSString>
- r> add-observer ;
+ [
+ "updateFactorGadgetSize:"
+ "NSViewFrameDidChangeNotification" <NSString>
+ ] dip add-observer ;
: string-or-nil? ( NSString -- ? )
[ CF>string NSStringPboardType = ] [ t ] if* ;
] if ;
: NSRect>rect ( NSRect world -- rect )
- >r dup NSRect-x over NSRect-y r>
+ [ dup NSRect-x over NSRect-y ] dip
rect-dim second swap - 2array
over NSRect-w rot NSRect-h 2array
<rect> ;
{ "validRequestorForSendType:returnType:" "id" { "id" "SEL" "id" "id" }
[
! We return either self or nil
- >r >r over window-focus r> r>
+ [ over window-focus ] 2dip
valid-service? [ drop ] [ 2drop f ] if
]
}
{ "readSelectionFromPasteboard:" "char" { "id" "SEL" "id" }
[
pasteboard-string dup [
- >r drop window-focus r> swap user-input 1
+ [ drop window-focus ] dip swap user-input 1
] [
3drop 0
] if
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions kernel sequences strings
math assocs words generic namespaces make assocs quotations
-splitting ui.gestures unicode.case unicode.categories tr ;
+splitting ui.gestures unicode.case unicode.categories tr fry ;
IN: ui.commands
SYMBOL: +nullary+
[
commands>>
[ drop ] assoc-filter
- [ [ invoke-command ] curry swap set ] assoc-each
+ [ '[ _ invoke-command ] swap set ] assoc-each
] each
] H{ } make-assoc ;
freetype drop open-fonts get [ <font> ] cache ;
: load-glyph ( font char -- glyph )
- >r handle>> dup r> 0 FT_Load_Char
+ [ handle>> dup ] dip 0 FT_Load_Char
freetype-error face-glyph ;
: char-width ( open-font char -- w )
bi 2array ;
: <char-sprite> ( open-font char -- sprite )
- over >r render-glyph dup r> glyph-texture-loc
+ over [ render-glyph dup ] dip glyph-texture-loc
over glyph-size pick glyph-texture-size <sprite>
[ bitmap>texture ] keep [ init-sprite ] keep ;
fonts>> [ open-font H{ } clone 2array ] cache first2 ;
M: freetype-renderer draw-string ( font string loc -- )
- >r >r world get font-sprites r> r> (draw-string) ;
+ [ world get font-sprites ] 2dip (draw-string) ;
: run-char-widths ( open-font string -- widths )
char-widths [ scan-sums ] [ 2 v/n ] bi v+ ;
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences models ui.gadgets math.geometry.rect ;
+USING: accessors kernel sequences models ui.gadgets
+math.geometry.rect fry ;
IN: ui.gadgets.books
TUPLE: book < gadget ;
M: book pref-dim* ( book -- dim ) children>> pref-dims max-dim ;
M: book layout* ( book -- )
- [ children>> ] [ dim>> ] bi [ >>dim drop ] curry each ;
+ [ children>> ] [ dim>> ] bi '[ _ >>dim drop ] each ;
M: book focusable-child* ( book -- child/t ) current-page ;
USING: accessors arrays hashtables kernel models math namespaces
make sequences quotations math.vectors combinators sorting
binary-search vectors dlists deques models threads
-concurrency.flags math.order math.geometry.rect ;
+concurrency.flags math.order math.geometry.rect fry ;
IN: ui.gadgets
SYMBOL: ui-notify-flag
2dup eq? [
2drop { 0 0 }
] [
- over rect-loc >r
- >r parent>> r> relative-loc
- r> v+
+ over rect-loc [ [ parent>> ] dip relative-loc ] dip v+
] if ;
GENERIC: user-input* ( str gadget -- ? )
[ swap loc>> v- ] dip v. 0 <=> ;
: (fast-children-on) ( dim axis children -- i )
- -rot [ ((fast-children-on)) ] 2curry search drop ;
+ -rot '[ _ _ ((fast-children-on)) ] search drop ;
: fast-children-on ( rect axis children -- from to )
[ [ rect-loc ] 2dip (fast-children-on) 0 or ]
: dim-sum ( seq -- dim ) { 0 0 } [ v+ ] reduce ;
: orient ( gadget seq1 seq2 -- seq )
- >r >r orientation>> r> r> [ pick set-axis ] 2map nip ;
+ rot orientation>> '[ [ _ ] 2dip set-axis ] 2map ;
: each-child ( gadget quot -- )
- >r children>> r> each ; inline
+ [ children>> ] dip each ; inline
! Selection protocol
GENERIC: gadget-selection? ( gadget -- ? )
[ parent>> ] follow ;
: each-parent ( gadget quot -- ? )
- >r parents r> all? ; inline
+ [ parents ] dip all? ; inline
: find-parent ( gadget quot -- parent )
- >r parents r> find nip ; inline
+ [ parents ] dip find nip ; inline
: screen-loc ( gadget -- loc )
parents { 0 0 } [ rect-loc v+ ] reduce ;
: (screen-rect) ( gadget -- loc ext )
dup parent>> [
- >r rect-extent r> (screen-rect)
- >r tuck v+ r> vmin >r v+ r>
+ [ rect-extent ] dip (screen-rect)
+ [ tuck v+ ] dip vmin [ v+ ] dip
] [
rect-extent
] if* ;
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors math namespaces opengl opengl.gl sequences
-math.vectors ui.gadgets ui.gadgets.grids ui.render math.geometry.rect ;
+USING: kernel accessors math namespaces opengl opengl.gl
+sequences math.vectors ui.gadgets ui.gadgets.grids ui.render
+math.geometry.rect fry ;
IN: ui.gadgets.grid-lines
TUPLE: grid-lines color ;
: draw-grid-lines ( gaps orientation -- )
[ grid get swap grid-positions grid get rect-dim suffix ] dip
- [ [ v- ] curry map ] keep
- [ swap grid-line-from/to gl-line ] curry each ;
+ [ '[ _ v- ] map ] keep
+ '[ _ swap grid-line-from/to gl-line ] each ;
M: grid-lines draw-boundary
color>> gl-color [
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces make sequences words io
io.streams.string math.vectors ui.gadgets columns accessors
-math.geometry.rect locals ;
+math.geometry.rect locals fry ;
IN: ui.gadgets.grids
TUPLE: grid < gadget
dupd add-gaps dim-sum v+ ;
M: grid pref-dim*
- dup gap>> swap compute-grid >r over r>
- gap-sum >r gap-sum r> (pair-up) ;
+ dup gap>> swap compute-grid [ over ] dip
+ [ gap-sum ] 2bi@ (pair-up) ;
: do-grid ( dims grid quot -- )
- -rot grid>>
- [ [ pick call ] 2each ] 2each
- drop ; inline
+ [ grid>> ] dip '[ _ 2each ] 2each ; inline
: grid-positions ( grid dims -- locs )
- >r gap>> dup r> add-gaps swap [ v+ ] accumulate nip ;
+ [ gap>> dup ] dip add-gaps swap [ v+ ] accumulate nip ;
: position-grid ( grid horiz vert -- )
- pick >r
- >r over r> grid-positions >r grid-positions r>
- pair-up r> [ (>>loc) ] do-grid ;
+ pick [ [ over ] dip [ grid-positions ] 2bi@ pair-up ] dip
+ [ (>>loc) ] do-grid ;
: resize-grid ( grid horiz vert -- )
pick fill?>> [
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays ui.gadgets.buttons ui.gadgets.borders
ui.gadgets.labels ui.gadgets.panes ui.gadgets.scrollers
M: labelled-gadget focusable-child* content>> ;
: <labelled-scroller> ( gadget title -- gadget )
- >r <scroller> r> <labelled-gadget> ;
+ [ <scroller> ] dip <labelled-gadget> ;
: <labelled-pane> ( model quot scrolls? title -- gadget )
- >r >r <pane-control> r> >>scrolls? r>
+ [ [ <pane-control> ] dip >>scrolls? ] dip
<labelled-scroller> ;
: <close-box> ( quot -- button/f )
: set-label-string ( string label -- )
CHAR: \n pick memq? [
- >r string-lines r> (>>text)
+ [ string-lines ] dip (>>text)
] [
(>>text)
] if ; inline
hook>> [ [ list? ] find-parent ] prepend ;
: <list-presentation> ( hook elt presenter -- gadget )
- keep >r >label text-theme r>
+ keep [ >label text-theme ] dip
<presentation>
swap >>hook ; inline
[ presenter>> ]
[ control-value ]
tri [
- >r 2dup r> swap <list-presentation>
+ [ 2dup ] dip swap <list-presentation>
] map 2nip ;
M: list model-changed
select-gadget ;
: list-page ( list vec -- )
- >r dup selected-rect rect-bounds 2 v/n v+
- over visible-dim r> v* v+ swap select-at ;
+ [ dup selected-rect rect-bounds 2 v/n v+ over visible-dim ] dip
+ v* v+ swap select-at ;
: list-page-up ( list -- ) { 0 -1 } list-page ;
IN: ui.gadgets.menus
: menu-loc ( world menu -- loc )
- >r rect-dim r> pref-dim [v-] hand-loc get-global vmin ;
+ [ rect-dim ] [ pref-dim ] bi* [v-] hand-loc get-global vmin ;
TUPLE: menu-glass < gadget ;
: <menu-glass> ( menu world -- glass )
menu-glass new-gadget
- >r over menu-loc >>loc r>
+ [ over menu-loc >>loc ] dip
swap add-gadget ;
M: menu-glass layout* gadget-child prefer ;
{ 0 0 } [ v+ over v+ ] accumulate 2nip ;
: aligned-locs ( gadget sizes -- seq )
- [ >r dup align>> swap rect-dim r> v- n*v ] with map ;
+ [ [ dup align>> swap rect-dim ] dip v- n*v ] with map ;
: packed-locs ( gadget sizes -- seq )
- over gap>> over gap-locs >r dupd aligned-locs r> orient ;
+ over gap>> over gap-locs [ dupd aligned-locs ] dip orient ;
: round-dims ( seq -- newseq )
{ 0 0 } swap
: pack-layout ( pack sizes -- )
round-dims over children>>
- >r dupd packed-dims r> 2dup [ (>>dim) ] 2each
- >r packed-locs r> [ (>>loc) ] 2each ;
+ [ dupd packed-dims ] dip
+ [ [ (>>dim) ] 2each ]
+ [ [ packed-locs ] dip [ (>>loc) ] 2each ] 2bi ;
: <pack> ( orientation -- pack )
pack new-gadget
[ dim-sum ] keep length 1 [-] rot n*v v+ ;
: pack-pref-dim ( gadget sizes -- dim )
- over gap>> over gap-dims >r max-dim r>
+ over gap>> over gap-dims [ max-dim ] dip
rot orientation>> set-axis ;
M: pack pref-dim*
io.streams.nested assocs ui.gadgets.presentations
ui.gadgets.slots ui.gadgets.grids ui.gadgets.grid-lines
classes.tuple models continuations destructors accessors
-math.geometry.rect ;
+math.geometry.rect fry ;
IN: ui.gadgets.panes
TUPLE: pane < pack
GENERIC: draw-selection ( loc obj -- )
: if-fits ( rect quot -- )
- >r clip get over intersects? r> [ drop ] if ; inline
+ [ clip get over intersects? ] dip [ drop ] if ; inline
M: gadget draw-selection ( loc gadget -- )
swap offset-rect [
: with-pane ( pane quot -- )
over scroll>top
- over pane-clear >r <pane-stream> r>
- over >r with-output-stream* r> ?nl ; inline
+ over pane-clear [ <pane-stream> ] dip
+ over [ with-output-stream* ] dip ?nl ; inline
: make-pane ( quot -- gadget )
<pane> [ swap with-pane ] keep smash-pane ; inline
swap >>model ;
: do-pane-stream ( pane-stream quot -- )
- >r pane>> r> keep scroll-pane ; inline
+ [ pane>> ] dip keep scroll-pane ; inline
M: pane-stream stream-nl
[ pane-nl drop ] do-pane-stream ;
! Character styles
: apply-style ( style gadget key quot -- style gadget )
- >r pick at r> when* ; inline
+ [ pick at ] dip when* ; inline
: apply-foreground-style ( style gadget -- style gadget )
foreground [ >>color ] apply-style ;
border-width [ <border> ] apply-style ;
: apply-printer-style ( style gadget -- style gadget )
- presented-printer [ [ make-pane ] curry >>printer ] apply-style ;
+ presented-printer [ '[ _ make-pane ] >>printer ] apply-style ;
: style-pane ( style pane -- pane )
apply-border-width-style
pane-cell-stream new-nested-pane-stream ;
M: pane-stream stream-write-table
- >r
- swap [ [ pane>> smash-pane ] map ] map
- styled-grid
- r> print-gadget ;
+ [
+ swap [ [ pane>> smash-pane ] map ] map
+ styled-grid
+ ] dip print-gadget ;
! Stream utilities
M: pack dispose drop ;
drop ;
: gadget-write1 ( char gadget -- )
- >r 1string r> stream-write ;
+ [ 1string ] dip stream-write ;
M: pack stream-write1 gadget-write1 ;
: invoke-presentation ( presentation command -- )
over dup hook>> call
- >r object>> r> invoke-command ;
+ [ object>> ] dip invoke-command ;
: invoke-primary ( presentation -- )
dup object>> primary-operation
ui.gadgets.frames ui.gadgets.grids math.order
ui.gadgets.theme ui.render kernel math namespaces sequences
vectors models models.range math.vectors math.functions
-quotations colors math.geometry.rect ;
+quotations colors math.geometry.rect fry ;
IN: ui.gadgets.sliders
TUPLE: elevator < gadget direction ;
: layout-thumb-loc ( slider -- )
dup thumb-loc (layout-thumb)
- >r [ floor ] map r> (>>loc) ;
+ [ [ floor ] map ] dip (>>loc) ;
: layout-thumb-dim ( slider -- )
- dup dup thumb-dim (layout-thumb) >r
- >r dup rect-dim r>
- rot orientation>> set-axis [ ceiling ] map
- r> (>>dim) ;
+ dup dup thumb-dim (layout-thumb)
+ [
+ [ dup rect-dim ] dip
+ rot orientation>> set-axis [ ceiling ] map
+ ] dip (>>dim) ;
: layout-thumb ( slider -- )
dup layout-thumb-loc layout-thumb-dim ;
: slide-by-line ( amount slider -- ) [ line>> * ] keep slide-by ;
: <slide-button> ( vector polygon amount -- button )
- >r gray swap <polygon-gadget> r>
- [ swap find-slider slide-by-line ] curry <repeat-button>
+ [ gray swap <polygon-gadget> ] dip
+ '[ _ swap find-slider slide-by-line ] <repeat-button>
swap >>orientation ;
: elevator, ( gadget orientation -- gadget )
tuck <elevator> >>elevator
- swap <thumb> >>thumb
+ swap <thumb> >>thumb
dup elevator>> over thumb>> add-gadget
@center grid-add ;
open-world-window ;
: show-summary ( object gadget -- )
- >r [ summary ] [ "" ] if* r> show-status ;
+ [ [ summary ] [ "" ] if* ] dip show-status ;
M: world layout*
dup call-next-method
dup glass>> [
- >r dup rect-dim r> (>>dim)
+ [ dup rect-dim ] dip (>>dim)
] when* drop ;
M: world focusable-child* gadget-child ;
operations get [ predicate>> call ] with filter ;
: find-operation ( obj quot -- command )
- >r object-operations r> find-last nip ; inline
+ [ object-operations ] dip find-last nip ; inline
: primary-operation ( obj -- operation )
[ command>> +primary+ word-prop ] find-operation ;
: flip-rect ( rect -- loc dim )
rect-bounds [
- >r { 1 -1 } v* r> { 0 -1 } v* v+
+ [ { 1 -1 } v* ] dip { 0 -1 } v* v+
viewport-translation get v+
] keep ;
>absolute clip [ rect-intersect ] change ;
: with-clipping ( gadget quot -- )
- clip get >r
- over change-clip do-clip call
- r> clip set do-clip ; inline
+ clip get [ over change-clip do-clip call ] dip clip set do-clip ; inline
: draw-gadget ( gadget -- )
{
: <polygon-gadget> ( color points -- gadget )
dup max-dim
- >r <polygon> <gadget> r> >>dim
+ [ <polygon> <gadget> ] dip >>dim
swap >>interior ;
! Font rendering
[
[
2dup { 0 0 } draw-string
- >r open-font r> string-height
+ [ open-font ] dip string-height
0.0 swap 0.0 glTranslated
] with each
] with-translation
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: ui.gadgets colors kernel ui.render namespaces
- models models.mapping sequences ui.gadgets.buttons
- ui.gadgets.packs ui.gadgets.labels tools.deploy.config
- namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
- ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
- tools.deploy vocabs ui.tools.workspace system accessors ;
-
+USING: ui.gadgets colors kernel ui.render namespaces models
+models.mapping sequences ui.gadgets.buttons ui.gadgets.packs
+ui.gadgets.labels tools.deploy.config namespaces
+ui.gadgets.editors ui.gadgets.borders ui.gestures ui.commands
+assocs ui.gadgets.tracks ui ui.tools.listener tools.deploy
+vocabs ui.tools.workspace system accessors fry ;
IN: ui.tools.deploy
TUPLE: deploy-gadget < pack vocab settings ;
: com-deploy ( gadget -- )
dup com-save
- dup find-deploy-vocab [ deploy ] curry call-listener
+ dup find-deploy-vocab '[ _ deploy ] call-listener
close-window ;
: com-help ( -- )
ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.status-bar
ui.gadgets.presentations ui.gadgets.worlds ui.gestures
definitions calendar concurrency.flags concurrency.mailboxes
-ui.tools.workspace accessors sets destructors ;
+ui.tools.workspace accessors sets destructors fry ;
IN: ui.tools.interactor
! If waiting is t, we're waiting for user input, and invoking
[ editor-string ] keep
[ interactor-input. ] 2keep
[ add-interactor-history ] keep
- [ clear-input ] curry "Clearing input" spawn drop ;
+ '[ _ clear-input ] "Clearing input" spawn drop ;
: interactor-eof ( interactor -- )
dup interactor-busy? [
swap dup zero? [
2drop ""
] [
- >r interactor-read dup [ "\n" join ] when r> short head
+ [ interactor-read dup [ "\n" join ] when ] dip short head
] if ;
M: interactor stream-read-partial
input>> ;
M: listener-gadget call-tool* ( input listener -- )
- >r string>> r> input>> set-editor-string ;
+ [ string>> ] dip input>> set-editor-string ;
M: listener-gadget tool-scroller
output>> find-scroller ;
: use-if-necessary ( word seq -- )
over vocabulary>> over and [
2dup [ assoc-stack ] keep = [ 2drop ] [
- >r vocabulary>> vocab-words r> push
+ [ vocabulary>> vocab-words ] dip push
] if
] [ 2drop ] if ;
: insert-word ( word -- )
get-workspace listener>> input>>
- [ >r word-completion-string r> user-input* drop ]
+ [ [ word-completion-string ] dip user-input* drop ]
[ interactor-use use-if-necessary ]
2bi ;
! See http://factorcode.org/license.txt for BSD license.
USING: ui.tools.workspace kernel quotations tools.profiler
ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
-ui.gadgets.tracks ui.gestures ui.gadgets.buttons accessors ;
+ui.gadgets.tracks ui.gestures ui.gadgets.buttons accessors fry ;
IN: ui.tools.profiler
TUPLE: profiler-gadget < track pane ;
dup pane>> <scroller> 1 track-add ;
: with-profiler-pane ( gadget quot -- )
- >r pane>> r> with-pane ;
+ [ pane>> ] dip with-pane ;
: com-full-profile ( gadget -- )
[ profile. ] with-profiler-pane ;
GENERIC: profiler-presentation ( obj -- quot )
M: usage-profile profiler-presentation
- word>> [ usage-profile. ] curry ;
+ word>> '[ _ usage-profile. ] ;
M: vocab-profile profiler-presentation
- vocab>> [ vocab-profile. ] curry ;
+ vocab>> '[ _ vocab-profile. ] ;
M: f profiler-presentation
drop [ vocabs-profile. ] ;
] with-grafted-gadget ;
: test-live-search ( gadget quot -- ? )
- >r update-live-search dup assert-non-empty r> all? ;
+ [ update-live-search dup assert-non-empty ] dip all? ;
[ t ] [
"swp" all-words f <definition-search>
ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
ui.gadgets.presentations ui.gestures words vocabs.loader
tools.test tools.vocabs ui.gadgets.buttons ui.gadgets.status-bar
-mirrors ;
+mirrors fry ;
IN: ui.tools
: <workspace-tabs> ( workspace -- tabs )
] workspace-window-hook set-global
: inspect-continuation ( traceback -- )
- control-value [ inspect ] curry call-listener ;
+ control-value '[ _ inspect ] call-listener ;
traceback-gadget "toolbar" f {
{ T{ key-down f f "v" } variables }
ui.gadgets.status-bar ui.gadgets.tracks ui.commands ui.gadgets
models models.filter ui.tools.workspace ui.gestures
ui.gadgets.labels ui threads namespaces make tools.walker assocs
-combinators ;
+combinators fry ;
IN: ui.tools.walker
TUPLE: walker-gadget < track
] "" make ;
: <thread-status> ( model thread -- gadget )
- [ walker-state-string ] curry <filter> <label-control> ;
+ '[ _ walker-state-string ] <filter> <label-control> ;
: <walker-gadget> ( status continuation thread -- gadget )
{ 0 1 } walker-gadget new-track
} cond ;
: find-walker-window ( thread -- world/f )
- [ swap walker-for-thread? ] curry find-window ;
+ '[ _ swap walker-for-thread? ] find-window ;
: walker-window ( status continuation thread -- )
[ <walker-gadget> ] [ name>> ] bi open-status-window ;
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes continuations help help.topics kernel models
-sequences assocs arrays namespaces accessors math.vectors ui
+sequences assocs arrays namespaces accessors math.vectors fry ui
ui.backend ui.tools.debugger ui.gadgets ui.gadgets.books
ui.gadgets.buttons ui.gadgets.labelled ui.gadgets.panes
ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
set-model ;
: get-workspace* ( quot -- workspace )
- [ >r dup workspace? r> [ drop f ] if ] curry find-window
+ '[ dup workspace? _ [ drop f ] if ] find-window
[ dup raise-window gadget-child ]
[ workspace-window* ] if* ; inline
: mouse-wheel ( lParam -- array ) >lo-hi [ sgn neg ] map ;
: mouse-absolute>relative ( lparam handle -- array )
- >r >lo-hi r>
+ [ >lo-hi ] dip
"RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep
get-RECT-top-left 2array v- ;
[ <button-down> ] [ <button-up> ] if ;
: prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world )
- nip >r mouse-event>gesture r> >lo-hi rot window ;
+ [ drop mouse-event>gesture ] dip >lo-hi rot window ;
: set-capture ( hwnd -- )
mouse-captured get [
mouse-captured off ;
: handle-wm-buttondown ( hWnd uMsg wParam lParam -- )
- >r >r
- over set-capture
- dup message>button drop nc-buttons get delete
- r> r> prepare-mouse send-button-down ;
+ [
+ over set-capture
+ dup message>button drop nc-buttons get delete
+ ] 2dip prepare-mouse send-button-down ;
: handle-wm-buttonup ( hWnd uMsg wParam lParam -- )
mouse-captured get [ release-capture ] when
TrackMouseEvent drop
>lo-hi swap window move-hand fire-motion ;
-: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
- >r nip r>
- pick mouse-absolute>relative >r mouse-wheel r> rot window send-wheel ;
+:: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
+ lParam mouse-wheel
+ hWnd mouse-absolute>relative
+ hWnd window send-wheel ;
: handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
#! message sent if windows needs application to stop dragging
: create-window ( rect -- hwnd )
make-adjusted-RECT
- >r class-name-ptr get-global f r>
- >r >r >r ex-style r> r>
+ [ class-name-ptr get-global f ] dip
+ [
+ [ ex-style ] 2dip
{ WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags
- r> get-RECT-dimensions
+ ] dip get-RECT-dimensions
f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;
: show-window ( hWnd -- )
M: windows-ui-backend set-title ( string world -- )
handle>>
dup title>> [ free ] when*
- >r utf16n malloc-string r>
+ [ utf16n malloc-string ] dip
2dup (>>title)
hWnd>> WM_SETTEXT 0 roll alien-address SendMessage drop ;
: key-down-event>gesture ( event world -- string gesture )
dupd
handle>> xic>> lookup-string
- >r swap event-modifiers r> key-code <key-down> ;
+ [ swap event-modifiers ] dip key-code <key-down> ;
M: world key-down-event
[ key-down-event>gesture ] keep
dup event-modifiers swap 0 XLookupKeysym key-code <key-up> ;
M: world key-up-event
- >r key-up-event>gesture r> world-focus propagate-gesture ;
+ [ key-up-event>gesture ] dip world-focus propagate-gesture ;
: mouse-event>gesture ( event -- modifiers button loc )
dup event-modifiers over XButtonEvent-button
rot mouse-event-loc ;
M: world button-down-event
- >r mouse-event>gesture >r <button-down> r> r>
+ [ mouse-event>gesture [ <button-down> ] dip ] dip
send-button-down ;
M: world button-up-event
- >r mouse-event>gesture >r <button-up> r> r>
+ [ mouse-event>gesture [ <button-up> ] dip ] dip
send-button-up ;
: mouse-event>scroll-direction ( event -- pair )
} at ;
M: world wheel-event
- >r dup mouse-event>scroll-direction swap mouse-event-loc r>
+ [ dup mouse-event>scroll-direction swap mouse-event-loc ] dip
send-wheel ;
M: world enter-event motion-event ;
M: world leave-event 2drop forget-rollover ;
M: world motion-event
- >r dup XMotionEvent-x swap XMotionEvent-y 2array r>
+ [ dup XMotionEvent-x swap XMotionEvent-y 2array ] dip
move-hand fire-motion ;
M: world focus-in-event
[ XSelectionRequestEvent-requestor ] keep
[ XSelectionRequestEvent-property ] keep
[ XSelectionRequestEvent-target ] keep
- >r 8 PropModeReplace r>
+ [ 8 PropModeReplace ] dip
[
XSelectionRequestEvent-selection
clipboard-for-atom contents>>
(>>contents) ;
M: x-clipboard paste-clipboard
- >r find-world handle>> window>>
- r> atom>> convert-selection ;
+ [ find-world handle>> window>> ] dip atom>> convert-selection ;
: init-clipboard ( -- )
XA_PRIMARY <x-clipboard> selection set-global
dup [ 127 <= ] all? [ XStoreName drop ] [ 3drop ] if ;
: set-title-new ( dpy window string -- )
- >r
- XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace
- r> utf8 encode dup length XChangeProperty drop ;
+ [ XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace ] dip
+ utf8 encode dup length XChangeProperty drop ;
M: x11-ui-backend set-title ( string world -- )
handle>> window>> swap dpy get -rot
3dup set-title-old set-title-new ;
-
+
M: x11-ui-backend set-fullscreen* ( ? world -- )
handle>> window>> "XClientMessageEvent" <c-object>
tuck set-XClientMessageEvent-window
"_NET_WM_STATE" x-atom over set-XClientMessageEvent-message_type
32 over set-XClientMessageEvent-format
"_NET_WM_STATE_FULLSCREEN" x-atom over set-XClientMessageEvent-data1
- >r dpy get root get 0 SubstructureNotifyMask r> XSendEvent drop ;
-
+ [ dpy get root get 0 SubstructureNotifyMask ] dip XSendEvent drop ;
M: x11-ui-backend (open-window) ( world -- )
dup gadget-window