From: Slava Pestov Date: Tue, 24 Feb 2009 07:21:10 +0000 (-0600) Subject: Fixing conflicts from stack checker changes X-Git-Tag: 0.94~2191^2~140 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=ce1bc1d6ed5ab65557e108526161fe533bbbb730 Fixing conflicts from stack checker changes --- ce1bc1d6ed5ab65557e108526161fe533bbbb730 diff --cc basis/cocoa/subclassing/subclassing.factor index dfd6ff47b2,0896312670..394f45bef3 --- a/basis/cocoa/subclassing/subclassing.factor +++ b/basis/cocoa/subclassing/subclassing.factor @@@ -32,16 -32,15 +32,16 @@@ IN: cocoa.subclassin [ 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 ) [ diff --cc basis/cocoa/views/views.factor index 906832775b,4bb6468fa6..4674e6bdf1 --- a/basis/cocoa/views/views.factor +++ b/basis/cocoa/views/views.factor @@@ -40,11 -40,8 +40,7 @@@ CONSTANT: NSOpenGLPFAScreenMask 8 CONSTANT: NSOpenGLPFAPixelBuffer 90 CONSTANT: NSOpenGLPFAAllowOfflineRenderers 96 CONSTANT: NSOpenGLPFAVirtualScreenCount 128 -- --CONSTANT: kCGLRendererGenericFloatID HEX: 00020400 - - +CONSTANT: NSOpenGLCPSwapInterval 222 ( color -- CGColor ) + >rgba-components CGColorCreateGenericRGB ; + +M: color (>cf) ; + +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: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ; - +FUNCTION: void* CGBitmapContextGetData ( CGContextRef c ) ; + ++CONSTANT: kCGLRendererGenericFloatID HEX: 00020400 ++ ++FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ; ++ + ( 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 dim -- image ) + + swap >>dim + swap >>bitmap + little-endian? ARGB BGRA ? >>component-order ; + +PRIVATE> + +: dummy-context ( -- context ) + \ dummy-context [ + [ 4 malloc { 1 1 } ] with-destructors + ] initialize-alien ; + +: make-bitmap-image ( dim quot -- image ) + [ + [ [ [ malloc-bitmap-data ] keep &CGContextRelease ] keep ] dip + [ nip call ] [ drop [ bitmap-data ] keep ] 3bi + ] with-destructors ; inline diff --cc basis/ui/backend/windows/windows.factor index 5cbdd63896,0000000000..a8c8e823c8 mode 100755,000000..100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@@ -1,588 -1,0 +1,588 @@@ +! 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 + +M: pasteboard clipboard-contents drop paste ; +M: pasteboard set-clipboard-contents drop copy ; + +: init-clipboard ( -- ) + clipboard set-global + selection set-global ; + +TUPLE: win-base hDC hRC ; +TUPLE: win < win-base hWnd world title ; +TUPLE: win-offscreen < win-base hBitmap bits ; +C: win +C: 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) ; + - : wm-keydown-codes ( -- key ) ++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" } - } ; ++ } + +: 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 ? ; + - : exclude-keys-wm-keydown ++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 -- ) + [ [ ] ] dip send-key-gesture ; + +: send-key-up ( sym action? hWnd -- ) + [ [ ] ] 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 + [ ] [ ] 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" [ 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" + 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" + 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 ] 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" [ + 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 + [ 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 + >>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 diff --cc basis/ui/backend/x11/x11.factor index 20a8f20647,0000000000..0567c21f74 mode 100755,000000..100755 --- a/basis/ui/backend/x11/x11.factor +++ b/basis/ui/backend/x11/x11.factor @@@ -1,295 -1,0 +1,295 @@@ +! 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 +C: 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 ; + - : modifiers ++CONSTANT: modifiers + { + { S+ HEX: 1 } + { C+ HEX: 4 } + { A+ HEX: 8 } - } ; - - : key-codes ++ } ++ ++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" } - } ; ++ } + +: 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 ; + +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 ) - dup event-modifiers swap 0 XLookupKeysym key-code ; ++ [ event-modifiers ] [ 0 XLookupKeysym key-code ] bi ; + +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 [ ] dip ] dip + send-button-down ; + +M: world button-up-event + [ mouse-event>gesture [ ] 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 ] + } 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 + [ 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 selection set-global + XA_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" + [ 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 >>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 diff --cc basis/ui/gadgets/frames/frames.factor index 34f4686518,a4d6b46129..a7da9c4f75 --- a/basis/ui/gadgets/frames/frames.factor +++ b/basis/ui/gadgets/frames/frames.factor @@@ -14,36 -9,35 +14,33 @@@ TUPLE: glue < gadget M: glue pref-dim* drop { 0 0 } ; -: ( -- glue ) glue new-gadget ; - -: ( -- grid ) 9 [ ] replicate 3 group ; +: ( -- 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 +: ( cols rows -- grid ) + swap '[ _ [ ] 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 ) - swap new-grid ; inline +: (fill-center) ( frame grid-layout quot1 quot2 -- ) (fill- -center) ; inline -: ( -- 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 -- grid-layout ) + dup [ 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>> ] [ ] bi grid-layout ; + +: new-frame ( cols rows class -- frame ) + [ ] dip new-grid ; inline + +: ( cols rows -- frame ) + frame new-frame ; diff --cc basis/ui/render/render.factor index bd79563137,a913c78f7d..d083b70908 --- a/basis/ui/render/render.factor +++ b/basis/ui/render/render.factor @@@ -88,28 -88,161 +88,28 @@@ GENERIC: draw-children ( gadget -- [ [ (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 -: ( 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 ) -> 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 ; - -: ( colors -- gradient ) gradient new swap >>colors ; - -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 ; - -: ( 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 } } - -: ( color points -- gadget ) - dup max-dim - [ ] 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 diff --cc extra/maze/maze.factor index b4953a9b67,a490a8bbfc..14bbc5822e --- a/extra/maze/maze.factor +++ b/extra/maze/maze.factor @@@ -1,10 -1,10 +1,10 @@@ ! 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 diff --cc extra/nehe/2/2.factor index 3ee153bbd6,fdb53ef254..1a77b501f0 --- a/extra/nehe/2/2.factor +++ b/extra/nehe/2/2.factor @@@ -4,11 -4,11 +4,11 @@@ IN: nehe. TUPLE: nehe2-gadget < gadget ; - : width 256 ; - : height 256 ; + CONSTANT: width 256 + CONSTANT: height 256 : ( -- gadget ) - nehe2-gadget new-gadget ; + nehe2-gadget new ; M: nehe2-gadget pref-dim* ( gadget -- dim ) drop width height 2array ; diff --cc extra/nehe/3/3.factor index af9b37f73e,557655a029..228107618b --- a/extra/nehe/3/3.factor +++ b/extra/nehe/3/3.factor @@@ -4,11 -4,11 +4,11 @@@ IN: nehe. TUPLE: nehe3-gadget < gadget ; - : width 256 ; - : height 256 ; + CONSTANT: width 256 + CONSTANT: height 256 : ( -- gadget ) - nehe3-gadget new-gadget ; + nehe3-gadget new ; M: nehe3-gadget pref-dim* ( gadget -- dim ) drop width height 2array ;