--- /dev/null
+! 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 ;
[ (>>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 ;
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\"" }
{ $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" } }
{ $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" } }
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
: TYPEDEF:
scan scan typedef ; parsing
-: TYPEDEF-IF:
- scan-word execute scan scan rot [ typedef ] [ 2drop ] if ; parsing
-
: C-STRUCT:
scan in get
parse-definition
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 ;
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 ;
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 ;
-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 ;
: 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
<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: ;
--- /dev/null
+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
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 ;
[ 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" }
{ "initWithFrame:pixelFormat:" "id" { "id" "SEL" "NSRect" "id" }
[
- rot drop
+ [ drop ] 2dip
SUPER-> initWithFrame:pixelFormat:
dup dup add-resize-observer
]
{ "dealloc" "void" { "id" "SEL" }
[
drop
- dup unregister-window
- dup remove-observer
- SUPER-> dealloc
+ [ unregister-window ]
+ [ remove-observer ]
+ [ SUPER-> dealloc ]
+ tri
]
} ;
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 )
] 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>> ;
] 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 ]
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 ;
{ { 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
: 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
: <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 ;
[ 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>> ;
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
visible-children [ label? ] all?
] unit-test
+
+[ { { 10 30 } } ] [
+ { { 10 20 } }
+ { { 100 30 } }
+ <gadget> { 0 1 } >>orientation
+ orient
+] unit-test
! 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
: <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 ;
-! 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
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 ;
: 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,
: 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 -- )
! 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
: 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 ;
] [ 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 ;
! 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+
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
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 )
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 ;
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 ]
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 [
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
[ 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
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>
projects / factor.git / commitdiff