[ 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 )
[
CONSTANT: NSOpenGLPFAPixelBuffer 90
CONSTANT: NSOpenGLPFAAllowOfflineRenderers 96
CONSTANT: NSOpenGLPFAVirtualScreenCount 128
--
--CONSTANT: kCGLRendererGenericFloatID HEX: 00020400
-
-
+CONSTANT: NSOpenGLCPSwapInterval 222
<PRIVATE
--- /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
--- /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
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 ;
[ [ (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
! 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
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 ;
projects / factor.git / commitdiff