From 3e25d14e5424a3c55ac994e883eff641d3f930e6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Nov 2008 17:47:29 -0600 Subject: [PATCH] Code cleanup: refactoring usages of rot and -rot to use newer idioms instead --- basis/alien/parser/parser.factor | 19 ++++++++ basis/alien/structs/fields/fields.factor | 14 ++---- basis/alien/syntax/syntax-docs.factor | 12 ++--- basis/alien/syntax/syntax.factor | 22 +-------- basis/cpu/x86/assembler/assembler.factor | 2 +- basis/dlists/dlists.factor | 20 ++++---- basis/opengl/gl/extensions/extensions.factor | 24 +++++----- basis/ui/cocoa/cocoa.factor | 13 ++--- basis/ui/cocoa/views/views-tests.factor | 15 ++++++ basis/ui/cocoa/views/views.factor | 48 ++++++++++--------- basis/ui/freetype/freetype.factor | 16 ++++--- basis/ui/gadgets/editors/editors.factor | 5 +- basis/ui/gadgets/gadgets-tests.factor | 7 --- basis/ui/gadgets/gadgets.factor | 5 +- basis/ui/gadgets/grids/grids.factor | 4 +- basis/ui/gadgets/labelled/labelled.factor | 9 ++-- basis/ui/gadgets/packs/packs-tests.factor | 10 +++- basis/ui/gadgets/packs/packs.factor | 28 ++++++----- basis/ui/gadgets/paragraphs/paragraphs.factor | 26 ++++++---- basis/ui/gadgets/sliders/sliders.factor | 13 ++--- basis/ui/gadgets/worlds/worlds.factor | 9 ++-- basis/ui/operations/operations.factor | 4 +- basis/ui/render/render.factor | 2 +- basis/ui/tools/deploy/deploy.factor | 6 ++- basis/ui/traverse/traverse.factor | 8 ++-- basis/ui/windows/windows.factor | 8 ++-- basis/ui/x11/x11.factor | 10 ++-- 27 files changed, 189 insertions(+), 170 deletions(-) create mode 100644 basis/alien/parser/parser.factor create mode 100644 basis/ui/cocoa/views/views-tests.factor diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor new file mode 100644 index 0000000000..193893fabc --- /dev/null +++ b/basis/alien/parser/parser.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.c-types arrays assocs effects grouping kernel +parser sequences splitting words fry locals ; +IN: alien.parser + +: parse-arglist ( parameters return -- types effect ) + [ 2 group unzip [ "," ?tail drop ] map ] + [ [ { } ] [ 1array ] if-void ] + bi* ; + +: function-quot ( return library function types -- quot ) + '[ _ _ _ _ alien-invoke ] ; + +:: define-function ( return library function parameters -- ) + function create-in dup reset-generic + return library function + parameters return parse-arglist [ function-quot ] dip + define-declared ; diff --git a/basis/alien/structs/fields/fields.factor b/basis/alien/structs/fields/fields.factor index 880c6f8413..17294aed87 100644 --- a/basis/alien/structs/fields/fields.factor +++ b/basis/alien/structs/fields/fields.factor @@ -52,25 +52,21 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ; [ (>>offset) ] [ type>> heap-size + ] 2bi ] reduce ; -: define-struct-slot-word ( spec word quot -- ) - rot offset>> prefix define-inline ; +: define-struct-slot-word ( word quot spec -- ) + offset>> prefix define-inline ; : define-getter ( type spec -- ) [ set-reader-props ] keep - [ ] [ reader>> ] [ type>> [ c-getter ] [ c-type-boxer-quot ] bi append - ] tri - define-struct-slot-word ; + ] + [ ] tri define-struct-slot-word ; : define-setter ( type spec -- ) [ set-writer-props ] keep - [ ] - [ writer>> ] - [ type>> c-setter ] tri - define-struct-slot-word ; + [ writer>> ] [ type>> c-setter ] [ ] tri define-struct-slot-word ; : define-field ( type spec -- ) [ define-getter ] [ define-setter ] 2bi ; diff --git a/basis/alien/syntax/syntax-docs.factor b/basis/alien/syntax/syntax-docs.factor index 37cbd12801..b9752f9fc8 100644 --- a/basis/alien/syntax/syntax-docs.factor +++ b/basis/alien/syntax/syntax-docs.factor @@ -1,6 +1,6 @@ IN: alien.syntax -USING: alien alien.c-types alien.structs alien.syntax.private -help.markup help.syntax ; +USING: alien alien.c-types alien.parser alien.structs +alien.syntax.private help.markup help.syntax ; HELP: DLL" { $syntax "DLL\" path\"" } @@ -54,12 +54,6 @@ HELP: TYPEDEF: { $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } " if ." } { $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ; -HELP: TYPEDEF-IF: -{ $syntax "TYPEDEF-IF: word old new" } -{ $values { "word" "a word with stack effect " { $snippet "( -- ? )" } } { "old" "a C type" } { "new" "a C type" } } -{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } " if " { $snippet "word" } " evaluates to a true value." } -{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ; - HELP: C-STRUCT: { $syntax "C-STRUCT: name pairs... ;" } { $values { "name" "a new C type name" } { "pairs" "C type / field name string pairs" } } @@ -88,7 +82,7 @@ HELP: typedef { $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." } { $notes "Using this word in the same source file which defines C bindings can cause problems, because words are compiled before top-level forms are run. Use the " { $link POSTPONE: TYPEDEF: } " word instead." } ; -{ POSTPONE: TYPEDEF-IF: POSTPONE: TYPEDEF: typedef } related-words +{ POSTPONE: TYPEDEF: typedef } related-words HELP: c-struct? { $values { "type" "a string" } { "?" "a boolean" } } diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index 3a45edd03f..a204b1621c 100644 --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -4,26 +4,9 @@ USING: accessors arrays alien alien.c-types alien.structs alien.arrays alien.strings kernel math namespaces parser sequences words quotations math.parser splitting grouping effects prettyprint prettyprint.sections prettyprint.backend -assocs combinators lexer strings.parser ; +assocs combinators lexer strings.parser alien.parser ; IN: alien.syntax - ; - -: function-quot ( type lib func types -- quot ) - [ alien-invoke ] 2curry 2curry ; - -: define-function ( return library function parameters -- ) - [ pick ] dip parse-arglist - pick create-in dup reset-generic - [ function-quot ] 2dip - -rot define-declared ; - -PRIVATE> - : DLL" lexer get skip-blank parse-string dlopen parsed ; parsing : ALIEN: scan string>number parsed ; parsing @@ -40,9 +23,6 @@ PRIVATE> : TYPEDEF: scan scan typedef ; parsing -: TYPEDEF-IF: - scan-word execute scan scan rot [ typedef ] [ 2drop ] if ; parsing - : C-STRUCT: scan in get parse-definition diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index c51c3783d4..05fe3a8093 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -300,7 +300,7 @@ PREDICATE: callable < word register? not ; GENERIC: MOV ( dst src -- ) M: immediate MOV swap (MOV-I) ; -M: callable MOV 0 rot (MOV-I) rc-absolute-cell rel-word ; +M: callable MOV [ 0 ] 2dip (MOV-I) rc-absolute-cell rel-word ; M: operand MOV HEX: 88 2-operand ; : LEA ( dst src -- ) swap HEX: 8d 2-operand ; diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor index a120c8437d..dcff476166 100644 --- a/basis/dlists/dlists.factor +++ b/basis/dlists/dlists.factor @@ -93,11 +93,11 @@ M: dlist peek-front ( dlist -- obj ) M: dlist pop-front* ( dlist -- ) [ - dup front>> [ empty-dlist ] unless* - dup next>> - f rot (>>next) - f over set-prev-when - swap (>>front) + [ + [ empty-dlist ] unless* + [ f ] change-next drop + f over set-prev-when + ] change-front drop ] keep normalize-back ; @@ -106,11 +106,11 @@ M: dlist peek-back ( dlist -- obj ) M: dlist pop-back* ( dlist -- ) [ - dup back>> [ empty-dlist ] unless* - dup prev>> - f rot (>>prev) - f over set-next-when - swap (>>back) + [ + [ empty-dlist ] unless* + [ f ] change-prev drop + f over set-next-when + ] change-back drop ] keep normalize-front ; diff --git a/basis/opengl/gl/extensions/extensions.factor b/basis/opengl/gl/extensions/extensions.factor index 02b1a9a623..ea37829d0e 100644 --- a/basis/opengl/gl/extensions/extensions.factor +++ b/basis/opengl/gl/extensions/extensions.factor @@ -1,6 +1,6 @@ -USING: alien alien.syntax alien.syntax.private combinators +USING: alien alien.syntax alien.parser combinators kernel parser sequences system words namespaces hashtables init -math arrays assocs continuations lexer ; +math arrays assocs continuations lexer fry locals ; IN: opengl.gl.extensions ERROR: unknown-gl-platform ; @@ -30,20 +30,22 @@ reset-gl-function-number-counter : gl-function-pointer ( names n -- funptr ) gl-function-context 2array dup +gl-function-pointers+ get-global at [ 2nip ] [ - >r [ gl-function-address ] map [ ] find nip - dup [ "OpenGL function not available" throw ] unless - dup r> + [ + [ gl-function-address ] map [ ] find nip + dup [ "OpenGL function not available" throw ] unless + dup + ] dip +gl-function-pointers+ get-global set-at ] if* ; : indirect-quot ( function-ptr-quot return types abi -- quot ) - [ alien-indirect ] 3curry compose ; + '[ @ _ _ _ alien-indirect ] ; -: define-indirect ( abi return function-ptr-quot function-name parameters -- ) - [ pick ] dip parse-arglist - rot create-in - [ swapd roll indirect-quot ] 2dip - -rot define-declared ; +:: define-indirect ( abi return function-ptr-quot function-name parameters -- ) + function-name create-in dup reset-generic + function-ptr-quot return + parameters return parse-arglist [ abi indirect-quot ] dip + define-declared ; : GL-FUNCTION: gl-function-calling-convention diff --git a/basis/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor index 5d3b8db19d..a9b3b03b75 100644 --- a/basis/ui/cocoa/cocoa.factor +++ b/basis/ui/cocoa/cocoa.factor @@ -33,16 +33,13 @@ M: pasteboard set-clipboard-contents selection set-global ; : world>NSRect ( world -- NSRect ) - dup window-loc>> first2 rot rect-dim first2 ; + [ window-loc>> ] [ dim>> ] bi [ first2 ] bi@ ; : gadget-window ( world -- ) - [ - dup - dup rot world>NSRect - dup install-window-delegate - over -> release - - ] keep (>>handle) ; + dup + 2dup swap world>NSRect + [ [ -> release ] [ install-window-delegate ] bi* ] [ ] 2bi + >>handle drop ; M: cocoa-ui-backend set-title ( string world -- ) handle>> window>> swap -> setTitle: ; diff --git a/basis/ui/cocoa/views/views-tests.factor b/basis/ui/cocoa/views/views-tests.factor new file mode 100644 index 0000000000..fc64534cfb --- /dev/null +++ b/basis/ui/cocoa/views/views-tests.factor @@ -0,0 +1,15 @@ +IN: ui.cocoa.views.tests +USING: ui.cocoa.views tools.test kernel math.geometry.rect +namespaces ; + +[ t ] [ + T{ rect + { loc { 0 0 } } + { dim { 1000 1000 } } + } "world" set + + T{ rect + { loc { 1.5 2.25 } } + { dim { 13.0 14.0 } } + } dup "world" get rect>NSRect "world" get NSRect>rect = +] unit-test diff --git a/basis/ui/cocoa/views/views.factor b/basis/ui/cocoa/views/views.factor index 1e35fcf4b2..128fdceeb4 100644 --- a/basis/ui/cocoa/views/views.factor +++ b/basis/ui/cocoa/views/views.factor @@ -77,18 +77,22 @@ IN: ui.cocoa.views dup event-modifiers swap button ; : send-button-down$ ( view event -- ) - [ mouse-event>gesture ] - [ mouse-location rot window send-button-down ] 2bi ; + [ nip mouse-event>gesture ] + [ mouse-location ] + [ drop window ] + 2tri send-button-down ; : send-button-up$ ( view event -- ) - [ mouse-event>gesture ] 2keep - mouse-location rot window send-button-up ; + [ nip mouse-event>gesture ] + [ mouse-location ] + [ drop window ] + 2tri send-button-up ; : send-wheel$ ( view event -- ) - [ - dup -> deltaX sgn neg over -> deltaY sgn neg 2array -rot - mouse-location - ] [ drop window ] 2bi send-wheel ; + [ nip [ -> deltaX ] [ -> deltaY ] bi [ sgn neg ] bi@ 2array ] + [ mouse-location ] + [ drop window ] + 2tri send-wheel ; : send-action$ ( view event gesture -- junk ) [ drop window ] dip send-action f ; @@ -103,21 +107,18 @@ IN: ui.cocoa.views [ CF>string NSStringPboardType = ] [ t ] if* ; : valid-service? ( gadget send-type return-type -- ? ) - over string-or-nil? over string-or-nil? and [ - drop [ gadget-selection? ] [ drop t ] if - ] [ - 3drop f - ] if ; + over string-or-nil? over string-or-nil? and + [ drop [ gadget-selection? ] [ drop t ] if ] [ 3drop f ] if ; : NSRect>rect ( NSRect world -- rect ) - [ dup NSRect-x over NSRect-y ] dip - rect-dim second swap - 2array - over NSRect-w rot NSRect-h 2array - ; + [ [ [ NSRect-x ] [ NSRect-y ] bi ] [ dim>> second ] bi* swap - 2array ] + [ drop [ NSRect-w ] [ NSRect-h ] bi 2array ] + 2bi ; : rect>NSRect ( rect world -- NSRect ) - over rect-loc first2 rot rect-dim second swap - - rot rect-dim first2 ; + [ [ rect-loc first2 ] [ dim>> second ] bi* swap - ] + [ drop rect-dim first2 ] + 2bi ; CLASS: { { +superclass+ "NSOpenGLView" } @@ -342,7 +343,7 @@ CLASS: { { "initWithFrame:pixelFormat:" "id" { "id" "SEL" "NSRect" "id" } [ - rot drop + [ drop ] 2dip SUPER-> initWithFrame:pixelFormat: dup dup add-resize-observer ] @@ -351,9 +352,10 @@ CLASS: { { "dealloc" "void" { "id" "SEL" } [ drop - dup unregister-window - dup remove-observer - SUPER-> dealloc + [ unregister-window ] + [ remove-observer ] + [ SUPER-> dealloc ] + tri ] } ; diff --git a/basis/ui/freetype/freetype.factor b/basis/ui/freetype/freetype.factor index 41d000af26..a4ef77e661 100644 --- a/basis/ui/freetype/freetype.factor +++ b/basis/ui/freetype/freetype.factor @@ -97,14 +97,15 @@ SYMBOL: dpi dup handle>> init-descent dup [ ascent>> ] [ descent>> ] bi - ft-ceil >>height ; inline -: set-char-size ( handle size -- ) - 0 swap 6 shift dpi get-global dup FT_Set_Char_Size freetype-error ; +: set-char-size ( open-font size -- open-font ) + [ dup handle>> 0 ] dip + 6 shift dpi get-global dup FT_Set_Char_Size freetype-error ; -: ( handle -- font ) +: ( font -- open-font ) font new H{ } clone >>widths over first2 open-face >>handle - dup handle>> rot third set-char-size + swap third set-char-size init-font ; M: freetype-renderer open-font ( font -- open-font ) @@ -120,7 +121,7 @@ M: freetype-renderer open-font ( font -- open-font ) ] cache nip ; M: freetype-renderer string-width ( open-font string -- w ) - 0 -rot [ char-width + ] with each ; + [ 0 ] 2dip [ char-width + ] with each ; M: freetype-renderer string-height ( open-font string -- h ) drop height>> ; @@ -165,8 +166,9 @@ M: freetype-renderer string-height ( open-font string -- h ) ] with-malloc ; : glyph-texture-loc ( glyph font -- loc ) - over glyph-hori-bearing-x ft-floor -rot - ascent>> swap glyph-hori-bearing-y - ft-floor 2array ; + [ drop glyph-hori-bearing-x ft-floor ] + [ ascent>> swap glyph-hori-bearing-y - ft-floor ] + 2bi 2array ; : glyph-texture-size ( glyph -- dim ) [ glyph-bitmap-width next-power-of-2 ] diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index 0aa50c6276..ad81d18f92 100644 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -138,11 +138,8 @@ M: editor ungraft* f >>focused? relayout-1 ; -: (offset>x) ( font col# str -- x ) - swap head-slice string-width ; - : offset>x ( col# line# editor -- x ) - [ editor-line ] keep editor-font* -rot (offset>x) ; + [ editor-line ] keep editor-font* spin head-slice string-width ; : loc>x ( loc editor -- x ) [ first2 swap ] dip offset>x ; diff --git a/basis/ui/gadgets/gadgets-tests.factor b/basis/ui/gadgets/gadgets-tests.factor index c3a7216910..01d695c281 100644 --- a/basis/ui/gadgets/gadgets-tests.factor +++ b/basis/ui/gadgets/gadgets-tests.factor @@ -152,13 +152,6 @@ M: mock-gadget ungraft* { { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each ] with-string-writer print -[ { { 10 30 } } ] [ - { 0 1 } >>orientation - { { 10 20 } } - { { 100 30 } } - orient -] unit-test - \ must-infer \ unparent must-infer \ add-gadget must-infer diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index 51c8f07225..baf025d116 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -86,15 +86,12 @@ M: gadget children-on nip children>> ; : pick-up ( point gadget -- child/f ) 2dup (pick-up) dup - [ nip [ rect-loc v- ] keep pick-up ] [ rot 2drop ] if ; + [ nip [ rect-loc v- ] keep pick-up ] [ drop nip ] if ; : max-dim ( dims -- dim ) { 0 0 } [ vmax ] reduce ; : dim-sum ( seq -- dim ) { 0 0 } [ v+ ] reduce ; -: orient ( gadget seq1 seq2 -- seq ) - rot orientation>> '[ _ set-axis ] 2map ; - : each-child ( gadget quot -- ) [ children>> ] dip each ; inline diff --git a/basis/ui/gadgets/grids/grids.factor b/basis/ui/gadgets/grids/grids.factor index 386457551f..eab8833120 100644 --- a/basis/ui/gadgets/grids/grids.factor +++ b/basis/ui/gadgets/grids/grids.factor @@ -18,14 +18,14 @@ grid : ( children -- grid ) grid new-grid ; -: grid-child ( grid i j -- gadget ) rot grid>> nth nth ; +:: grid-child ( grid i j -- gadget ) i j grid grid>> nth nth ; :: grid-add ( grid child i j -- grid ) grid i j grid-child unparent grid child add-gadget child i j grid grid>> nth set-nth ; -: grid-remove ( grid i j -- grid ) -rot grid-add ; +: grid-remove ( grid i j -- grid ) [ ] 2dip grid-add ; : pref-dim-grid ( grid -- dims ) grid>> [ [ pref-dim ] map ] map ; diff --git a/basis/ui/gadgets/labelled/labelled.factor b/basis/ui/gadgets/labelled/labelled.factor index e4343e6280..108c5ae461 100644 --- a/basis/ui/gadgets/labelled/labelled.factor +++ b/basis/ui/gadgets/labelled/labelled.factor @@ -48,9 +48,10 @@ TUPLE: closable-gadget < frame content ; [ closable-gadget? ] find-parent ; : ( gadget title quot -- gadget ) - closable-gadget new-frame - -rot @top grid-add - swap >>content - dup content>> @center grid-add ; + [ + [ closable-gadget new-frame ] dip + [ >>content ] [ @center grid-add ] bi + ] 2dip + @top grid-add ; M: closable-gadget focusable-child* content>> ; diff --git a/basis/ui/gadgets/packs/packs-tests.factor b/basis/ui/gadgets/packs/packs-tests.factor index 065267d7be..8b52a2ad2f 100644 --- a/basis/ui/gadgets/packs/packs-tests.factor +++ b/basis/ui/gadgets/packs/packs-tests.factor @@ -1,6 +1,7 @@ IN: ui.gadgets.packs.tests USING: ui.gadgets.packs ui.gadgets.labels ui.gadgets ui.render -kernel namespaces tools.test math.parser sequences math.geometry.rect ; +kernel namespaces tools.test math.parser sequences math.geometry.rect +accessors ; [ t ] [ { 0 0 } { 100 100 } clip set @@ -11,3 +12,10 @@ kernel namespaces tools.test math.parser sequences math.geometry.rect ; visible-children [ label? ] all? ] unit-test + +[ { { 10 30 } } ] [ + { { 10 20 } } + { { 100 30 } } + { 0 1 } >>orientation + orient +] unit-test diff --git a/basis/ui/gadgets/packs/packs.factor b/basis/ui/gadgets/packs/packs.factor index 5965e8b568..86dc6ea354 100644 --- a/basis/ui/gadgets/packs/packs.factor +++ b/basis/ui/gadgets/packs/packs.factor @@ -1,28 +1,30 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: sequences ui.gadgets kernel math math.functions -math.vectors namespaces math.order accessors math.geometry.rect ; +math.vectors math.order math.geometry.rect namespaces accessors +fry ; IN: ui.gadgets.packs TUPLE: pack < gadget - { align initial: 0 } - { fill initial: 0 } - { gap initial: { 0 0 } } ; +{ align initial: 0 } { fill initial: 0 } { gap initial: { 0 0 } } ; : packed-dim-2 ( gadget sizes -- list ) - [ over rect-dim over v- rot fill>> v*n v+ ] with map ; + swap [ dim>> ] [ fill>> ] bi '[ _ over v- _ v*n v+ ] map ; + +: orient ( seq1 seq2 gadget -- seq ) + orientation>> '[ _ set-axis ] 2map ; : packed-dims ( gadget sizes -- seq ) - 2dup packed-dim-2 swap orient ; + [ packed-dim-2 ] [ nip ] [ drop ] 2tri orient ; : gap-locs ( gap sizes -- seq ) { 0 0 } [ v+ over v+ ] accumulate 2nip ; : aligned-locs ( gadget sizes -- seq ) - [ [ dup align>> swap rect-dim ] dip v- n*v ] with map ; + [ [ [ align>> ] [ dim>> ] bi ] dip v- n*v ] with map ; : packed-locs ( gadget sizes -- seq ) - over gap>> over gap-locs [ dupd aligned-locs ] dip orient ; + [ aligned-locs ] [ [ gap>> ] dip gap-locs ] [ drop ] 2tri orient ; : round-dims ( seq -- newseq ) { 0 0 } swap @@ -45,12 +47,14 @@ TUPLE: pack < gadget : ( -- pack ) { 1 0 } ; -: gap-dims ( gap sizes -- seeq ) - [ dim-sum ] keep length 1 [-] rot n*v v+ ; +: gap-dims ( sizes gadget -- seeq ) + [ [ dim-sum ] [ length 1 [-] ] bi ] [ gap>> ] bi* n*v v+ ; : pack-pref-dim ( gadget sizes -- dim ) - over gap>> over gap-dims [ max-dim ] dip - rot orientation>> set-axis ; + [ nip max-dim ] + [ swap gap-dims ] + [ drop orientation>> ] + 2tri set-axis ; M: pack pref-dim* dup children>> pref-dims pack-pref-dim ; diff --git a/basis/ui/gadgets/paragraphs/paragraphs.factor b/basis/ui/gadgets/paragraphs/paragraphs.factor index 216f21af27..6e26a2989f 100644 --- a/basis/ui/gadgets/paragraphs/paragraphs.factor +++ b/basis/ui/gadgets/paragraphs/paragraphs.factor @@ -1,7 +1,8 @@ -! Copyright (C) 2005, 2007 Slava Pestov +! Copyright (C) 2005, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays ui.gadgets ui.gadgets.labels ui.render kernel math -namespaces sequences math.order math.geometry.rect ; +USING: accessors arrays ui.gadgets ui.gadgets.labels ui.render +kernel math namespaces sequences math.order math.geometry.rect +locals ; IN: ui.gadgets.paragraphs ! A word break gadget @@ -46,12 +47,19 @@ SYMBOL: margin dup line-height [ max ] change y get + max-y [ max ] change ; -: wrap-step ( quot child -- ) - dup pref-dim [ - over word-break-gadget? [ - dup first overrun? [ wrap-line ] when - ] unless drop wrap-pos rot call - ] keep first2 advance-y advance-x ; inline +:: wrap-step ( quot child -- ) + child pref-dim + [ + child + [ + word-break-gadget? + [ drop ] [ first overrun? [ wrap-line ] when ] if + ] + [ wrap-pos quot call ] bi + ] + [ first advance-x ] + [ second advance-y ] + tri ; inline : wrap-dim ( -- dim ) max-x get max-y get 2array ; diff --git a/basis/ui/gadgets/sliders/sliders.factor b/basis/ui/gadgets/sliders/sliders.factor index 968972a869..9e13e5ad7c 100644 --- a/basis/ui/gadgets/sliders/sliders.factor +++ b/basis/ui/gadgets/sliders/sliders.factor @@ -26,10 +26,11 @@ TUPLE: slider < frame elevator thumb saved line ; : slider-max* ( gadget -- n ) model>> range-max-value* ; : thumb-dim ( slider -- h ) - dup slider-page over slider-max 1 max / 1 min - over elevator-length * min-thumb-dim max - over elevator>> rect-dim - rot orientation>> v. min ; + [ + [ [ slider-page ] [ slider-max 1 max ] bi / 1 min ] + [ elevator-length ] bi * min-thumb-dim max + ] + [ [ elevator>> dim>> ] [ orientation>> ] bi v. ] bi min ; : slider-scale ( slider -- n ) #! A scaling factor such that if x is a slider co-ordinate, @@ -109,8 +110,8 @@ elevator H{ : layout-thumb-dim ( slider -- ) dup dup thumb-dim (layout-thumb) [ - [ dup rect-dim ] dip - rot orientation>> set-axis [ ceiling ] map + [ [ rect-dim ] dip ] [ drop orientation>> ] 2bi set-axis + [ ceiling ] map ] dip (>>dim) ; : layout-thumb ( slider -- ) diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 98c3258911..68a2a18210 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs continuations kernel math models -namespaces opengl sequences io combinators math.vectors +namespaces opengl sequences io combinators fry math.vectors ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks debugger math.geometry.rect ; IN: ui.gadgets.worlds @@ -67,9 +67,7 @@ M: world children-on nip children>> ; : draw-world? ( world -- ? ) #! We don't draw deactivated worlds, or those with 0 size. #! On Windows, the latter case results in GL errors. - dup active?>> - over handle>> - rot rect-dim [ 0 > ] all? and and ; + [ active?>> ] [ handle>> ] [ dim>> [ 0 > ] all? ] tri and and ; TUPLE: world-error error world ; @@ -127,5 +125,4 @@ M: world handle-gesture ( gesture gadget -- ? ) ] [ 2drop f ] if ; : close-global ( world global -- ) - dup get-global find-world rot eq? - [ f swap set-global ] [ drop ] if ; + [ get-global find-world eq? ] keep '[ f _ set-global ] when ; diff --git a/basis/ui/operations/operations.factor b/basis/ui/operations/operations.factor index 660ae1f43d..bcfca946dd 100644 --- a/basis/ui/operations/operations.factor +++ b/basis/ui/operations/operations.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays definitions kernel ui.commands ui.gestures sequences strings math words generic namespaces make -hashtables help.markup quotations assocs ; +hashtables help.markup quotations assocs fry ; IN: ui.operations SYMBOL: +keyboard+ @@ -63,7 +63,7 @@ SYMBOL: operations t >>listener? ; : modify-operations ( operations hook translator -- operations ) - rot [ modify-operation ] with with map ; + '[ [ _ _ ] dip modify-operation ] map ; : operations>commands ( object hook translator -- pairs ) [ object-operations ] 2dip modify-operations diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor index 55b8a82ac1..4ce36dc3bd 100755 --- a/basis/ui/render/render.factor +++ b/basis/ui/render/render.factor @@ -227,7 +227,7 @@ HOOK: free-fonts font-renderer ( world -- ) dup string? [ string-width ] [ - 0 -rot [ string-width max ] with each + [ 0 ] 2dip [ string-width max ] with each ] if ; : text-dim ( open-font text -- dim ) diff --git a/basis/ui/tools/deploy/deploy.factor b/basis/ui/tools/deploy/deploy.factor index 5a99d1174b..127269b325 100644 --- a/basis/ui/tools/deploy/deploy.factor +++ b/basis/ui/tools/deploy/deploy.factor @@ -117,5 +117,7 @@ deploy-gadget "toolbar" f { dup com-revert ; : deploy-tool ( vocab -- ) - vocab-name dup 10 - "Deploying \"" rot "\"" 3append open-window ; + vocab-name + [ 10 ] + [ "Deploying \"" swap "\"" 3append ] bi + open-window ; diff --git a/basis/ui/traverse/traverse.factor b/basis/ui/traverse/traverse.factor index 5135c3da6e..7a012aa3e0 100644 --- a/basis/ui/traverse/traverse.factor +++ b/basis/ui/traverse/traverse.factor @@ -59,15 +59,15 @@ TUPLE: node value children ; DEFER: (gadget-subtree) : traverse-child ( frompath topath gadget -- ) - [ -rot ] keep [ - [ rest-slice ] 2dip traverse-step (gadget-subtree) - ] make-node ; + [ 2nip ] 3keep + [ [ rest-slice ] 2dip traverse-step (gadget-subtree) ] + make-node ; : (gadget-subtree) ( frompath topath gadget -- ) { { [ dup not ] [ 3drop ] } { [ pick empty? pick empty? and ] [ 2nip , ] } - { [ pick empty? ] [ rot drop traverse-to-path ] } + { [ pick empty? ] [ traverse-to-path drop ] } { [ over empty? ] [ nip traverse-from-path ] } { [ pick first pick first = ] [ traverse-child ] } [ traverse-middle ] diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor index 6e1ce8f77f..cb63833edd 100755 --- a/basis/ui/windows/windows.factor +++ b/basis/ui/windows/windows.factor @@ -296,8 +296,10 @@ SYMBOL: nc-buttons key-modifiers swap message>button [ ] [ ] if ; -: prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world ) - [ drop mouse-event>gesture ] dip >lo-hi rot window ; +:: prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world ) + uMsg mouse-event>gesture + lParam >lo-hi + hWnd window ; : set-capture ( hwnd -- ) mouse-captured get [ @@ -435,7 +437,7 @@ M: windows-ui-backend do-events style 0 ex-style AdjustWindowRectEx win32-error=0/f ; : make-RECT ( world -- RECT ) - dup window-loc>> dup rot rect-dim v+ + [ window-loc>> dup ] [ rect-dim ] bi v+ "RECT" over first over set-RECT-right swap second over set-RECT-bottom diff --git a/basis/ui/x11/x11.factor b/basis/ui/x11/x11.factor index b9889c75d4..b5c71bc3fb 100644 --- a/basis/ui/x11/x11.factor +++ b/basis/ui/x11/x11.factor @@ -95,8 +95,10 @@ M: world key-up-event [ 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 ; + [ event-modifiers ] + [ XButtonEvent-button ] + [ mouse-event-loc ] + tri ; M: world button-down-event [ mouse-event>gesture [ ] dip ] dip @@ -222,8 +224,8 @@ M: x-clipboard paste-clipboard 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 ; + handle>> window>> swap + [ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ; M: x11-ui-backend set-fullscreen* ( ? world -- ) handle>> window>> "XClientMessageEvent"