steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Code cleanup: refactoring usages of rot and -rot to use newer idioms instead

db4
Slava Pestov 2008-11-30 17:47:29 -06:00
parent 9bba10c970
commit 3e25d14e54
27 changed files with 189 additions and 170 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
basis/alien/parser/parser.factor Normal file
View File

@ -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* <effect> ;
: 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 ;

14
basis/alien/structs/fields/fields.factor
View File

@ -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 ;

12
basis/alien/syntax/syntax-docs.factor
View File

@ -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" } }

22
basis/alien/syntax/syntax.factor
View File

@ -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
<PRIVATE
: parse-arglist ( return seq -- types effect )
2 group dup keys swap values [ "," ?tail drop ] map
rot dup "void" = [ drop { } ] [ 1array ] if <effect> ;
: 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 <alien> 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

2
basis/cpu/x86/assembler/assembler.factor
View File

@ -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 ;

20
basis/dlists/dlists.factor
View File

@ -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 ;

24
basis/opengl/gl/extensions/extensions.factor
View File

@ -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

13
basis/ui/cocoa/cocoa.factor
View File

@ -33,16 +33,13 @@ M: pasteboard set-clipboard-contents
<clipboard> selection set-global ;
: world>NSRect ( world -- NSRect )
dup window-loc>> first2 rot rect-dim first2 <NSRect> ;
[ window-loc>> ] [ dim>> ] bi [ first2 ] bi@ <NSRect> ;
: gadget-window ( world -- )
[
dup <FactorView>
dup rot world>NSRect <ViewWindow>
dup install-window-delegate
over -> release
<handle>
] keep (>>handle) ;
dup <FactorView>
2dup swap world>NSRect <ViewWindow>
[ [ -> release ] [ install-window-delegate ] bi* ] [ <handle> ] 2bi
>>handle drop ;
M: cocoa-ui-backend set-title ( string world -- )
handle>> window>> swap <NSString> -> setTitle: ;

15
basis/ui/cocoa/views/views-tests.factor Normal file
View File

@ -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

48
basis/ui/cocoa/views/views.factor
View File

@ -77,18 +77,22 @@ IN: ui.cocoa.views
dup event-modifiers swap button ;
: send-button-down$ ( view event -- )
[ mouse-event>gesture <button-down> ]
[ mouse-location rot window send-button-down ] 2bi ;
[ nip mouse-event>gesture <button-down> ]
[ mouse-location ]
[ drop window ]
2tri send-button-down ;
: send-button-up$ ( view event -- )
[ mouse-event>gesture <button-up> ] 2keep
mouse-location rot window send-button-up ;
[ nip mouse-event>gesture <button-up> ]
[ 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
<rect> ;
[ [ [ NSRect-x ] [ NSRect-y ] bi ] [ dim>> second ] bi* swap - 2array ]
[ drop [ NSRect-w ] [ NSRect-h ] bi 2array ]
2bi <rect> ;
: rect>NSRect ( rect world -- NSRect )
over rect-loc first2 rot rect-dim second swap -
rot rect-dim first2 <NSRect> ;
[ [ rect-loc first2 ] [ dim>> second ] bi* swap - ]
[ drop rect-dim first2 ]
2bi <NSRect> ;
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
]
} ;

16
basis/ui/freetype/freetype.factor
View File

@ -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 ;
: <font> ( handle -- font )
: <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 ]

5
basis/ui/gadgets/editors/editors.factor
View File

@ -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 ;

7
basis/ui/gadgets/gadgets-tests.factor
View File

@ -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 } } ] [
<gadget> { 0 1 } >>orientation
{ { 10 20 } }
{ { 100 30 } }
orient
] unit-test
\ <gadget> must-infer
\ unparent must-infer
\ add-gadget must-infer

5
basis/ui/gadgets/gadgets.factor
View File

@ -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

4
basis/ui/gadgets/grids/grids.factor
View File

@ -18,14 +18,14 @@ grid
: <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 ) <gadget> -rot grid-add ;
: grid-remove ( grid i j -- grid ) [ <gadget> ] 2dip grid-add ;
: pref-dim-grid ( grid -- dims )
grid>> [ [ pref-dim ] map ] map ;

9
basis/ui/gadgets/labelled/labelled.factor
View File

@ -48,9 +48,10 @@ TUPLE: closable-gadget < frame content ;
[ closable-gadget? ] find-parent ;
: <closable-gadget> ( gadget title quot -- gadget )
closable-gadget new-frame
-rot <title-bar> @top grid-add
swap >>content
dup content>> @center grid-add ;
[
[ closable-gadget new-frame ] dip
[ >>content ] [ @center grid-add ] bi
] 2dip
<title-bar> @top grid-add ;
M: closable-gadget focusable-child* content>> ;

10
basis/ui/gadgets/packs/packs-tests.factor
View File

@ -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 } <rect> 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 } }
<gadget> { 0 1 } >>orientation
orient
] unit-test

28
basis/ui/gadgets/packs/packs.factor
View File

@ -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
: <shelf> ( -- pack ) { 1 0 } <pack> ;
: 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 ;

26
basis/ui/gadgets/paragraphs/paragraphs.factor
View File

@ -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 ;

13
basis/ui/gadgets/sliders/sliders.factor
View File

@ -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 -- )

9
basis/ui/gadgets/worlds/worlds.factor
View File

@ -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 ;

4
basis/ui/operations/operations.factor
View File

@ -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

2
basis/ui/render/render.factor
View File

@ -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 )

6
basis/ui/tools/deploy/deploy.factor
View File

@ -117,5 +117,7 @@ deploy-gadget "toolbar" f {
dup com-revert ;
: deploy-tool ( vocab -- )
vocab-name dup <deploy-gadget> 10 <border>
"Deploying \"" rot "\"" 3append open-window ;
vocab-name
[ <deploy-gadget> 10 <border> ]
[ "Deploying \"" swap "\"" 3append ] bi
open-window ;

8
basis/ui/traverse/traverse.factor
View File

@ -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 ]

8
basis/ui/windows/windows.factor
View File

@ -296,8 +296,10 @@ SYMBOL: nc-buttons
key-modifiers swap message>button
[ <button-down> ] [ <button-up> ] 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" <c-object>
over first over set-RECT-right
swap second over set-RECT-bottom

10
basis/ui/x11/x11.factor
View File

@ -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 [ <button-down> ] 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" <c-object>