diff --git a/basis/ui/clipboards/clipboards.factor b/basis/ui/clipboards/clipboards.factor index e1b591dfb9..42c3f6ddef 100644 --- a/basis/ui/clipboards/clipboards.factor +++ b/basis/ui/clipboards/clipboards.factor @@ -33,7 +33,7 @@ SYMBOL: selection : gadget-copy ( gadget clipboard -- ) over gadget-selection? - [ >r [ gadget-selection ] keep r> copy-clipboard ] + [ [ [ gadget-selection ] keep ] dip copy-clipboard ] [ 2drop ] if ; diff --git a/basis/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor index 9ff3a59f71..5d3b8db19d 100644 --- a/basis/ui/cocoa/cocoa.factor +++ b/basis/ui/cocoa/cocoa.factor @@ -5,7 +5,7 @@ command-line kernel memory namespaces cocoa.messages 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 ; @@ -15,7 +15,7 @@ C: handle 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 ; diff --git a/basis/ui/cocoa/tools/tools.factor b/basis/ui/cocoa/tools/tools.factor index 876e9e5df1..a8ade05a86 100644 --- a/basis/ui/cocoa/tools/tools.factor +++ b/basis/ui/cocoa/tools/tools.factor @@ -25,7 +25,7 @@ CLASS: { } { "application:openFiles:" "void" { "id" "SEL" "id" "id" } - [ >r 3drop r> finder-run-files ] + [ [ 3drop ] dip finder-run-files ] } { "newFactorWorkspace:" "id" { "id" "SEL" "id" } diff --git a/basis/ui/cocoa/views/views.factor b/basis/ui/cocoa/views/views.factor index 82a31ad0d9..1e35fcf4b2 100644 --- a/basis/ui/cocoa/views/views.factor +++ b/basis/ui/cocoa/views/views.factor @@ -8,7 +8,7 @@ core-foundation threads combinators math.geometry.rect ; 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 @@ -85,18 +85,19 @@ IN: ui.cocoa.views 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" - r> add-observer ; + [ + "updateFactorGadgetSize:" + "NSViewFrameDidChangeNotification" + ] dip add-observer ; : string-or-nil? ( NSString -- ? ) [ CF>string NSStringPboardType = ] [ t ] if* ; @@ -109,7 +110,7 @@ IN: ui.cocoa.views ] 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 ; @@ -256,7 +257,7 @@ CLASS: { { "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 ] } @@ -278,7 +279,7 @@ CLASS: { { "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 diff --git a/basis/ui/commands/commands.factor b/basis/ui/commands/commands.factor index b45e2e4004..5f8c3381b7 100644 --- a/basis/ui/commands/commands.factor +++ b/basis/ui/commands/commands.factor @@ -2,7 +2,7 @@ ! 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+ @@ -37,7 +37,7 @@ GENERIC: command-word ( command -- word ) [ commands>> [ drop ] assoc-filter - [ [ invoke-command ] curry swap set ] assoc-each + [ '[ _ invoke-command ] swap set ] assoc-each ] each ] H{ } make-assoc ; diff --git a/basis/ui/freetype/freetype.factor b/basis/ui/freetype/freetype.factor index d2dfe56ed4..41d000af26 100644 --- a/basis/ui/freetype/freetype.factor +++ b/basis/ui/freetype/freetype.factor @@ -111,7 +111,7 @@ M: freetype-renderer open-font ( font -- open-font ) freetype drop open-fonts get [ ] 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 ) @@ -174,7 +174,7 @@ M: freetype-renderer string-height ( open-font string -- h ) bi 2array ; : ( 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 [ bitmap>texture ] keep [ init-sprite ] keep ; @@ -206,7 +206,7 @@ M: freetype-renderer string-height ( open-font string -- h ) 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+ ; diff --git a/basis/ui/gadgets/books/books.factor b/basis/ui/gadgets/books/books.factor index da0ff35728..4ef90d87b9 100644 --- a/basis/ui/gadgets/books/books.factor +++ b/basis/ui/gadgets/books/books.factor @@ -1,6 +1,7 @@ ! 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 ; @@ -25,6 +26,6 @@ M: book model-changed ( model book -- ) 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 ; diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index 7d33ec21fd..a1386eef53 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -3,7 +3,7 @@ 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 @@ -56,9 +56,7 @@ M: gadget model-changed 2drop ; 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 -- ? ) @@ -73,7 +71,7 @@ M: gadget children-on nip children>> ; [ 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 ] @@ -95,10 +93,10 @@ M: gadget children-on nip children>> ; : 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 -- ? ) @@ -310,18 +308,18 @@ SYMBOL: in-layout? [ 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* ; diff --git a/basis/ui/gadgets/grid-lines/grid-lines.factor b/basis/ui/gadgets/grid-lines/grid-lines.factor index feca8f7c63..8d79c9e07c 100755 --- a/basis/ui/gadgets/grid-lines/grid-lines.factor +++ b/basis/ui/gadgets/grid-lines/grid-lines.factor @@ -1,7 +1,8 @@ -! 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 ; @@ -19,8 +20,8 @@ SYMBOL: grid-dim : 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 [ diff --git a/basis/ui/gadgets/grids/grids.factor b/basis/ui/gadgets/grids/grids.factor index 3e91e0ceb6..386457551f 100644 --- a/basis/ui/gadgets/grids/grids.factor +++ b/basis/ui/gadgets/grids/grids.factor @@ -2,7 +2,7 @@ ! 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 @@ -48,21 +48,18 @@ grid 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?>> [ diff --git a/basis/ui/gadgets/labelled/labelled.factor b/basis/ui/gadgets/labelled/labelled.factor index 79a485b711..e4343e6280 100644 --- a/basis/ui/gadgets/labelled/labelled.factor +++ b/basis/ui/gadgets/labelled/labelled.factor @@ -1,4 +1,4 @@ -! 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 @@ -19,10 +19,10 @@ TUPLE: labelled-gadget < track content ; M: labelled-gadget focusable-child* content>> ; : ( gadget title -- gadget ) - >r r> ; + [ ] dip ; : ( model quot scrolls? title -- gadget ) - >r >r r> >>scrolls? r> + [ [ ] dip >>scrolls? ] dip ; : ( quot -- button/f ) diff --git a/basis/ui/gadgets/labels/labels.factor b/basis/ui/gadgets/labels/labels.factor index 6e56b48c8b..5706f47639 100644 --- a/basis/ui/gadgets/labels/labels.factor +++ b/basis/ui/gadgets/labels/labels.factor @@ -13,7 +13,7 @@ TUPLE: label < gadget text font color ; : set-label-string ( string label -- ) CHAR: \n pick memq? [ - >r string-lines r> (>>text) + [ string-lines ] dip (>>text) ] [ (>>text) ] if ; inline diff --git a/basis/ui/gadgets/lists/lists.factor b/basis/ui/gadgets/lists/lists.factor index ec46638c91..0113e1959d 100644 --- a/basis/ui/gadgets/lists/lists.factor +++ b/basis/ui/gadgets/lists/lists.factor @@ -33,7 +33,7 @@ TUPLE: list < pack index presenter color hook ; hook>> [ [ list? ] find-parent ] prepend ; : ( hook elt presenter -- gadget ) - keep >r >label text-theme r> + keep [ >label text-theme ] dip swap >>hook ; inline @@ -42,7 +42,7 @@ TUPLE: list < pack index presenter color hook ; [ presenter>> ] [ control-value ] tri [ - >r 2dup r> swap + [ 2dup ] dip swap ] map 2nip ; M: list model-changed @@ -113,8 +113,8 @@ M: list focusable-child* drop t ; 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 ; diff --git a/basis/ui/gadgets/menus/menus.factor b/basis/ui/gadgets/menus/menus.factor index e973dd07dc..cbcfdb14d8 100644 --- a/basis/ui/gadgets/menus/menus.factor +++ b/basis/ui/gadgets/menus/menus.factor @@ -8,13 +8,13 @@ math.geometry.rect ; 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 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 ; diff --git a/basis/ui/gadgets/packs/packs.factor b/basis/ui/gadgets/packs/packs.factor index 32a60374eb..5965e8b568 100644 --- a/basis/ui/gadgets/packs/packs.factor +++ b/basis/ui/gadgets/packs/packs.factor @@ -19,10 +19,10 @@ TUPLE: pack < gadget { 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 @@ -31,8 +31,9 @@ TUPLE: pack < gadget : 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 ; : ( orientation -- pack ) pack new-gadget @@ -48,7 +49,7 @@ TUPLE: pack < 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* diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor index c612cbef0a..9a30cee777 100644 --- a/basis/ui/gadgets/panes/panes.factor +++ b/basis/ui/gadgets/panes/panes.factor @@ -9,7 +9,7 @@ opengl combinators math.vectors sorting splitting 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 @@ -59,7 +59,7 @@ M: pane gadget-selection ( pane -- string/f ) 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 [ @@ -135,8 +135,8 @@ M: style-stream write-gadget : with-pane ( pane quot -- ) over scroll>top - over pane-clear >r r> - over >r with-output-stream* r> ?nl ; inline + over pane-clear [ ] dip + over [ with-output-stream* ] dip ?nl ; inline : make-pane ( quot -- gadget ) [ swap with-pane ] keep smash-pane ; inline @@ -154,7 +154,7 @@ M: pane-control model-changed ( model pane-control -- ) 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 ; @@ -178,7 +178,7 @@ M: pane-stream make-span-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 ; @@ -228,7 +228,7 @@ M: pane-stream make-span-stream border-width [ ] 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 @@ -284,10 +284,10 @@ M: pane-stream make-cell-stream 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 ; @@ -309,7 +309,7 @@ M: paragraph stream-write drop ; : gadget-write1 ( char gadget -- ) - >r 1string r> stream-write ; + [ 1string ] dip stream-write ; M: pack stream-write1 gadget-write1 ; diff --git a/basis/ui/gadgets/presentations/presentations.factor b/basis/ui/gadgets/presentations/presentations.factor index c5f078e82e..e39069ed7b 100644 --- a/basis/ui/gadgets/presentations/presentations.factor +++ b/basis/ui/gadgets/presentations/presentations.factor @@ -12,7 +12,7 @@ TUPLE: presentation < button object hook ; : invoke-presentation ( presentation command -- ) over dup hook>> call - >r object>> r> invoke-command ; + [ object>> ] dip invoke-command ; : invoke-primary ( presentation -- ) dup object>> primary-operation diff --git a/basis/ui/gadgets/sliders/sliders.factor b/basis/ui/gadgets/sliders/sliders.factor index f42d65f738..968972a869 100644 --- a/basis/ui/gadgets/sliders/sliders.factor +++ b/basis/ui/gadgets/sliders/sliders.factor @@ -4,7 +4,7 @@ USING: accessors arrays ui.gestures ui.gadgets ui.gadgets.buttons 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 ; @@ -104,13 +104,14 @@ elevator H{ : 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 ; @@ -121,13 +122,13 @@ M: elevator layout* : slide-by-line ( amount slider -- ) [ line>> * ] keep slide-by ; : ( vector polygon amount -- button ) - >r gray swap r> - [ swap find-slider slide-by-line ] curry + [ gray swap ] dip + '[ _ swap find-slider slide-by-line ] swap >>orientation ; : elevator, ( gadget orientation -- gadget ) tuck >>elevator - swap >>thumb + swap >>thumb dup elevator>> over thumb>> add-gadget @center grid-add ; diff --git a/basis/ui/gadgets/status-bar/status-bar.factor b/basis/ui/gadgets/status-bar/status-bar.factor index 431804f4ca..32abcd5466 100644 --- a/basis/ui/gadgets/status-bar/status-bar.factor +++ b/basis/ui/gadgets/status-bar/status-bar.factor @@ -16,4 +16,4 @@ IN: ui.gadgets.status-bar open-world-window ; : show-summary ( object gadget -- ) - >r [ summary ] [ "" ] if* r> show-status ; + [ [ summary ] [ "" ] if* ] dip show-status ; diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 904a2a5bac..98c3258911 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -52,7 +52,7 @@ M: world request-focus-on ( child gadget -- ) 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 ; diff --git a/basis/ui/operations/operations.factor b/basis/ui/operations/operations.factor index 8e83f69edb..660ae1f43d 100644 --- a/basis/ui/operations/operations.factor +++ b/basis/ui/operations/operations.factor @@ -38,7 +38,7 @@ SYMBOL: operations 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 ; diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor index 36c0d5f256..55b8a82ac1 100755 --- a/basis/ui/render/render.factor +++ b/basis/ui/render/render.factor @@ -12,7 +12,7 @@ SYMBOL: viewport-translation : 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 ; @@ -79,9 +79,7 @@ DEFER: draw-gadget >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 -- ) { @@ -200,7 +198,7 @@ M: polygon draw-interior : ( color points -- gadget ) dup max-dim - >r r> >>dim + [ ] dip >>dim swap >>interior ; ! Font rendering @@ -242,7 +240,7 @@ HOOK: free-fonts font-renderer ( world -- ) [ [ 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 diff --git a/basis/ui/tools/deploy/deploy.factor b/basis/ui/tools/deploy/deploy.factor index f310f72780..5a99d1174b 100644 --- a/basis/ui/tools/deploy/deploy.factor +++ b/basis/ui/tools/deploy/deploy.factor @@ -1,12 +1,11 @@ ! 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 ; @@ -83,7 +82,7 @@ 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 ( -- ) diff --git a/basis/ui/tools/interactor/interactor.factor b/basis/ui/tools/interactor/interactor.factor index 5739a469ea..0676619b07 100644 --- a/basis/ui/tools/interactor/interactor.factor +++ b/basis/ui/tools/interactor/interactor.factor @@ -7,7 +7,7 @@ quotations sequences strings threads listener classes.tuple 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 @@ -88,7 +88,7 @@ M: interactor model-changed [ 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? [ @@ -126,7 +126,7 @@ M: interactor stream-read 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 diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index de0ce43f20..7ffbfd2738 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -28,7 +28,7 @@ M: listener-gadget focusable-child* 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 ; @@ -95,13 +95,13 @@ M: engine-word word-completion-string : 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 ; diff --git a/basis/ui/tools/profiler/profiler.factor b/basis/ui/tools/profiler/profiler.factor index 05d1ccdb82..7280efe885 100644 --- a/basis/ui/tools/profiler/profiler.factor +++ b/basis/ui/tools/profiler/profiler.factor @@ -2,7 +2,7 @@ ! 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 ; @@ -14,7 +14,7 @@ TUPLE: profiler-gadget < track pane ; dup pane>> 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 ; @@ -39,10 +39,10 @@ profiler-gadget "toolbar" f { 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. ] ; diff --git a/basis/ui/tools/search/search-tests.factor b/basis/ui/tools/search/search-tests.factor index c8c7c6c219..39a6442308 100644 --- a/basis/ui/tools/search/search-tests.factor +++ b/basis/ui/tools/search/search-tests.factor @@ -19,7 +19,7 @@ IN: ui.tools.search.tests ] 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 diff --git a/basis/ui/tools/tools.factor b/basis/ui/tools/tools.factor index 3310a3e0a5..9927f9e5ae 100644 --- a/basis/ui/tools/tools.factor +++ b/basis/ui/tools/tools.factor @@ -9,7 +9,7 @@ ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled 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 ) @@ -93,7 +93,7 @@ workspace "workflow" f { ] 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 } diff --git a/basis/ui/tools/walker/walker.factor b/basis/ui/tools/walker/walker.factor index 9c825d4920..e6643698c7 100644 --- a/basis/ui/tools/walker/walker.factor +++ b/basis/ui/tools/walker/walker.factor @@ -5,7 +5,7 @@ ui.tools.listener ui.tools.traceback ui.gadgets.buttons 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 @@ -53,7 +53,7 @@ M: walker-gadget focusable-child* ] "" make ; : ( model thread -- gadget ) - [ walker-state-string ] curry ; + '[ _ walker-state-string ] ; : ( status continuation thread -- gadget ) { 0 1 } walker-gadget new-track @@ -89,7 +89,7 @@ walker-gadget "toolbar" f { } 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 -- ) [ ] [ name>> ] bi open-status-window ; diff --git a/basis/ui/tools/workspace/workspace.factor b/basis/ui/tools/workspace/workspace.factor index 6536cb8c7d..3b689eee39 100644 --- a/basis/ui/tools/workspace/workspace.factor +++ b/basis/ui/tools/workspace/workspace.factor @@ -1,7 +1,7 @@ ! 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 @@ -33,7 +33,7 @@ M: gadget tool-scroller drop f ; 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 diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor index 99a7d5fe0f..3805cf7e1f 100755 --- a/basis/ui/windows/windows.factor +++ b/basis/ui/windows/windows.factor @@ -288,7 +288,7 @@ SYMBOL: nc-buttons : mouse-wheel ( lParam -- array ) >lo-hi [ sgn neg ] map ; : mouse-absolute>relative ( lparam handle -- array ) - >r >lo-hi r> + [ >lo-hi ] dip "RECT" [ GetWindowRect win32-error=0/f ] keep get-RECT-top-left 2array v- ; @@ -297,7 +297,7 @@ SYMBOL: nc-buttons [ ] [ ] 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 [ @@ -312,10 +312,10 @@ SYMBOL: nc-buttons 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 @@ -337,9 +337,10 @@ SYMBOL: nc-buttons 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 @@ -456,10 +457,11 @@ M: windows-ui-backend do-events : 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 -- ) @@ -515,7 +517,7 @@ M: windows-ui-backend raise-window* ( world -- ) 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 ; diff --git a/basis/ui/x11/x11.factor b/basis/ui/x11/x11.factor index de57c2dc72..b9889c75d4 100644 --- a/basis/ui/x11/x11.factor +++ b/basis/ui/x11/x11.factor @@ -79,7 +79,7 @@ M: world configure-event : key-down-event>gesture ( event world -- string gesture ) dupd handle>> xic>> lookup-string - >r swap event-modifiers r> key-code ; + [ swap event-modifiers ] dip key-code ; M: world key-down-event [ key-down-event>gesture ] keep @@ -92,18 +92,18 @@ M: world key-down-event dup event-modifiers swap 0 XLookupKeysym key-code ; 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 r> r> + [ mouse-event>gesture [ ] dip ] dip send-button-down ; M: world button-up-event - >r mouse-event>gesture >r r> r> + [ mouse-event>gesture [ ] dip ] dip send-button-up ; : mouse-event>scroll-direction ( event -- pair ) @@ -115,7 +115,7 @@ M: world button-up-event } 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 ; @@ -123,7 +123,7 @@ 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 @@ -158,7 +158,7 @@ M: world selection-notify-event [ XSelectionRequestEvent-requestor ] keep [ XSelectionRequestEvent-property ] keep [ XSelectionRequestEvent-target ] keep - >r 8 PropModeReplace r> + [ 8 PropModeReplace ] dip [ XSelectionRequestEvent-selection clipboard-for-atom contents>> @@ -208,8 +208,7 @@ M: x-clipboard copy-clipboard (>>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 selection set-global @@ -219,14 +218,13 @@ M: x-clipboard paste-clipboard 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" tuck set-XClientMessageEvent-window @@ -237,8 +235,7 @@ M: x11-ui-backend set-fullscreen* ( ? world -- ) "_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