! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings arrays assocs
- continuations combinators compiler compiler.alien kernel math
- namespaces make parser quotations sequences strings words
- cocoa.runtime io macros memoize io.encodings.utf8
- effects libc libc.private parser lexer init core-foundation fry
- generalizations specialized-arrays.direct.alien call ;
+ continuations combinators compiler compiler.alien stack-checker kernel
+ math namespaces make parser quotations sequences strings words
+ cocoa.runtime io macros memoize io.encodings.utf8 effects libc
+ libc.private parser lexer init core-foundation fry generalizations
+ specialized-arrays.direct.alien call ;
IN: cocoa.messages
: make-sender ( method function -- quot )
: sender-stub ( method function -- word )
[ "( sender-stub )" f <word> dup ] 2dip
over first large-struct? [ "_stret" append ] when
- make-sender define ;
+ make-sender dup infer define-declared ;
SYMBOL: message-senders
SYMBOL: super-message-senders
drop "void*"
] unless ;
+ERROR: no-objc-type name ;
+
+: decode-type ( ch -- ctype )
+ 1string dup objc>alien-types get at
+ [ ] [ no-objc-type ] ?if ;
+
: (parse-objc-type) ( i string -- ctype )
[ [ 1+ ] dip ] [ nth ] 2bi {
{ [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
{ [ dup CHAR: ^ = ] [ 3drop "void*" ] }
{ [ dup CHAR: { = ] [ drop objc-struct-type ] }
{ [ dup CHAR: [ = ] [ 3drop "void*" ] }
- [ 2nip 1string objc>alien-types get at ]
+ [ 2nip decode-type ]
} cond ;
: parse-objc-type ( string -- ctype ) 0 swap (parse-objc-type) ;
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.accessors arrays kernel cocoa.messages
cocoa.classes cocoa.application sequences cocoa core-foundation
core-foundation.strings core-foundation.arrays ;
IN: cocoa.pasteboard
- : NSStringPboardType "NSStringPboardType" ;
+ CONSTANT: NSStringPboardType "NSStringPboardType"
: pasteboard-string? ( pasteboard -- ? )
NSStringPboardType swap -> types CF>string-array member? ;
dup [ CF>string ] when ;
: set-pasteboard-types ( seq pasteboard -- )
- swap <NSArray> f -> declareTypes:owner: drop ;
+ swap <CFArray> -> autorelease f -> declareTypes:owner: drop ;
: set-pasteboard-string ( str pasteboard -- )
NSStringPboardType <NSString>
[ add-protocols ] [ add-methods ] [ objc_registerClassPair ]
tri ;
+: encode-type ( type -- encoded )
+ dup alien>objc-types get at [ ] [ no-objc-type ] ?if ;
+
: encode-types ( return types -- encoding )
- swap prefix [
- alien>objc-types get at "0" append
- ] map concat ;
+ swap prefix [ encode-type "0" append ] map concat ;
: prepare-method ( ret types quot -- type imp )
- [ [ encode-types ] 2keep ] dip [
- "cdecl" swap 4array % \ alien-callback ,
- ] [ ] make define-temp ;
+ [ [ encode-types ] 2keep ] dip
+ '[ _ _ "cdecl" _ alien-callback ]
+ (( -- callback )) define-temp ;
: prepare-methods ( methods -- methods )
[
-! Copyright (C) 2006, 2008 Slava Pestov
+! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: specialized-arrays.int arrays kernel math namespaces make
-cocoa cocoa.messages cocoa.classes cocoa.types sequences
+cocoa cocoa.messages cocoa.classes core-graphics.types sequences
continuations accessors ;
IN: cocoa.views
CONSTANT: NSOpenGLPFAPixelBuffer 90
CONSTANT: NSOpenGLPFAAllowOfflineRenderers 96
CONSTANT: NSOpenGLPFAVirtualScreenCount 128
--
--CONSTANT: kCGLRendererGenericFloatID HEX: 00020400
-
-
+CONSTANT: NSOpenGLCPSwapInterval 222
<PRIVATE
-SYMBOL: +software-renderer+
-SYMBOL: +multisample+
+SYMBOL: software-renderer?
+SYMBOL: multisample?
PRIVATE>
: with-software-renderer ( quot -- )
- t +software-renderer+ pick with-variable ; inline
+ [ t software-renderer? ] dip with-variable ; inline
+
: with-multisample ( quot -- )
- t +multisample+ pick with-variable ; inline
+ [ t multisample? ] dip with-variable ; inline
: <PixelFormat> ( attributes -- pixelfmt )
NSOpenGLPixelFormat -> alloc swap [
%
NSOpenGLPFADepthSize , 16 ,
- +software-renderer+ get [
+ software-renderer? get [
NSOpenGLPFARendererID , kCGLRendererGenericFloatID ,
] when
- +multisample+ get [
+ multisample? get [
NSOpenGLPFASupersample ,
NSOpenGLPFASampleBuffers , 1 ,
NSOpenGLPFASamples , 8 ,
-> autorelease ;
: <GLView> ( class dim -- view )
- [ -> alloc 0 0 ] dip first2 <NSRect>
+ [ -> alloc 0 0 ] dip first2 <CGRect>
NSOpenGLPFAWindow NSOpenGLPFADoubleBuffer 2array <PixelFormat>
-> initWithFrame:pixelFormat:
dup 1 -> setPostsBoundsChangedNotifications:
: view-dim ( view -- dim )
-> bounds
- dup NSRect-w >fixnum
- swap NSRect-h >fixnum 2array ;
+ [ CGRect-w >fixnum ] [ CGRect-h >fixnum ] bi
+ 2array ;
: mouse-location ( view event -- loc )
[
-> locationInWindow f -> convertPoint:fromView:
- [ NSPoint-x ] [ NSPoint-y ] bi
- ] [ drop -> frame NSRect-h ] 2bi
+ [ CGPoint-x ] [ CGPoint-y ] bi
+ ] [ drop -> frame CGRect-h ] 2bi
swap - 2array ;
-
-USE: opengl.gl
-USE: alien.syntax
-
-CONSTANT: NSOpenGLCPSwapInterval 222
-
-LIBRARY: OpenGL
-
-TYPEDEF: int CGLError
-TYPEDEF: void* CGLContextObj
-TYPEDEF: int CGLContextParameter
-
-FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;
-
--- /dev/null
- FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;
-
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.destructors alien.syntax accessors
+destructors fry kernel math math.bitwise sequences libc colors
+images core-graphics.types core-foundation.utilities ;
+IN: core-graphics
+
+! CGImageAlphaInfo
+C-ENUM:
+kCGImageAlphaNone
+kCGImageAlphaPremultipliedLast
+kCGImageAlphaPremultipliedFirst
+kCGImageAlphaLast
+kCGImageAlphaFirst
+kCGImageAlphaNoneSkipLast
+kCGImageAlphaNoneSkipFirst ;
+
+: kCGBitmapAlphaInfoMask ( -- n ) HEX: 1f ; inline
+: kCGBitmapFloatComponents ( -- n ) 1 8 shift ; inline
+
+: kCGBitmapByteOrderMask ( -- n ) HEX: 7000 ; inline
+: kCGBitmapByteOrderDefault ( -- n ) 0 12 shift ; inline
+: kCGBitmapByteOrder16Little ( -- n ) 1 12 shift ; inline
+: kCGBitmapByteOrder32Little ( -- n ) 2 12 shift ; inline
+: kCGBitmapByteOrder16Big ( -- n ) 3 12 shift ; inline
+: kCGBitmapByteOrder32Big ( -- n ) 4 12 shift ; inline
+
+: kCGBitmapByteOrder16Host ( -- n )
+ little-endian?
+ kCGBitmapByteOrder16Little
+ kCGBitmapByteOrder16Big ? ; foldable
+
+: kCGBitmapByteOrder32Host ( -- n )
+ little-endian?
+ kCGBitmapByteOrder32Little
+ kCGBitmapByteOrder32Big ? ; foldable
+
+FUNCTION: CGColorRef CGColorCreateGenericRGB (
+ CGFloat red,
+ CGFloat green,
+ CGFloat blue,
+ CGFloat alpha
+) ;
+
+: <CGColor> ( color -- CGColor )
+ >rgba-components CGColorCreateGenericRGB ;
+
+M: color (>cf) <CGColor> ;
+
+FUNCTION: CGColorSpaceRef CGColorSpaceCreateDeviceRGB ( ) ;
+
+FUNCTION: CGContextRef CGBitmapContextCreate (
+ void* data,
+ size_t width,
+ size_t height,
+ size_t bitsPerComponent,
+ size_t bytesPerRow,
+ CGColorSpaceRef colorspace,
+ CGBitmapInfo bitmapInfo
+) ;
+
+FUNCTION: void CGColorSpaceRelease ( CGColorSpaceRef ref ) ;
+
+DESTRUCTOR: CGColorSpaceRelease
+
+FUNCTION: void CGContextRelease ( CGContextRef ref ) ;
+
+DESTRUCTOR: CGContextRelease
+
+FUNCTION: void CGContextSetRGBStrokeColor (
+ CGContextRef c,
+ CGFloat red,
+ CGFloat green,
+ CGFloat blue,
+ CGFloat alpha
+) ;
+
+FUNCTION: void CGContextSetRGBFillColor (
+ CGContextRef c,
+ CGFloat red,
+ CGFloat green,
+ CGFloat blue,
+ CGFloat alpha
+) ;
+
+FUNCTION: void CGContextSetTextPosition (
+ CGContextRef c,
+ CGFloat x,
+ CGFloat y
+) ;
+
+FUNCTION: void CGContextFillRect (
+ CGContextRef c,
+ CGRect rect
+) ;
+
+FUNCTION: void CGContextSetShouldSmoothFonts (
+ CGContextRef c,
+ bool shouldSmoothFonts
+) ;
+
+FUNCTION: void* CGBitmapContextGetData ( CGContextRef c ) ;
+
++CONSTANT: kCGLRendererGenericFloatID HEX: 00020400
++
++FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;
++
+<PRIVATE
+
+: bitmap-flags ( -- flags )
+ { kCGImageAlphaPremultipliedFirst kCGBitmapByteOrder32Host } flags ;
+
+: bitmap-size ( dim -- n )
+ product "uint" heap-size * ;
+
+: malloc-bitmap-data ( dim -- alien )
+ bitmap-size 1 calloc &free ;
+
+: bitmap-color-space ( -- color-space )
+ CGColorSpaceCreateDeviceRGB &CGColorSpaceRelease ;
+
+: <CGBitmapContext> ( data dim -- context )
+ [ first2 8 ] [ first 4 * ] bi
+ bitmap-color-space bitmap-flags CGBitmapContextCreate
+ [ "CGBitmapContextCreate failed" throw ] unless* ;
+
+: bitmap-data ( bitmap dim -- data )
+ [ CGBitmapContextGetData ] [ bitmap-size ] bi*
+ memory>byte-array ;
+
+: <bitmap-image> ( bitmap dim -- image )
+ <image>
+ swap >>dim
+ swap >>bitmap
+ little-endian? ARGB BGRA ? >>component-order ;
+
+PRIVATE>
+
+: dummy-context ( -- context )
+ \ dummy-context [
+ [ 4 malloc { 1 1 } <CGBitmapContext> ] with-destructors
+ ] initialize-alien ;
+
+: make-bitmap-image ( dim quot -- image )
+ [
+ [ [ [ malloc-bitmap-data ] keep <CGBitmapContext> &CGContextRelease ] keep ] dip
+ [ nip call ] [ drop [ bitmap-data ] keep <bitmap-image> ] 3bi
+ ] with-destructors ; inline
: CHLOE:
scan parse-definition define-chloe-tag ; parsing
- : chloe-ns "http://factorcode.org/chloe/1.0" ; inline
+ CONSTANT: chloe-ns "http://factorcode.org/chloe/1.0"
: chloe-name? ( name -- ? )
url>> chloe-ns = ;
XML-NS: chloe-name http://factorcode.org/chloe/1.0
: required-attr ( tag name -- value )
- tuck chloe-name attr
- [ nip ] [ " attribute is required" append throw ] if* ;
+ [ nip ] [ chloe-name attr ] 2bi
+ [ ] [ " attribute is required" append throw ] ?if ;
: optional-attr ( tag name -- value )
chloe-name attr ;
--- /dev/null
- : wm-keydown-codes ( -- key )
+! Copyright (C) 2005, 2006 Doug Coleman.
+! Portions copyright (C) 2007, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.strings arrays assocs ui
+ui.gadgets ui.backend ui.clipboards ui.gadgets.worlds
+ui.gestures ui.event-loop io kernel math
+math.vectors namespaces make sequences strings vectors words
+windows.kernel32 windows.gdi32 windows.user32 windows.opengl32
+windows.messages windows.types windows.nt windows threads libc
+combinators fry combinators.short-circuit continuations
+command-line shuffle opengl ui.render ascii math.bitwise locals
+accessors math.rectangles math.order ascii calendar
+io.encodings.utf16n ;
+IN: ui.backend.windows
+
+SINGLETON: windows-ui-backend
+
+: crlf>lf ( str -- str' )
+ CHAR: \r swap remove ;
+
+: lf>crlf ( str -- str' )
+ [ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ;
+
+: enum-clipboard ( -- seq )
+ 0
+ [ EnumClipboardFormats win32-error dup dup 0 > ]
+ [ ]
+ [ drop ]
+ produce nip ;
+
+: with-clipboard ( quot -- )
+ f OpenClipboard win32-error=0/f
+ call
+ CloseClipboard win32-error=0/f ; inline
+
+: paste ( -- str )
+ [
+ CF_UNICODETEXT IsClipboardFormatAvailable zero? [
+ ! nothing to paste
+ ""
+ ] [
+ CF_UNICODETEXT GetClipboardData dup win32-error=0/f
+ dup GlobalLock dup win32-error=0/f
+ GlobalUnlock win32-error=0/f
+ utf16n alien>string
+ ] if
+ ] with-clipboard
+ crlf>lf ;
+
+: copy ( str -- )
+ lf>crlf [
+ utf16n string>alien
+ EmptyClipboard win32-error=0/f
+ GMEM_MOVEABLE over length 1+ GlobalAlloc
+ dup win32-error=0/f
+
+ dup GlobalLock dup win32-error=0/f
+ swapd byte-array>memory
+ dup GlobalUnlock win32-error=0/f
+ CF_UNICODETEXT swap SetClipboardData win32-error=0/f
+ ] with-clipboard ;
+
+TUPLE: pasteboard ;
+C: <pasteboard> pasteboard
+
+M: pasteboard clipboard-contents drop paste ;
+M: pasteboard set-clipboard-contents drop copy ;
+
+: init-clipboard ( -- )
+ <pasteboard> clipboard set-global
+ <clipboard> selection set-global ;
+
+TUPLE: win-base hDC hRC ;
+TUPLE: win < win-base hWnd world title ;
+TUPLE: win-offscreen < win-base hBitmap bits ;
+C: <win> win
+C: <win-offscreen> win-offscreen
+
+SYMBOLS: msg-obj class-name-ptr mouse-captured ;
+
+: style ( -- n ) WS_OVERLAPPEDWINDOW ; inline
+: ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline
+
+: get-RECT-top-left ( RECT -- x y )
+ [ RECT-left ] keep RECT-top ;
+
+: get-RECT-dimensions ( RECT -- x y width height )
+ [ get-RECT-top-left ] keep
+ [ RECT-right ] keep [ RECT-left - ] keep
+ [ RECT-bottom ] keep RECT-top - ;
+
+: handle-wm-paint ( hWnd uMsg wParam lParam -- )
+ #! wParam and lParam are unused
+ #! only paint if width/height both > 0
+ 3drop window relayout-1 yield ;
+
+: handle-wm-size ( hWnd uMsg wParam lParam -- )
+ 2nip
+ [ lo-word ] keep hi-word 2array
+ dup { 0 0 } = [ 2drop ] [ swap window (>>dim) ] if ;
+
+: handle-wm-move ( hWnd uMsg wParam lParam -- )
+ 2nip
+ [ lo-word ] keep hi-word 2array
+ swap window (>>window-loc) ;
+
- } ;
++CONSTANT: wm-keydown-codes
+ H{
+ { 8 "BACKSPACE" }
+ { 9 "TAB" }
+ { 13 "RET" }
+ { 27 "ESC" }
+ { 33 "PAGE_UP" }
+ { 34 "PAGE_DOWN" }
+ { 35 "END" }
+ { 36 "HOME" }
+ { 37 "LEFT" }
+ { 38 "UP" }
+ { 39 "RIGHT" }
+ { 40 "DOWN" }
+ { 45 "INSERT" }
+ { 46 "DELETE" }
+ { 112 "F1" }
+ { 113 "F2" }
+ { 114 "F3" }
+ { 115 "F4" }
+ { 116 "F5" }
+ { 117 "F6" }
+ { 118 "F7" }
+ { 119 "F8" }
+ { 120 "F9" }
+ { 121 "F10" }
+ { 122 "F11" }
+ { 123 "F12" }
- : exclude-keys-wm-keydown
++ }
+
+: key-state-down? ( key -- ? )
+ GetKeyState 16 bit? ;
+
+: left-shift? ( -- ? ) VK_LSHIFT key-state-down? ;
+: left-ctrl? ( -- ? ) VK_LCONTROL key-state-down? ;
+: left-alt? ( -- ? ) VK_LMENU key-state-down? ;
+: right-shift? ( -- ? ) VK_RSHIFT key-state-down? ;
+: right-ctrl? ( -- ? ) VK_RCONTROL key-state-down? ;
+: right-alt? ( -- ? ) VK_RMENU key-state-down? ;
+: shift? ( -- ? ) left-shift? right-shift? or ;
+: ctrl? ( -- ? ) left-ctrl? right-ctrl? or ;
+: alt? ( -- ? ) left-alt? right-alt? or ;
+: caps-lock? ( -- ? ) VK_CAPITAL GetKeyState zero? not ;
+
+: key-modifiers ( -- seq )
+ [
+ shift? [ S+ , ] when
+ ctrl? [ C+ , ] when
+ alt? [ A+ , ] when
+ ] { } make [ empty? not ] keep f ? ;
+
- } ;
++CONSTANT: exclude-keys-wm-keydown
+ H{
+ { 16 "SHIFT" }
+ { 17 "CTRL" }
+ { 18 "ALT" }
+ { 20 "CAPS-LOCK" }
- : exclude-keys-wm-char
- ! Values are ignored
++ }
+
- } ;
++! Values are ignored
++CONSTANT: exclude-keys-wm-char
+ H{
+ { 8 "BACKSPACE" }
+ { 9 "TAB" }
+ { 13 "RET" }
+ { 27 "ESC" }
++ }
+
+: exclude-key-wm-keydown? ( n -- ? )
+ exclude-keys-wm-keydown key? ;
+
+: exclude-key-wm-char? ( n -- ? )
+ exclude-keys-wm-char key? ;
+
+: keystroke>gesture ( n -- mods sym )
+ wm-keydown-codes at* [ key-modifiers swap ] [ drop f f ] if ;
+
+: send-key-gesture ( sym action? quot hWnd -- )
+ [ [ key-modifiers ] 3dip call ] dip
+ window propagate-key-gesture ; inline
+
+: send-key-down ( sym action? hWnd -- )
+ [ [ <key-down> ] ] dip send-key-gesture ;
+
+: send-key-up ( sym action? hWnd -- )
+ [ [ <key-up> ] ] dip send-key-gesture ;
+
+: key-sym ( wParam -- string/f action? )
+ {
+ {
+ [ dup LETTER? ]
+ [ shift? caps-lock? xor [ CHAR: a + CHAR: A - ] unless 1string f ]
+ }
+ { [ dup digit? ] [ 1string f ] }
+ [ wm-keydown-codes at t ]
+ } cond ;
+
+:: handle-wm-keydown ( hWnd uMsg wParam lParam -- )
+ wParam exclude-key-wm-keydown? [
+ wParam key-sym over [
+ dup ctrl? alt? xor or [
+ hWnd send-key-down
+ ] [ 2drop ] if
+ ] [ 2drop ] if
+ ] unless ;
+
+:: handle-wm-char ( hWnd uMsg wParam lParam -- )
+ wParam exclude-key-wm-char? [
+ ctrl? alt? xor [
+ wParam 1string
+ [ f hWnd send-key-down ]
+ [ hWnd window user-input ] bi
+ ] unless
+ ] unless ;
+
+:: handle-wm-keyup ( hWnd uMsg wParam lParam -- )
+ wParam exclude-key-wm-keydown? [
+ wParam key-sym over [
+ hWnd send-key-up
+ ] [ 2drop ] if
+ ] unless ;
+
+:: set-window-active ( hwnd uMsg wParam lParam ? -- n )
+ ? hwnd window (>>active?)
+ hwnd uMsg wParam lParam DefWindowProc ;
+
+: handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
+ {
+ { [ over SC_MINIMIZE = ] [ f set-window-active ] }
+ { [ over SC_RESTORE = ] [ t set-window-active ] }
+ { [ over SC_MAXIMIZE = ] [ t set-window-active ] }
+ { [ dup alpha? ] [ 4drop 0 ] }
+ { [ t ] [ DefWindowProc ] }
+ } cond ;
+
+: cleanup-window ( handle -- )
+ dup title>> [ free ] when*
+ dup hRC>> wglDeleteContext win32-error=0/f
+ dup hWnd>> swap hDC>> ReleaseDC win32-error=0/f ;
+
+M: windows-ui-backend (close-window)
+ dup hWnd>> unregister-window
+ dup cleanup-window
+ hWnd>> DestroyWindow win32-error=0/f ;
+
+: handle-wm-close ( hWnd uMsg wParam lParam -- )
+ 3drop window ungraft ;
+
+: handle-wm-set-focus ( hWnd uMsg wParam lParam -- )
+ 3drop window [ focus-world ] when* ;
+
+: handle-wm-kill-focus ( hWnd uMsg wParam lParam -- )
+ 3drop window [ unfocus-world ] when* ;
+
+: message>button ( uMsg -- button down? )
+ {
+ { WM_LBUTTONDOWN [ 1 t ] }
+ { WM_LBUTTONUP [ 1 f ] }
+ { WM_MBUTTONDOWN [ 2 t ] }
+ { WM_MBUTTONUP [ 2 f ] }
+ { WM_RBUTTONDOWN [ 3 t ] }
+ { WM_RBUTTONUP [ 3 f ] }
+
+ { WM_NCLBUTTONDOWN [ 1 t ] }
+ { WM_NCLBUTTONUP [ 1 f ] }
+ { WM_NCMBUTTONDOWN [ 2 t ] }
+ { WM_NCMBUTTONUP [ 2 f ] }
+ { WM_NCRBUTTONDOWN [ 3 t ] }
+ { WM_NCRBUTTONUP [ 3 f ] }
+ } case ;
+
+! If the user clicks in the window border ("non-client area")
+! Windows sends us an NC[LMR]BUTTONDOWN message; but if the
+! mouse is subsequently released outside the NC area, we receive
+! a [LMR]BUTTONUP message and Factor can get confused. So we
+! ignore BUTTONUP's that are a result of an NC*BUTTONDOWN.
+SYMBOL: nc-buttons
+
+: handle-wm-ncbutton ( hWnd uMsg wParam lParam -- )
+ 2drop nip
+ message>button nc-buttons get
+ swap [ push ] [ delete ] if ;
+
+: >lo-hi ( WORD -- array ) [ lo-word ] [ hi-word ] bi 2array ;
+
+: mouse-wheel ( wParam -- array ) >lo-hi [ sgn neg ] map ;
+
+: mouse-event>gesture ( uMsg -- button )
+ key-modifiers swap message>button
+ [ <button-down> ] [ <button-up> ] if ;
+
+:: prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world )
+ uMsg mouse-event>gesture
+ lParam >lo-hi
+ hWnd window ;
+
+: set-capture ( hwnd -- )
+ mouse-captured get [
+ drop
+ ] [
+ [ SetCapture drop ] keep
+ mouse-captured set
+ ] if ;
+
+: release-capture ( -- )
+ ReleaseCapture win32-error=0/f
+ mouse-captured off ;
+
+: handle-wm-buttondown ( hWnd uMsg wParam lParam -- )
+ [
+ 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
+ pick message>button drop dup nc-buttons get member? [
+ nc-buttons get delete 4drop
+ ] [
+ drop prepare-mouse send-button-up
+ ] if ;
+
+: make-TRACKMOUSEEVENT ( hWnd -- alien )
+ "TRACKMOUSEEVENT" <c-object> [ set-TRACKMOUSEEVENT-hwndTrack ] keep
+ "TRACKMOUSEEVENT" heap-size over set-TRACKMOUSEEVENT-cbSize ;
+
+: handle-wm-mousemove ( hWnd uMsg wParam lParam -- )
+ 2nip
+ over make-TRACKMOUSEEVENT
+ TME_LEAVE over set-TRACKMOUSEEVENT-dwFlags
+ 0 over set-TRACKMOUSEEVENT-dwHoverTime
+ TrackMouseEvent drop
+ >lo-hi swap window move-hand fire-motion ;
+
+:: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
+ wParam mouse-wheel hand-loc get hWnd window send-wheel ;
+
+: handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
+ #! message sent if windows needs application to stop dragging
+ 4drop release-capture ;
+
+: handle-wm-mouseleave ( hWnd uMsg wParam lParam -- )
+ #! message sent if mouse leaves main application
+ 4drop forget-rollover ;
+
+SYMBOL: wm-handlers
+
+H{ } clone wm-handlers set-global
+
+: add-wm-handler ( quot wm -- )
+ dup array?
+ [ [ execute add-wm-handler ] with each ]
+ [ wm-handlers get-global set-at ] if ;
+
+[ handle-wm-close 0 ] WM_CLOSE add-wm-handler
+[ 4dup handle-wm-paint DefWindowProc ] WM_PAINT add-wm-handler
+
+[ handle-wm-size 0 ] WM_SIZE add-wm-handler
+[ handle-wm-move 0 ] WM_MOVE add-wm-handler
+
+[ 4dup handle-wm-keydown DefWindowProc ] { WM_KEYDOWN WM_SYSKEYDOWN } add-wm-handler
+[ 4dup handle-wm-char DefWindowProc ] { WM_CHAR WM_SYSCHAR } add-wm-handler
+[ 4dup handle-wm-keyup DefWindowProc ] { WM_KEYUP WM_SYSKEYUP } add-wm-handler
+
+[ handle-wm-syscommand ] WM_SYSCOMMAND add-wm-handler
+[ handle-wm-set-focus 0 ] WM_SETFOCUS add-wm-handler
+[ handle-wm-kill-focus 0 ] WM_KILLFOCUS add-wm-handler
+
+[ handle-wm-buttondown 0 ] WM_LBUTTONDOWN add-wm-handler
+[ handle-wm-buttondown 0 ] WM_MBUTTONDOWN add-wm-handler
+[ handle-wm-buttondown 0 ] WM_RBUTTONDOWN add-wm-handler
+[ handle-wm-buttonup 0 ] WM_LBUTTONUP add-wm-handler
+[ handle-wm-buttonup 0 ] WM_MBUTTONUP add-wm-handler
+[ handle-wm-buttonup 0 ] WM_RBUTTONUP add-wm-handler
+
+[ 4dup handle-wm-ncbutton DefWindowProc ]
+{ WM_NCLBUTTONDOWN WM_NCMBUTTONDOWN WM_NCRBUTTONDOWN
+WM_NCLBUTTONUP WM_NCMBUTTONUP WM_NCRBUTTONUP }
+add-wm-handler
+
+[ nc-buttons get-global delete-all DefWindowProc ]
+{ WM_EXITSIZEMOVE WM_EXITMENULOOP } add-wm-handler
+
+[ handle-wm-mousemove 0 ] WM_MOUSEMOVE add-wm-handler
+[ handle-wm-mousewheel 0 ] WM_MOUSEWHEEL add-wm-handler
+[ handle-wm-cancelmode 0 ] WM_CANCELMODE add-wm-handler
+[ handle-wm-mouseleave 0 ] WM_MOUSELEAVE add-wm-handler
+
+SYMBOL: trace-messages?
+
+! return 0 if you handle the message, else just let DefWindowProc return its val
+: ui-wndproc ( -- object )
+ "uint" { "void*" "uint" "long" "long" } "stdcall" [
+ pick
+ trace-messages? get-global [ dup windows-message-name name>> print flush ] when
+ wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
+ ] alien-callback ;
+
+: peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
+
+M: windows-ui-backend do-events
+ msg-obj get-global
+ dup peek-message? [ drop ui-wait ] [
+ [ TranslateMessage drop ]
+ [ DispatchMessage drop ] bi
+ ] if ;
+
+: register-wndclassex ( -- class )
+ "WNDCLASSEX" <c-object>
+ f GetModuleHandle
+ class-name-ptr get-global
+ pick GetClassInfoEx zero? [
+ "WNDCLASSEX" heap-size over set-WNDCLASSEX-cbSize
+ { CS_HREDRAW CS_VREDRAW CS_OWNDC } flags over set-WNDCLASSEX-style
+ ui-wndproc over set-WNDCLASSEX-lpfnWndProc
+ 0 over set-WNDCLASSEX-cbClsExtra
+ 0 over set-WNDCLASSEX-cbWndExtra
+ f GetModuleHandle over set-WNDCLASSEX-hInstance
+ f GetModuleHandle "fraptor" utf16n string>alien LoadIcon
+ over set-WNDCLASSEX-hIcon
+ f IDC_ARROW LoadCursor over set-WNDCLASSEX-hCursor
+
+ class-name-ptr get-global over set-WNDCLASSEX-lpszClassName
+ RegisterClassEx dup win32-error=0/f
+ ] when ;
+
+: adjust-RECT ( RECT -- )
+ style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
+
+: make-RECT ( world -- RECT )
+ [ window-loc>> dup ] [ dim>> ] bi v+
+ "RECT" <c-object>
+ over first over set-RECT-right
+ swap second over set-RECT-bottom
+ over first over set-RECT-left
+ swap second over set-RECT-top ;
+
+: default-position-RECT ( RECT -- )
+ dup get-RECT-dimensions [ 2drop ] 2dip
+ CW_USEDEFAULT + pick set-RECT-bottom
+ CW_USEDEFAULT + over set-RECT-right
+ CW_USEDEFAULT over set-RECT-left
+ CW_USEDEFAULT swap set-RECT-top ;
+
+: make-adjusted-RECT ( rect -- RECT )
+ make-RECT
+ dup get-RECT-top-left [ zero? ] both? swap
+ dup adjust-RECT
+ swap [ dup default-position-RECT ] when ;
+
+: create-window ( rect -- hwnd )
+ make-adjusted-RECT
+ [ class-name-ptr get-global f ] dip
+ [
+ [ ex-style ] 2dip
+ { WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags
+ ] dip get-RECT-dimensions
+ f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;
+
+: show-window ( hWnd -- )
+ dup SW_SHOW ShowWindow drop ! always succeeds
+ dup SetForegroundWindow drop
+ SetFocus drop ;
+
+: init-win32-ui ( -- )
+ V{ } clone nc-buttons set-global
+ "MSG" malloc-object msg-obj set-global
+ "Factor-window" utf16n malloc-string class-name-ptr set-global
+ register-wndclassex drop
+ GetDoubleClickTime milliseconds double-click-timeout set-global ;
+
+: cleanup-win32-ui ( -- )
+ class-name-ptr get-global [ dup f UnregisterClass drop free ] when*
+ msg-obj get-global [ free ] when*
+ f class-name-ptr set-global
+ f msg-obj set-global ;
+
+: setup-pixel-format ( hdc flags -- )
+ 32 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep
+ swapd SetPixelFormat win32-error=0/f ;
+
+: get-dc ( hWnd -- hDC ) GetDC dup win32-error=0/f ;
+
+: get-rc ( hDC -- hRC )
+ dup wglCreateContext dup win32-error=0/f
+ [ wglMakeCurrent win32-error=0/f ] keep ;
+
+: setup-gl ( hwnd -- hDC hRC )
+ get-dc dup windowed-pfd-dwFlags setup-pixel-format dup get-rc ;
+
+M: windows-ui-backend (open-window) ( world -- )
+ [ create-window [ setup-gl ] keep ] keep
+ [ f <win> ] keep
+ [ swap hWnd>> register-window ] 2keep
+ dupd (>>handle)
+ hWnd>> show-window ;
+
+M: win-base select-gl-context ( handle -- )
+ [ hDC>> ] keep hRC>> wglMakeCurrent win32-error=0/f
+ GdiFlush drop ;
+
+M: win-base flush-gl-context ( handle -- )
+ hDC>> SwapBuffers win32-error=0/f ;
+
+: (bitmap-info) ( dim -- BITMAPINFO )
+ "BITMAPINFO" <c-object> [
+ BITMAPINFO-bmiHeader {
+ [ nip "BITMAPINFOHEADER" heap-size swap set-BITMAPINFOHEADER-biSize ]
+ [ [ first ] dip set-BITMAPINFOHEADER-biWidth ]
+ [ [ second ] dip set-BITMAPINFOHEADER-biHeight ]
+ [ nip 1 swap set-BITMAPINFOHEADER-biPlanes ]
+ [ nip 32 swap set-BITMAPINFOHEADER-biBitCount ]
+ [ nip BI_RGB swap set-BITMAPINFOHEADER-biCompression ]
+ [ [ first2 * 4 * ] dip set-BITMAPINFOHEADER-biSizeImage ]
+ [ nip 72 swap set-BITMAPINFOHEADER-biXPelsPerMeter ]
+ [ nip 72 swap set-BITMAPINFOHEADER-biYPelsPerMeter ]
+ [ nip 0 swap set-BITMAPINFOHEADER-biClrUsed ]
+ [ nip 0 swap set-BITMAPINFOHEADER-biClrImportant ]
+ } 2cleave
+ ] keep ;
+
+: make-offscreen-dc-and-bitmap ( dim -- hDC hBitmap bits )
+ f CreateCompatibleDC
+ dup rot (bitmap-info) DIB_RGB_COLORS f <void*>
+ [ f 0 CreateDIBSection ] keep *void*
+ [ 2dup SelectObject drop ] dip ;
+
+: setup-offscreen-gl ( dim -- hDC hRC hBitmap bits )
+ make-offscreen-dc-and-bitmap [
+ [ dup offscreen-pfd-dwFlags setup-pixel-format ]
+ [ get-rc ] bi
+ ] 2dip ;
+
+M: windows-ui-backend (open-offscreen-buffer) ( world -- )
+ dup dim>> setup-offscreen-gl <win-offscreen>
+ >>handle drop ;
+
+M: windows-ui-backend (close-offscreen-buffer) ( handle -- )
+ [ hDC>> DeleteDC drop ]
+ [ hBitmap>> DeleteObject drop ] bi ;
+
+! Windows 32-bit bitmaps don't actually use the alpha byte of
+! each pixel; it's left as zero
+
+: (make-opaque) ( byte-array -- byte-array' )
+ [ length 4 / ]
+ [ '[ 255 swap 4 * 3 + _ set-nth ] each ]
+ [ ] tri ;
+
+: (opaque-pixels) ( world -- pixels )
+ [ handle>> bits>> ] [ dim>> first2 * 4 * ] bi
+ memory>byte-array (make-opaque) ;
+
+M: windows-ui-backend offscreen-pixels ( world -- alien w h )
+ [ (opaque-pixels) ] [ dim>> first2 ] bi ;
+
+M: windows-ui-backend raise-window* ( world -- )
+ handle>> [ hWnd>> SetFocus drop ] when* ;
+
+M: windows-ui-backend set-title ( string world -- )
+ handle>>
+ dup title>> [ free ] when*
+ swap utf16n malloc-string
+ [ >>title ]
+ [ [ hWnd>> WM_SETTEXT 0 ] dip alien-address SendMessage drop ] bi ;
+
+M: windows-ui-backend (with-ui)
+ [
+ [
+ init-clipboard
+ init-win32-ui
+ start-ui
+ event-loop
+ ] [ cleanup-win32-ui ] [ ] cleanup
+ ] ui-running ;
+
+M: windows-ui-backend beep ( -- )
+ 0 MessageBeep drop ;
+
+windows-ui-backend ui-backend set-global
+
+[ "ui.tools" ] main-vocab-hook set-global
--- /dev/null
- : modifiers
+! Copyright (C) 2005, 2009 Eduardo Cavazos and Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.c-types arrays ui ui.gadgets
+ui.gestures ui.backend ui.clipboards ui.gadgets.worlds ui.render
+ui.event-loop assocs kernel math namespaces opengl
+sequences strings x11.xlib x11.events x11.xim x11.glx
+x11.clipboard x11.constants x11.windows io.encodings.string
+io.encodings.ascii io.encodings.utf8 combinators command-line
+math.vectors classes.tuple opengl.gl threads math.rectangles
+environment ascii ;
+IN: ui.backend.x11
+
+SINGLETON: x11-ui-backend
+
+: XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ;
+
+TUPLE: x11-handle-base glx ;
+TUPLE: x11-handle < x11-handle-base xic window ;
+TUPLE: x11-pixmap-handle < x11-handle-base pixmap glx-pixmap ;
+
+C: <x11-handle> x11-handle
+C: <x11-pixmap-handle> x11-pixmap-handle
+
+M: world expose-event nip relayout ;
+
+M: world configure-event
+ over configured-loc >>window-loc
+ swap configured-dim >>dim
+ ! In case dimensions didn't change
+ relayout-1 ;
+
- } ;
-
- : key-codes
++CONSTANT: modifiers
+ {
+ { S+ HEX: 1 }
+ { C+ HEX: 4 }
+ { A+ HEX: 8 }
- } ;
++ }
++
++CONSTANT: key-codes
+ H{
+ { HEX: FF08 "BACKSPACE" }
+ { HEX: FF09 "TAB" }
+ { HEX: FF0D "RET" }
+ { HEX: FF8D "ENTER" }
+ { HEX: FF1B "ESC" }
+ { HEX: FFFF "DELETE" }
+ { HEX: FF50 "HOME" }
+ { HEX: FF51 "LEFT" }
+ { HEX: FF52 "UP" }
+ { HEX: FF53 "RIGHT" }
+ { HEX: FF54 "DOWN" }
+ { HEX: FF55 "PAGE_UP" }
+ { HEX: FF56 "PAGE_DOWN" }
+ { HEX: FF57 "END" }
+ { HEX: FF58 "BEGIN" }
+ { HEX: FFBE "F1" }
+ { HEX: FFBF "F2" }
+ { HEX: FFC0 "F3" }
+ { HEX: FFC1 "F4" }
+ { HEX: FFC2 "F5" }
+ { HEX: FFC3 "F6" }
+ { HEX: FFC4 "F7" }
+ { HEX: FFC5 "F8" }
+ { HEX: FFC6 "F9" }
- dup event-modifiers swap 0 XLookupKeysym key-code <key-up> ;
++ }
+
+: key-code ( keysym -- keycode action? )
+ dup key-codes at [ t ] [ 1string f ] ?if ;
+
+: event-modifiers ( event -- seq )
+ XKeyEvent-state modifiers modifier ;
+
+: valid-input? ( string gesture -- ? )
+ over empty? [ 2drop f ] [
+ mods>> { f { S+ } } member? [
+ [ [ 127 = not ] [ CHAR: \s >= ] bi and ] all?
+ ] [
+ [ [ 127 = not ] [ CHAR: \s >= ] [ alpha? not ] tri and and ] all?
+ ] if
+ ] if ;
+
+: key-down-event>gesture ( event world -- string gesture )
+ dupd
+ handle>> xic>> lookup-string
+ [ swap event-modifiers ] dip key-code <key-down> ;
+
+M: world key-down-event
+ [ key-down-event>gesture ] keep
+ [ propagate-key-gesture drop ]
+ [ 2over valid-input? [ nip user-input ] [ 3drop ] if ]
+ 3bi ;
+
+: key-up-event>gesture ( event -- gesture )
++ [ event-modifiers ] [ 0 XLookupKeysym key-code ] bi <key-up> ;
+
+M: world key-up-event
+ [ key-up-event>gesture ] dip propagate-key-gesture ;
+
+: mouse-event>gesture ( event -- modifiers button loc )
+ [ event-modifiers ]
+ [ XButtonEvent-button ]
+ [ mouse-event-loc ]
+ tri ;
+
+M: world button-down-event
+ [ mouse-event>gesture [ <button-down> ] dip ] dip
+ send-button-down ;
+
+M: world button-up-event
+ [ mouse-event>gesture [ <button-up> ] dip ] dip
+ send-button-up ;
+
+: mouse-event>scroll-direction ( event -- pair )
+ XButtonEvent-button {
+ { 4 { 0 -1 } }
+ { 5 { 0 1 } }
+ { 6 { -1 0 } }
+ { 7 { 1 0 } }
+ } at ;
+
+M: world wheel-event
+ [ [ mouse-event>scroll-direction ] [ mouse-event-loc ] bi ] dip
+ send-wheel ;
+
+M: world enter-event motion-event ;
+
+M: world leave-event 2drop forget-rollover ;
+
+M: world motion-event
+ [ [ XMotionEvent-x ] [ XMotionEvent-y ] bi 2array ] dip
+ move-hand fire-motion ;
+
+M: world focus-in-event
+ nip
+ dup handle>> xic>> XSetICFocus focus-world ;
+
+M: world focus-out-event
+ nip
+ dup handle>> xic>> XUnsetICFocus unfocus-world ;
+
+M: world selection-notify-event
+ [ handle>> window>> selection-from-event ] keep
+ user-input ;
+
+: supported-type? ( atom -- ? )
+ { "UTF8_STRING" "STRING" "TEXT" }
+ [ x-atom = ] with any? ;
+
+: clipboard-for-atom ( atom -- clipboard )
+ {
+ { XA_PRIMARY [ selection get ] }
+ { XA_CLIPBOARD [ clipboard get ] }
+ [ drop <clipboard> ]
+ } case ;
+
+: encode-clipboard ( string type -- bytes )
+ XSelectionRequestEvent-target
+ XA_UTF8_STRING = utf8 ascii ? encode ;
+
+: set-selection-prop ( evt -- )
+ dpy get swap
+ [ XSelectionRequestEvent-requestor ] keep
+ [ XSelectionRequestEvent-property ] keep
+ [ XSelectionRequestEvent-target ] keep
+ [ 8 PropModeReplace ] dip
+ [
+ XSelectionRequestEvent-selection
+ clipboard-for-atom contents>>
+ ] keep encode-clipboard dup length XChangeProperty drop ;
+
+M: world selection-request-event
+ drop dup XSelectionRequestEvent-target {
+ { [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
+ { [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
+ { [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
+ [ drop send-notify-failure ]
+ } cond ;
+
+M: x11-ui-backend (close-window) ( handle -- )
+ [ xic>> XDestroyIC ]
+ [ glx>> destroy-glx ]
+ [ window>> [ unregister-window ] [ destroy-window ] bi ]
+ tri ;
+
+M: world client-event
+ swap close-box? [ ungraft ] [ drop ] if ;
+
+: gadget-window ( world -- )
+ [ [ window-loc>> ] [ dim>> ] bi glx-window ]
+ [ "Factor" create-xic ]
+ [ ] tri <x11-handle>
+ [ window>> register-window ] [ >>handle drop ] 2bi ;
+
+: wait-event ( -- event )
+ QueuedAfterFlush events-queued 0 > [
+ next-event dup
+ None XFilterEvent 0 = [ drop wait-event ] unless
+ ] [ ui-wait wait-event ] if ;
+
+M: x11-ui-backend do-events
+ wait-event dup XAnyEvent-window window dup
+ [ handle-event ] [ 2drop ] if ;
+
+: x-clipboard@ ( gadget clipboard -- prop win )
+ atom>> swap
+ find-world handle>> window>> ;
+
+M: x-clipboard copy-clipboard
+ [ x-clipboard@ own-selection ] keep
+ (>>contents) ;
+
+M: x-clipboard paste-clipboard
+ [ find-world handle>> window>> ] dip atom>> convert-selection ;
+
+: init-clipboard ( -- )
+ XA_PRIMARY <x-clipboard> selection set-global
+ XA_CLIPBOARD <x-clipboard> clipboard set-global ;
+
+: set-title-old ( dpy window string -- )
+ dup [ 127 <= ] all? [ XStoreName drop ] [ 3drop ] if ;
+
+: set-title-new ( dpy window string -- )
+ [ 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 ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
+
+M: x11-ui-backend set-fullscreen* ( ? world -- )
+ handle>> window>> "XClientMessageEvent" <c-object>
+ [ set-XClientMessageEvent-window ] keep
+ swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ?
+ over set-XClientMessageEvent-data0
+ ClientMessage over set-XClientMessageEvent-type
+ dpy get over set-XClientMessageEvent-display
+ "_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
+ [ dpy get root get 0 SubstructureNotifyMask ] dip XSendEvent drop ;
+
+M: x11-ui-backend (open-window) ( world -- )
+ dup gadget-window
+ handle>> window>> dup set-closable map-window ;
+
+M: x11-ui-backend raise-window* ( world -- )
+ handle>> [
+ dpy get swap window>> XRaiseWindow drop
+ ] when* ;
+
+M: x11-handle select-gl-context ( handle -- )
+ dpy get swap
+ [ window>> ] [ glx>> ] bi glXMakeCurrent
+ [ "Failed to set current GLX context" throw ] unless ;
+
+M: x11-handle flush-gl-context ( handle -- )
+ dpy get swap window>> glXSwapBuffers ;
+
+M: x11-pixmap-handle select-gl-context ( handle -- )
+ dpy get swap
+ [ glx-pixmap>> ] [ glx>> ] bi glXMakeCurrent
+ [ "Failed to set current GLX context" throw ] unless ;
+
+M: x11-pixmap-handle flush-gl-context ( handle -- )
+ drop ;
+
+M: x11-ui-backend (open-offscreen-buffer) ( world -- )
+ dup dim>> glx-pixmap <x11-pixmap-handle> >>handle drop ;
+M: x11-ui-backend (close-offscreen-buffer) ( handle -- )
+ dpy get swap
+ [ glx-pixmap>> glXDestroyGLXPixmap ]
+ [ pixmap>> XFreePixmap drop ]
+ [ glx>> glXDestroyContext ] 2tri ;
+
+M: x11-ui-backend offscreen-pixels ( world -- alien w h )
+ [ [ dim>> ] [ handle>> pixmap>> ] bi pixmap-bits ] [ dim>> first2 ] bi ;
+
+M: x11-ui-backend (with-ui) ( quot -- )
+ [
+ f [
+ [
+ init-clipboard
+ start-ui
+ event-loop
+ ] with-xim
+ ] with-x
+ ] ui-running ;
+
+M: x11-ui-backend beep ( -- )
+ dpy get 100 XBell drop ;
+
+x11-ui-backend ui-backend set-global
+
+[ "DISPLAY" os-env "ui.tools" "listener" ? ]
+main-vocab-hook set-global
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays generic kernel math namespaces sequences
words splitting grouping math.vectors ui.gadgets.grids
-ui.gadgets math.geometry.rect ;
+ui.gadgets.grids.private ui.gadgets math.order math.rectangles
+fry ;
IN: ui.gadgets.frames
+TUPLE: frame < grid filled-cell ;
+
+<PRIVATE
+
TUPLE: glue < gadget ;
M: glue pref-dim* drop { 0 0 } ;
-: <glue> ( -- glue ) glue new-gadget ;
-
-: <frame-grid> ( -- grid ) 9 [ <glue> ] replicate 3 group ;
+: <glue> ( -- glue ) glue new ;
-: @center ( -- i j ) 1 1 ; inline
-: @left ( -- i j ) 0 1 ; inline
-: @right ( -- i j ) 2 1 ; inline
-: @top ( -- i j ) 1 0 ; inline
-: @bottom ( -- i j ) 1 2 ; inline
+: <frame-grid> ( cols rows -- grid )
+ swap '[ _ [ <glue> ] replicate ] replicate ;
-: @top-left ( -- i j ) 0 0 ; inline
-: @top-right ( -- i j ) 2 0 ; inline
-: @bottom-left ( -- i j ) 0 2 ; inline
-: @bottom-right ( -- i j ) 2 2 ; inline
+: (fill- ( frame grid-layout quot1 quot2 -- pref-dim gap filled-cell dims )
+ [ '[ [ dim>> ] [ gap>> ] [ filled-cell>> ] tri _ tri@ ] dip ] dip call ; inline
- : available-space ( pref-dim gap dims -- avail )
- length 1+ * [-] ; inline
-
-TUPLE: frame < grid ;
+: -center) ( pref-dim gap filled-cell dims -- )
+ [ nip available-space ] 2keep [ remove-nth sum [-] ] 2keep set-nth ; inline
-: new-frame ( class -- frame )
- <frame-grid> swap new-grid ; inline
+: (fill-center) ( frame grid-layout quot1 quot2 -- ) (fill- -center) ; inline
-: <frame> ( -- frame )
- frame new-frame ;
+: fill-center ( frame grid-layout -- )
+ [ [ first ] [ column-widths>> ] (fill-center) ]
+ [ [ second ] [ row-heights>> ] (fill-center) ] 2bi ;
-: (fill-center) ( dim vec -- )
- [ [ first ] [ third ] bi v+ [v-] ] keep set-second ;
+: <frame-layout> ( frame -- grid-layout )
+ dup <grid-layout> [ fill-center ] keep ;
-: fill-center ( dim horiz vert -- )
- [ over ] dip [ (fill-center) ] 2bi@ ;
+PRIVATE>
M: frame layout*
- dup compute-grid
- [ [ dim>> ] 2dip fill-center ] [ grid-layout ] 3bi ;
+ [ grid>> ] [ <frame-layout> ] bi grid-layout ;
+
+: new-frame ( cols rows class -- frame )
+ [ <frame-grid> ] dip new-grid ; inline
+
+: <frame> ( cols rows -- frame )
+ frame new-frame ;
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays hashtables io kernel
-math namespaces opengl opengl.gl opengl.glu sequences strings
-io.styles vectors combinators math.vectors ui.gadgets colors
-math.order math.geometry.rect locals specialized-arrays.float ;
+USING: math.rectangles math.vectors namespaces kernel accessors
+combinators sequences opengl opengl.gl opengl.glu colors
+colors.constants ui.gadgets ui.pens ;
IN: ui.render
SYMBOL: clip
: do-clip ( -- ) clip get flip-rect gl-set-clip ;
-: init-clip ( clip-rect rect -- )
- GL_SCISSOR_TEST glEnable
- [ rect-intersect ] keep
- dim>> dup { 0 1 } v* viewport-translation set
- { 0 0 } over gl-viewport
- 0 swap first2 0 gluOrtho2D
- clip set
+: init-clip ( clip-rect -- )
+ [
+ dim>>
+ [ { 0 1 } v* viewport-translation set ]
+ [ [ { 0 0 } ] dip gl-viewport ]
+ [ [ 0 ] dip first2 0 gluOrtho2D ] tri
+ ]
+ [ clip set ] bi
do-clip ;
-: init-gl ( clip-rect rect -- )
+: init-gl ( clip-rect -- )
GL_SMOOTH glShadeModel
+ GL_SCISSOR_TEST glEnable
GL_BLEND glEnable
GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
GL_VERTEX_ARRAY glEnableClientState
init-clip
! white gl-clear is broken w.r.t window resizing
! Linux/PPC Radeon 9200
- white gl-color
+ COLOR: white gl-color
clip get dim>> gl-fill-rect ;
GENERIC: draw-gadget* ( gadget -- )
M: gadget draw-gadget* drop ;
-GENERIC: draw-interior ( gadget interior -- )
-
-GENERIC: draw-boundary ( gadget boundary -- )
-
SYMBOL: origin
{ 0 0 } origin set-global
: visible-children ( gadget -- seq )
- clip get origin get vneg offset-rect swap children-on ;
+ [ clip get origin get vneg offset-rect ] dip children-on ;
-: translate ( rect/point -- ) rect-loc origin [ v+ ] change ;
+: translate ( rect/point -- ) loc>> origin [ v+ ] change ;
-DEFER: draw-gadget
+GENERIC: draw-children ( gadget -- )
: (draw-gadget) ( gadget -- )
- [
- dup translate
- dup interior>> [
- origin get [ dupd draw-interior ] with-translation
- ] when*
- dup draw-gadget*
- dup visible-children [ draw-gadget ] each
- dup boundary>> [
- origin get [ dupd draw-boundary ] with-translation
- ] when*
- drop
- ] with-scope ;
+ dup loc>> origin get v+ origin [
+ [
+ origin get [
+ [ dup interior>> dup [ draw-interior ] [ 2drop ] if ]
+ [ draw-gadget* ]
+ bi
+ ] with-translation
+ ]
+ [ draw-children ]
+ [
+ dup boundary>> dup [
+ origin get [ draw-boundary ] with-translation
+ ] [ 2drop ] if
+ ] tri
+ ] with-variable ;
: >absolute ( rect -- rect )
origin get offset-rect ;
[ [ (draw-gadget) ] with-clipping ]
} cond ;
-! A pen that caches vertex arrays, etc
-TUPLE: caching-pen last-dim ;
-
-GENERIC: recompute-pen ( gadget pen -- )
-
-: compute-pen ( gadget pen -- )
- 2dup [ dim>> ] [ last-dim>> ] bi* = [
- 2drop
- ] [
- [ swap dim>> >>last-dim drop ] [ recompute-pen ] 2bi
- ] if ;
-
-! Solid fill/border
-TUPLE: solid < caching-pen color interior-vertices boundary-vertices ;
+! For text rendering
+SYMBOL: background
-: <solid> ( color -- solid ) solid new swap >>color ;
+SYMBOL: foreground
-M: solid recompute-pen
- swap dim>>
- [ (fill-rect-vertices) >>interior-vertices ]
- [ (rect-vertices) >>boundary-vertices ]
- bi drop ;
+GENERIC: gadget-background ( gadget -- color )
-<PRIVATE
+M: gadget gadget-background dup interior>> pen-background ;
-! Solid pen
-: (solid) ( gadget pen -- )
- [ compute-pen ] [ color>> gl-color ] bi ;
+GENERIC: gadget-foreground ( gadget -- color )
-PRIVATE>
+M: gadget gadget-foreground dup interior>> pen-foreground ;
-M: solid draw-interior
- [ (solid) ] [ interior-vertices>> gl-vertex-pointer ] bi
- (gl-fill-rect) ;
-
-M: solid draw-boundary
- [ (solid) ] [ boundary-vertices>> gl-vertex-pointer ] bi
- (gl-rect) ;
-
-! Gradient pen
-TUPLE: gradient < caching-pen colors last-vertices last-colors ;
-
-: <gradient> ( colors -- gradient ) gradient new swap >>colors ;
-
-<PRIVATE
-
-:: gradient-vertices ( direction dim colors -- seq )
- direction dim v* dim over v- swap
- colors length dup 1- v/n [ v*n ] with map
- [ dup rot v+ 2array ] with map
- concat concat >float-array ;
-
-: gradient-colors ( colors -- seq )
- [ color>raw 4array dup 2array ] map concat concat
- >float-array ;
-
-M: gradient recompute-pen ( gadget gradient -- )
- tuck
- [ [ orientation>> ] [ dim>> ] bi ] [ colors>> ] bi*
- [ gradient-vertices >>last-vertices ]
- [ gradient-colors >>last-colors ] bi
- drop ;
-
-: draw-gradient ( colors -- )
- GL_COLOR_ARRAY [
- [ GL_QUAD_STRIP 0 ] dip length 2 * glDrawArrays
- ] do-enabled-client-state ;
+M: gadget draw-children
+ [ visible-children ]
+ [ gadget-background ]
+ [ gadget-foreground ] tri [
+ [ foreground set ] when*
+ [ background set ] when*
+ [ draw-gadget ] each
+ ] with-scope ;
-PRIVATE>
+CONSTANT: selection-color T{ rgba f 0.8 0.8 1.0 1.0 }
- CONSTANT: focus-border-color COLOR: dark-gray
-M: gradient draw-interior
- {
- [ compute-pen ]
- [ last-vertices>> gl-vertex-pointer ]
- [ last-colors>> gl-color-pointer ]
- [ colors>> draw-gradient ]
- } cleave ;
-
-! Polygon pen
-TUPLE: polygon color
-interior-vertices
-interior-count
-boundary-vertices
-boundary-count ;
-
-: <polygon> ( color points -- polygon )
- dup close-path [ [ concat >float-array ] [ length ] bi ] bi@
- polygon boa ;
-
-M: polygon draw-boundary
- nip
- [ color>> gl-color ]
- [ boundary-vertices>> gl-vertex-pointer ]
- [ [ GL_LINE_STRIP 0 ] dip boundary-count>> glDrawArrays ]
- tri ;
-
-M: polygon draw-interior
- nip
- [ color>> gl-color ]
- [ interior-vertices>> gl-vertex-pointer ]
- [ [ GL_POLYGON 0 ] dip interior-count>> glDrawArrays ]
- tri ;
-
-CONSTANT: arrow-up { { 3 0 } { 6 6 } { 0 6 } }
-CONSTANT: arrow-right { { 0 0 } { 6 3 } { 0 6 } }
-CONSTANT: arrow-down { { 0 0 } { 6 0 } { 3 6 } }
-CONSTANT: arrow-left { { 0 3 } { 6 0 } { 6 6 } }
-CONSTANT: close-box { { 0 0 } { 6 0 } { 6 6 } { 0 6 } }
-
-: <polygon-gadget> ( color points -- gadget )
- dup max-dim
- [ <polygon> <gadget> ] dip >>dim
- swap >>interior ;
-
-! Font rendering
-SYMBOL: font-renderer
-
-HOOK: open-font font-renderer ( font -- open-font )
-
-HOOK: string-width font-renderer ( open-font string -- w )
-
-HOOK: string-height font-renderer ( open-font string -- h )
-
-HOOK: draw-string font-renderer ( font string loc -- )
-
-HOOK: x>offset font-renderer ( x open-font string -- n )
-
-HOOK: free-fonts font-renderer ( world -- )
-
-: text-height ( open-font text -- n )
- dup string? [
- string-height
- ] [
- [ string-height ] with map sum
- ] if ;
-
-: text-width ( open-font text -- n )
- dup string? [
- string-width
- ] [
- [ 0 ] 2dip [ string-width max ] with each
- ] if ;
-
-: text-dim ( open-font text -- dim )
- [ text-width ] 2keep text-height 2array ;
-
-: draw-text ( font text loc -- )
- over string? [
- draw-string
- ] [
- [
- [
- 2dup { 0 0 } draw-string
- [ open-font ] dip string-height
- 0.0 swap 0.0 glTranslated
- ] with each
- ] with-translation
- ] if ;
++CONSTANT: focus-border-color COLOR: dark-gray
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.parser namespaces make sequences strings
words assocs combinators accessors arrays ;
GENERIC: effect>string ( obj -- str )
M: string effect>string ;
+M: object effect>string drop "object" ;
M: word effect>string name>> ;
M: integer effect>string number>string ;
M: pair effect>string first2 [ effect>string ] bi@ ": " glue ;
GENERIC: stack-effect ( word -- effect/f )
- M: word stack-effect
- "declared-effect" "inferred-effect"
- [ word-prop ] bi-curry@ bi or ;
+ M: word stack-effect "declared-effect" word-prop ;
+
+ M: deferred stack-effect call-next-method (( -- * )) or ;
M: effect clone
[ in>> clone ] [ out>> clone ] bi <effect> ;
: split-shuffle ( stack shuffle -- stack1 stack2 )
in>> length cut* ;
-: load-shuffle ( stack shuffle -- )
- in>> [ set ] 2each ;
-
-: shuffled-values ( shuffle -- values )
- out>> [ get ] map ;
+: shuffle-mapping ( effect -- mapping )
+ [ out>> ] [ in>> ] bi [ index ] curry map ;
: shuffle ( stack shuffle -- newstack )
- [ [ load-shuffle ] keep shuffled-values ] with-scope ;
+ shuffle-mapping swap nths ;
: compiled-xref ( word dependencies generic-dependencies -- )
[ [ drop crossref? ] { } assoc-filter-as f like ] bi@
- [ over ] dip
[ "compiled-uses" compiled-crossref (compiled-xref) ]
[ "compiled-generic-uses" compiled-generic-crossref (compiled-xref) ]
- 2bi* ;
+ bi-curry* bi ;
: (compiled-unxref) ( word word-prop variable -- )
[ [ [ dupd word-prop ] dip get remove-vertex* ] 2curry ]
: gensym ( -- word )
"( gensym )" f <word> ;
- : define-temp ( quot -- word )
- [ gensym dup ] dip define ;
+ : define-temp ( quot effect -- word )
+ [ gensym dup ] 2dip define-declared ;
: reveal ( word -- )
dup [ name>> ] [ vocabulary>> ] bi dup vocab-words
combinators math.parser assocs threads ;
IN: joystick-demo
- : SIZE { 151 151 } ;
- : INDICATOR-SIZE { 4 4 } ;
+ CONSTANT: SIZE { 151 151 }
+ CONSTANT: INDICATOR-SIZE { 4 4 }
: FREQUENCY ( -- f ) 30 recip seconds ;
TUPLE: axis-gadget < gadget indicator z-indicator pov ;
: indicator-polygon ( -- polygon )
{ 0 0 } INDICATOR-SIZE (rect-polygon) ;
- : pov-polygons
+ CONSTANT: pov-polygons
V{
{ pov-neutral { { 70 75 } { 75 70 } { 80 75 } { 75 80 } } }
{ pov-up { { 70 65 } { 75 60 } { 80 65 } } }
{ pov-down-left { { 67 90 } { 60 90 } { 60 83 } } }
{ pov-left { { 65 70 } { 60 75 } { 65 80 } } }
{ pov-up-left { { 67 60 } { 60 60 } { 60 67 } } }
- } ;
+ }
: <indicator-gadget> ( color -- indicator )
indicator-polygon <polygon-gadget> ;
pov-polygons [ add-pov-gadget ] assoc-map >>pov ;
: <axis-gadget> ( -- gadget )
- axis-gadget new-gadget
+ axis-gadget new
add-pov-gadgets
black <indicator-gadget> [ >>z-indicator ] [ add-gadget ] bi
red <indicator-gadget> [ >>indicator ] [ add-gadget ] bi
TUPLE: joystick-demo-gadget < pack axis raxis controller buttons alarm ;
: add-gadget-with-border ( parent child -- parent )
- 2 <border> gray <solid> >>boundary add-gadget ;
+ { 2 2 } <border> gray <solid> >>boundary add-gadget ;
: add-controller-label ( gadget controller -- gadget )
[ >>controller ] [ product-string <label> add-gadget ] bi ;
[ (add-button-gadgets) ] 2keep ;
: <joystick-demo-gadget> ( controller -- gadget )
- joystick-demo-gadget new-gadget
+ joystick-demo-gadget new
{ 0 1 } >>orientation
swap add-controller-label
<shelf> add-axis-gadget add-raxis-gadget add-gadget
ui.gadgets.borders ui.gestures ;
IN: key-caps
- : key-locations H{
+ CONSTANT: key-locations H{
{ key-escape { { 0 0 } { 10 10 } } }
{ key-f1 { { 20 0 } { 10 10 } } }
{ key-keypad-0 { { 190 55 } { 20 10 } } }
{ key-keypad-. { { 210 55 } { 10 10 } } }
- } ;
+ }
- : KEYBOARD-SIZE { 230 65 } ;
+ CONSTANT: KEYBOARD-SIZE { 230 65 }
: FREQUENCY ( -- f ) 30 recip seconds ;
TUPLE: key-caps-gadget < gadget keys alarm ;
[ >>keys ] tri ;
: <key-caps-gadget> ( -- gadget )
- key-caps-gadget new-gadget
+ key-caps-gadget new
add-keys-gadgets ;
M: key-caps-gadget pref-dim* drop KEYBOARD-SIZE ;
: key-caps ( -- )
[
open-game-input
- <key-caps-gadget> 5 <border> "Key Caps" open-window
+ <key-caps-gadget> { 5 5 } <border> "Key Caps" open-window
] with-ui ;
MAIN: key-caps
! From http://www.ffconsultancy.com/ocaml/maze/index.html
USING: sequences namespaces math math.vectors opengl opengl.gl
arrays kernel random ui ui.gadgets ui.gadgets.canvas ui.render
-math.order math.geometry.rect ;
+math.order math.rectangles ;
IN: maze
- : line-width 8 ;
+ CONSTANT: line-width 8
SYMBOL: visited
: <maze> ( -- gadget ) maze new-canvas ;
-: n ( gadget -- n ) rect-dim first2 min line-width /i ;
+: n ( gadget -- n ) dim>> first2 min line-width /i ;
M: maze layout* delete-canvas-dlist ;
TUPLE: nehe2-gadget < gadget ;
- : width 256 ;
- : height 256 ;
+ CONSTANT: width 256
+ CONSTANT: height 256
: <nehe2-gadget> ( -- gadget )
- nehe2-gadget new-gadget ;
+ nehe2-gadget new ;
M: nehe2-gadget pref-dim* ( gadget -- dim )
drop width height 2array ;
TUPLE: nehe3-gadget < gadget ;
- : width 256 ;
- : height 256 ;
+ CONSTANT: width 256
+ CONSTANT: height 256
: <nehe3-gadget> ( -- gadget )
- nehe3-gadget new-gadget ;
+ nehe3-gadget new ;
M: nehe3-gadget pref-dim* ( gadget -- dim )
drop width height 2array ;
TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ;
- : width 256 ;
- : height 256 ;
+ CONSTANT: width 256
+ CONSTANT: height 256
: redraw-interval ( -- dt ) 10 milliseconds ;
: <nehe4-gadget> ( -- gadget )
- nehe4-gadget new-gadget
+ nehe4-gadget new
0.0 >>rtri
0.0 >>rquad ;
IN: nehe.5\r
\r
TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ;\r
- : width 256 ;\r
- : height 256 ;\r
+ CONSTANT: width 256\r
+ CONSTANT: height 256\r
: redraw-interval ( -- dt ) 10 milliseconds ;\r
\r
: <nehe5-gadget> ( -- gadget )\r
- nehe5-gadget new-gadget\r
+ nehe5-gadget new\r
0.0 >>rtri\r
0.0 >>rquad ;\r
\r
parser accessors colors ;
IN: slides
- : stylesheet
+ CONSTANT: stylesheet
H{
{ default-span-style
H{
H{ { table-gap { 10 20 } } }
}
{ bullet "\u0000b7" }
- } ;
+ }
: $title ( string -- )
[ H{ { font "sans-serif" } { font-size 48 } } format ] ($block) ;
TUPLE: slides < book ;
: <slides> ( slides -- gadget )
- [ <page> ] map 0 <model> slides new-book ;
+ 0 <model> slides new-book [ <page> add-gadget ] reduce ;
: change-page ( book n -- )
over control-value + over children>> length rem
projects / factor.git / commitdiff