{ [ os windows? ] [ "windows" ] }
{ [ os unix? ] [ "x11" ] }
} cond
- ] unless* "ui." prepend require
+ ] unless* "ui.backend." prepend require
+
+ "ui-text-backend" get [
+ {
+ { [ os macosx? ] [ "core-text" ] }
+ { [ os windows? ] [ "freetype" ] }
+ { [ os unix? ] [ "freetype" ] }
+ } cond
+ ] unless* "ui.text." prepend require
] when
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2006, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors math arrays assocs cocoa cocoa.application
+command-line kernel memory namespaces cocoa.messages
+cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
+cocoa.windows cocoa.classes cocoa.nibs sequences system ui
+ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
+ui.backend.cocoa.views core-foundation core-foundation.run-loop
+core-graphics.types threads math.geometry.rect fry libc
+generalizations alien.c-types cocoa.views
+combinators io.thread ;
+IN: ui.backend.cocoa
+
+TUPLE: handle ;
+TUPLE: window-handle < handle view window ;
+TUPLE: offscreen-handle < handle context buffer ;
+
+C: <window-handle> window-handle
+C: <offscreen-handle> offscreen-handle
+
+SINGLETON: cocoa-ui-backend
+
+TUPLE: pasteboard handle ;
+
+C: <pasteboard> pasteboard
+
+M: pasteboard clipboard-contents
+ handle>> pasteboard-string ;
+
+M: pasteboard set-clipboard-contents
+ handle>> set-pasteboard-string ;
+
+: init-clipboard ( -- )
+ NSPasteboard -> generalPasteboard <pasteboard>
+ clipboard set-global
+ <clipboard> selection set-global ;
+
+: world>NSRect ( world -- NSRect )
+ [ window-loc>> ] [ dim>> ] bi [ first2 ] bi@ <CGRect> ;
+
+: gadget-window ( world -- )
+ dup <FactorView>
+ 2dup swap world>NSRect <ViewWindow>
+ [ [ -> release ] [ install-window-delegate ] bi* ]
+ [ <window-handle> ] 2bi
+ >>handle drop ;
+
+M: cocoa-ui-backend set-title ( string world -- )
+ handle>> window>> swap <NSString> -> setTitle: ;
+
+: enter-fullscreen ( world -- )
+ handle>> view>>
+ NSScreen -> mainScreen
+ f -> enterFullScreenMode:withOptions:
+ drop ;
+
+: exit-fullscreen ( world -- )
+ handle>> view>> f -> exitFullScreenModeWithOptions: ;
+
+M: cocoa-ui-backend set-fullscreen* ( ? world -- )
+ swap [ enter-fullscreen ] [ exit-fullscreen ] if ;
+
+M: cocoa-ui-backend fullscreen* ( world -- ? )
+ handle>> view>> -> isInFullScreenMode zero? not ;
+
+: auto-position ( world -- )
+ dup window-loc>> { 0 0 } = [
+ handle>> window>> -> center
+ ] [
+ drop
+ ] if ;
+
+M: cocoa-ui-backend (open-window) ( world -- )
+ dup gadget-window
+ dup auto-position
+ handle>> window>> f -> makeKeyAndOrderFront: ;
+
+M: cocoa-ui-backend (close-window) ( handle -- )
+ window>> -> release ;
+
+M: cocoa-ui-backend close-window ( gadget -- )
+ find-world [
+ handle>> [
+ window>> f -> performClose:
+ ] when*
+ ] when* ;
+
+M: cocoa-ui-backend raise-window* ( world -- )
+ handle>> [
+ window>> dup f -> orderFront: -> makeKeyWindow
+ NSApp 1 -> activateIgnoringOtherApps:
+ ] when* ;
+
+: pixel-size ( pixel-format -- size )
+ 0 <int> [ NSOpenGLPFAColorSize 0 -> getValues:forAttribute:forVirtualScreen: ]
+ keep *int -3 shift ;
+
+: offscreen-buffer ( world pixel-format -- alien w h pitch )
+ [ dim>> first2 ] [ pixel-size ] bi*
+ { [ * * malloc ] [ 2drop ] [ drop nip ] [ nip * ] } 3cleave ;
+
+: gadget-offscreen-context ( world -- context buffer )
+ NSOpenGLPFAOffScreen 1array <PixelFormat>
+ [ nip NSOpenGLContext -> alloc swap f -> initWithFormat:shareContext: dup ]
+ [ offscreen-buffer ] 2bi
+ 4 npick [ -> setOffScreen:width:height:rowbytes: ] dip ;
+
+M: cocoa-ui-backend (open-offscreen-buffer) ( world -- )
+ dup gadget-offscreen-context <offscreen-handle> >>handle drop ;
+
+M: cocoa-ui-backend (close-offscreen-buffer) ( handle -- )
+ [ context>> -> release ]
+ [ buffer>> free ] bi ;
+
+GENERIC: (gl-context) ( handle -- context )
+M: window-handle (gl-context) view>> -> openGLContext ;
+M: offscreen-handle (gl-context) context>> ;
+
+M: handle select-gl-context ( handle -- )
+ (gl-context) -> makeCurrentContext ;
+
+M: handle flush-gl-context ( handle -- )
+ (gl-context) -> flushBuffer ;
+
+M: cocoa-ui-backend offscreen-pixels ( world -- alien w h )
+ [ handle>> buffer>> ] [ dim>> first2 neg ] bi ;
+
+M: cocoa-ui-backend beep ( -- )
+ NSBeep ;
+
+CLASS: {
+ { +superclass+ "NSObject" }
+ { +name+ "FactorApplicationDelegate" }
+}
+
+{ "applicationDidUpdate:" "void" { "id" "SEL" "id" }
+ [ 3drop reset-run-loop ]
+} ;
+
+: install-app-delegate ( -- )
+ NSApp FactorApplicationDelegate install-delegate ;
+
+SYMBOL: cocoa-init-hook
+
+cocoa-init-hook global [
+ [ "MiniFactor.nib" load-nib install-app-delegate ] or
+] change-at
+
+M: cocoa-ui-backend (with-ui)
+ "UI" assert.app [
+ [
+ init-clipboard
+ cocoa-init-hook get call
+ start-ui
+ f io-thread-running? set-global
+ init-thread-timer
+ reset-run-loop
+ NSApp -> run
+ ] ui-running
+ ] with-cocoa ;
+
+cocoa-ui-backend ui-backend set-global
+
+[ running.app? "ui.tools" "listener" ? ] main-vocab-hook set-global
--- /dev/null
+Cocoa UI backend
--- /dev/null
+unportable
--- /dev/null
+Slava Pestov
--- /dev/null
+Cocoa integration for UI developer tools
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2006, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax cocoa cocoa.nibs cocoa.application
+cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.subclassing
+core-foundation core-foundation.strings help.topics kernel
+memory namespaces parser system ui ui.tools.browser
+ui.tools.listener ui.backend.cocoa eval locals tools.vocabs ;
+IN: ui.backend.cocoa.tools
+
+: finder-run-files ( alien -- )
+ CF>string-array listener-run-files
+ NSApp NSApplicationDelegateReplySuccess
+ -> replyToOpenOrPrint: ;
+
+: menu-run-files ( -- )
+ open-panel [ listener-run-files ] when* ;
+
+: menu-save-image ( -- )
+ image save-panel [ save-image ] when* ;
+
+! Handle Open events from the Finder
+CLASS: {
+ { +superclass+ "FactorApplicationDelegate" }
+ { +name+ "FactorWorkspaceApplicationDelegate" }
+}
+
+{ "application:openFiles:" "void" { "id" "SEL" "id" "id" }
+ [ [ 3drop ] dip finder-run-files ]
+}
+
+{ "factorListener:" "id" { "id" "SEL" "id" }
+ [ 3drop show-listener f ]
+}
+
+{ "factorBrowser:" "id" { "id" "SEL" "id" }
+ [ 3drop show-browser f ]
+}
+
+{ "newFactorListener:" "id" { "id" "SEL" "id" }
+ [ 3drop listener-window f ]
+}
+
+{ "newFactorBrowser:" "id" { "id" "SEL" "id" }
+ [ 3drop browser-window f ]
+}
+
+{ "runFactorFile:" "id" { "id" "SEL" "id" }
+ [ 3drop menu-run-files f ]
+}
+
+{ "saveFactorImage:" "id" { "id" "SEL" "id" }
+ [ 3drop save f ]
+}
+
+{ "saveFactorImageAs:" "id" { "id" "SEL" "id" }
+ [ 3drop menu-save-image f ]
+}
+
+{ "refreshAll:" "id" { "id" "SEL" "id" }
+ [ 3drop [ refresh-all ] call-listener f ]
+} ;
+
+: install-app-delegate ( -- )
+ NSApp FactorWorkspaceApplicationDelegate install-delegate ;
+
+! Service support; evaluate Factor code from other apps
+:: do-service ( pboard error quot -- )
+ pboard error ?pasteboard-string
+ dup [ quot call ] when
+ [ pboard set-pasteboard-string ] when* ;
+
+CLASS: {
+ { +superclass+ "NSObject" }
+ { +name+ "FactorServiceProvider" }
+} {
+ "evalInListener:userData:error:"
+ "void"
+ { "id" "SEL" "id" "id" "id" }
+ [ nip [ eval-listener f ] do-service 2drop ]
+} {
+ "evalToString:userData:error:"
+ "void"
+ { "id" "SEL" "id" "id" "id" }
+ [ nip [ eval>string ] do-service 2drop ]
+} ;
+
+: register-services ( -- )
+ NSApp
+ FactorServiceProvider -> alloc -> init
+ -> setServicesProvider: ;
+
+FUNCTION: void NSUpdateDynamicServices ;
+
+[
+ install-app-delegate
+ "Factor.nib" load-nib
+ register-services
+] cocoa-init-hook set-global
--- /dev/null
+Slava Pestov
--- /dev/null
+Cocoa NSView implementation displaying Factor gadgets
--- /dev/null
+unportable
--- /dev/null
+IN: ui.backend.cocoa.views.tests
+USING: ui.backend.cocoa.views tools.test kernel math.geometry.rect
+namespaces ;
+
+[ t ] [
+ T{ rect
+ { loc { 0 0 } }
+ { dim { 1000 1000 } }
+ } "world" set
+
+ T{ rect
+ { loc { 1.5 2.25 } }
+ { dim { 13.0 14.0 } }
+ } dup "world" get rect>NSRect "world" get NSRect>rect =
+] unit-test
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.c-types arrays assocs cocoa kernel
+math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views
+cocoa.application cocoa.pasteboard cocoa.types cocoa.windows
+sequences ui ui.gadgets ui.gadgets.worlds ui.gestures
+core-foundation.strings core-graphics core-graphics.types
+threads combinators math.geometry.rect ;
+IN: ui.backend.cocoa.views
+
+: send-mouse-moved ( view event -- )
+ [ mouse-location ] [ drop window ] 2bi move-hand fire-motion ;
+
+: button ( event -- n )
+ #! Cocoa -> Factor UI button mapping
+ -> buttonNumber H{ { 0 1 } { 2 2 } { 1 3 } } at ;
+
+CONSTANT: modifiers
+ {
+ { S+ HEX: 20000 }
+ { C+ HEX: 40000 }
+ { A+ HEX: 100000 }
+ { M+ HEX: 80000 }
+ }
+
+CONSTANT: key-codes
+ H{
+ { 71 "CLEAR" }
+ { 36 "RET" }
+ { 76 "ENTER" }
+ { 53 "ESC" }
+ { 48 "TAB" }
+ { 51 "BACKSPACE" }
+ { 115 "HOME" }
+ { 117 "DELETE" }
+ { 119 "END" }
+ { 122 "F1" }
+ { 120 "F2" }
+ { 99 "F3" }
+ { 118 "F4" }
+ { 96 "F5" }
+ { 97 "F6" }
+ { 98 "F7" }
+ { 100 "F8" }
+ { 123 "LEFT" }
+ { 124 "RIGHT" }
+ { 125 "DOWN" }
+ { 126 "UP" }
+ { 116 "PAGE_UP" }
+ { 121 "PAGE_DOWN" }
+ }
+
+: key-code ( event -- string ? )
+ dup -> keyCode key-codes at
+ [ t ] [ -> charactersIgnoringModifiers CF>string f ] ?if ;
+
+: event-modifiers ( event -- modifiers )
+ -> modifierFlags modifiers modifier ;
+
+: key-event>gesture ( event -- modifiers keycode action? )
+ [ event-modifiers ] [ key-code ] bi ;
+
+: send-key-event ( view gesture -- )
+ swap window propagate-key-gesture ;
+
+: interpret-key-event ( view event -- )
+ NSArray swap -> arrayWithObject: -> interpretKeyEvents: ;
+
+: send-key-down-event ( view event -- )
+ [ key-event>gesture <key-down> send-key-event ]
+ [ interpret-key-event ]
+ 2bi ;
+
+: send-key-up-event ( view event -- )
+ key-event>gesture <key-up> send-key-event ;
+
+: mouse-event>gesture ( event -- modifiers button )
+ [ event-modifiers ] [ button ] bi ;
+
+: send-button-down$ ( view event -- )
+ [ nip mouse-event>gesture <button-down> ]
+ [ mouse-location ]
+ [ drop window ]
+ 2tri send-button-down ;
+
+: send-button-up$ ( view event -- )
+ [ nip mouse-event>gesture <button-up> ]
+ [ mouse-location ]
+ [ drop window ]
+ 2tri send-button-up ;
+
+: send-wheel$ ( view event -- )
+ [ nip [ -> deltaX ] [ -> deltaY ] bi [ sgn neg ] bi@ 2array ]
+ [ mouse-location ]
+ [ drop window ]
+ 2tri send-wheel ;
+
+: send-action$ ( view event gesture -- junk )
+ [ drop window ] dip send-action f ;
+
+: add-resize-observer ( observer object -- )
+ [
+ "updateFactorGadgetSize:"
+ "NSViewFrameDidChangeNotification" <NSString>
+ ] dip add-observer ;
+
+: string-or-nil? ( NSString -- ? )
+ [ CF>string NSStringPboardType = ] [ t ] if* ;
+
+: valid-service? ( gadget send-type return-type -- ? )
+ 2dup [ string-or-nil? ] [ string-or-nil? ] bi* and
+ [ drop [ gadget-selection? ] [ drop t ] if ] [ 3drop f ] if ;
+
+: NSRect>rect ( NSRect world -- rect )
+ [ [ [ CGRect-x ] [ CGRect-y ] bi ] [ dim>> second ] bi* swap - 2array ]
+ [ drop [ CGRect-w ] [ CGRect-h ] bi 2array ]
+ 2bi <rect> ;
+
+: rect>NSRect ( rect world -- NSRect )
+ [ [ rect-loc first2 ] [ dim>> second ] bi* swap - ]
+ [ drop rect-dim first2 ]
+ 2bi <CGRect> ;
+
+CLASS: {
+ { +superclass+ "NSOpenGLView" }
+ { +name+ "FactorView" }
+ { +protocols+ { "NSTextInput" } }
+}
+
+! Rendering
+{ "drawRect:" "void" { "id" "SEL" "NSRect" }
+ [ 2drop window relayout-1 ]
+}
+
+! Events
+{ "acceptsFirstMouse:" "char" { "id" "SEL" "id" }
+ [ 3drop 1 ]
+}
+
+{ "mouseEntered:" "void" { "id" "SEL" "id" }
+ [ nip send-mouse-moved ]
+}
+
+{ "mouseExited:" "void" { "id" "SEL" "id" }
+ [ 3drop forget-rollover ]
+}
+
+{ "mouseMoved:" "void" { "id" "SEL" "id" }
+ [ nip send-mouse-moved ]
+}
+
+{ "mouseDragged:" "void" { "id" "SEL" "id" }
+ [ nip send-mouse-moved ]
+}
+
+{ "rightMouseDragged:" "void" { "id" "SEL" "id" }
+ [ nip send-mouse-moved ]
+}
+
+{ "otherMouseDragged:" "void" { "id" "SEL" "id" }
+ [ nip send-mouse-moved ]
+}
+
+{ "mouseDown:" "void" { "id" "SEL" "id" }
+ [ nip send-button-down$ ]
+}
+
+{ "mouseUp:" "void" { "id" "SEL" "id" }
+ [ nip send-button-up$ ]
+}
+
+{ "rightMouseDown:" "void" { "id" "SEL" "id" }
+ [ nip send-button-down$ ]
+}
+
+{ "rightMouseUp:" "void" { "id" "SEL" "id" }
+ [ nip send-button-up$ ]
+}
+
+{ "otherMouseDown:" "void" { "id" "SEL" "id" }
+ [ nip send-button-down$ ]
+}
+
+{ "otherMouseUp:" "void" { "id" "SEL" "id" }
+ [ nip send-button-up$ ]
+}
+
+{ "scrollWheel:" "void" { "id" "SEL" "id" }
+ [ nip send-wheel$ ]
+}
+
+{ "keyDown:" "void" { "id" "SEL" "id" }
+ [ nip send-key-down-event ]
+}
+
+{ "keyUp:" "void" { "id" "SEL" "id" }
+ [ nip send-key-up-event ]
+}
+
+{ "cut:" "id" { "id" "SEL" "id" }
+ [ nip T{ cut-action } send-action$ ]
+}
+
+{ "copy:" "id" { "id" "SEL" "id" }
+ [ nip T{ copy-action } send-action$ ]
+}
+
+{ "paste:" "id" { "id" "SEL" "id" }
+ [ nip T{ paste-action } send-action$ ]
+}
+
+{ "delete:" "id" { "id" "SEL" "id" }
+ [ nip T{ delete-action } send-action$ ]
+}
+
+{ "selectAll:" "id" { "id" "SEL" "id" }
+ [ nip T{ select-all-action } send-action$ ]
+}
+
+! Multi-touch gestures: this is undocumented.
+! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html
+{ "magnifyWithEvent:" "void" { "id" "SEL" "id" }
+ [
+ nip
+ dup -> deltaZ sgn {
+ { 1 [ T{ zoom-in-action } send-action$ ] }
+ { -1 [ T{ zoom-out-action } send-action$ ] }
+ { 0 [ 2drop ] }
+ } case
+ ]
+}
+
+{ "swipeWithEvent:" "void" { "id" "SEL" "id" }
+ [
+ nip
+ dup -> deltaX sgn {
+ { 1 [ T{ left-action } send-action$ ] }
+ { -1 [ T{ right-action } send-action$ ] }
+ { 0
+ [
+ dup -> deltaY sgn {
+ { 1 [ T{ up-action } send-action$ ] }
+ { -1 [ T{ down-action } send-action$ ] }
+ { 0 [ 2drop ] }
+ } case
+ ]
+ }
+ } case
+ ]
+}
+
+! "rotateWithEvent:" "void" { "id" "SEL" "id" }}
+
+{ "acceptsFirstResponder" "char" { "id" "SEL" }
+ [ 2drop 1 ]
+}
+
+! Services
+{ "validRequestorForSendType:returnType:" "id" { "id" "SEL" "id" "id" }
+ [
+ ! We return either self or nil
+ [ over window-focus ] 2dip
+ valid-service? [ drop ] [ 2drop f ] if
+ ]
+}
+
+{ "writeSelectionToPasteboard:types:" "char" { "id" "SEL" "id" "id" }
+ [
+ CF>string-array NSStringPboardType swap member? [
+ [ drop window-focus gadget-selection ] dip over
+ [ set-pasteboard-string 1 ] [ 2drop 0 ] if
+ ] [ 3drop 0 ] if
+ ]
+}
+
+{ "readSelectionFromPasteboard:" "char" { "id" "SEL" "id" }
+ [
+ pasteboard-string dup [
+ [ drop window ] dip swap user-input 1
+ ] [ 3drop 0 ] if
+ ]
+}
+
+! Text input
+{ "insertText:" "void" { "id" "SEL" "id" }
+ [ nip CF>string swap window user-input ]
+}
+
+{ "hasMarkedText" "char" { "id" "SEL" }
+ [ 2drop 0 ]
+}
+
+{ "markedRange" "NSRange" { "id" "SEL" }
+ [ 2drop 0 0 <NSRange> ]
+}
+
+{ "selectedRange" "NSRange" { "id" "SEL" }
+ [ 2drop 0 0 <NSRange> ]
+}
+
+{ "setMarkedText:selectedRange:" "void" { "id" "SEL" "id" "NSRange" }
+ [ 2drop 2drop ]
+}
+
+{ "unmarkText" "void" { "id" "SEL" }
+ [ 2drop ]
+}
+
+{ "validAttributesForMarkedText" "id" { "id" "SEL" }
+ [ 2drop NSArray -> array ]
+}
+
+{ "attributedSubstringFromRange:" "id" { "id" "SEL" "NSRange" }
+ [ 3drop f ]
+}
+
+{ "characterIndexForPoint:" "NSUInteger" { "id" "SEL" "NSPoint" }
+ [ 3drop 0 ]
+}
+
+{ "firstRectForCharacterRange:" "NSRect" { "id" "SEL" "NSRange" }
+ [ 3drop 0 0 0 0 <CGRect> ]
+}
+
+{ "conversationIdentifier" "NSInteger" { "id" "SEL" }
+ [ drop alien-address ]
+}
+
+! Initialization
+{ "updateFactorGadgetSize:" "void" { "id" "SEL" "id" }
+ [ 2drop dup view-dim swap window (>>dim) yield ]
+}
+
+{ "doCommandBySelector:" "void" { "id" "SEL" "SEL" }
+ [ 3drop ]
+}
+
+{ "initWithFrame:pixelFormat:" "id" { "id" "SEL" "NSRect" "id" }
+ [
+ [ drop ] 2dip
+ SUPER-> initWithFrame:pixelFormat:
+ dup dup add-resize-observer
+ ]
+}
+
+{ "dealloc" "void" { "id" "SEL" }
+ [
+ drop
+ [ unregister-window ]
+ [ remove-observer ]
+ [ SUPER-> dealloc ]
+ tri
+ ]
+} ;
+
+: sync-refresh-to-screen ( GLView -- )
+ -> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 <int>
+ CGLSetParameter drop ;
+
+: <FactorView> ( world -- view )
+ FactorView over rect-dim <GLView>
+ [ sync-refresh-to-screen ] keep
+ [ register-window ] keep ;
+
+CLASS: {
+ { +superclass+ "NSObject" }
+ { +name+ "FactorWindowDelegate" }
+}
+
+{ "windowDidMove:" "void" { "id" "SEL" "id" }
+ [
+ 2nip -> object
+ [ -> contentView window ]
+ [ window-content-rect CGRect-x-y 2array ] bi
+ >>window-loc drop
+ ]
+}
+
+{ "windowDidBecomeKey:" "void" { "id" "SEL" "id" }
+ [
+ 2nip -> object -> contentView window focus-world
+ ]
+}
+
+{ "windowDidResignKey:" "void" { "id" "SEL" "id" }
+ [
+ forget-rollover
+ 2nip -> object -> contentView window unfocus-world
+ ]
+}
+
+{ "windowShouldClose:" "char" { "id" "SEL" "id" }
+ [
+ 3drop 1
+ ]
+}
+
+{ "windowWillClose:" "void" { "id" "SEL" "id" }
+ [
+ 2nip -> object -> contentView window ungraft
+ ]
+} ;
+
+: install-window-delegate ( window -- )
+ FactorWindowDelegate install-delegate ;
--- /dev/null
+Doug Coleman
--- /dev/null
+unportable
--- /dev/null
+! 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.geometry.rect 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) ;
+
+: wm-keydown-codes ( -- key )
+ 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
+ H{
+ { 16 "SHIFT" }
+ { 17 "CTRL" }
+ { 18 "ALT" }
+ { 20 "CAPS-LOCK" }
+ } ;
+
+: exclude-keys-wm-char
+ ! Values are ignored
+ 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 ] [ rect-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
+Slava Pestov
--- /dev/null
+unportable
--- /dev/null
+! 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.geometry.rect
+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 ;
+
+: modifiers
+ {
+ { S+ HEX: 1 }
+ { C+ HEX: 4 }
+ { A+ HEX: 8 }
+ } ;
+
+: 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 <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 )
+ dup event-modifiers swap 0 XLookupKeysym key-code <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 contains? ;
+
+: 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 -- )
+ dup xic>> XDestroyIC
+ dup glx>> destroy-glx
+ window>> dup unregister-window
+ destroy-window ;
+
+M: world client-event
+ swap close-box? [ ungraft ] [ drop ] if ;
+
+: gadget-window ( world -- )
+ dup window-loc>> over rect-dim glx-window
+ over "Factor" create-xic rot <x11-handle>
+ 2dup window>> register-window
+ >>handle drop ;
+
+: wait-event ( -- event )
+ QueuedAfterFlush events-queued 0 > [
+ next-event dup
+ None XFilterEvent zero? [ 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
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2006, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors math arrays assocs cocoa cocoa.application
-command-line kernel memory namespaces cocoa.messages
-cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
-cocoa.windows cocoa.classes cocoa.nibs sequences system ui
-ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
-ui.cocoa.views core-foundation core-foundation.run-loop
-core-graphics.types threads math.geometry.rect fry libc
-generalizations alien.c-types cocoa.views ui.cocoa.text
-combinators io.thread ;
-IN: ui.cocoa
-
-TUPLE: handle ;
-TUPLE: window-handle < handle view window ;
-TUPLE: offscreen-handle < handle context buffer ;
-
-C: <window-handle> window-handle
-C: <offscreen-handle> offscreen-handle
-
-SINGLETON: cocoa-ui-backend
-
-TUPLE: pasteboard handle ;
-
-C: <pasteboard> pasteboard
-
-M: pasteboard clipboard-contents
- handle>> pasteboard-string ;
-
-M: pasteboard set-clipboard-contents
- handle>> set-pasteboard-string ;
-
-: init-clipboard ( -- )
- NSPasteboard -> generalPasteboard <pasteboard>
- clipboard set-global
- <clipboard> selection set-global ;
-
-: world>NSRect ( world -- NSRect )
- [ window-loc>> ] [ dim>> ] bi [ first2 ] bi@ <CGRect> ;
-
-: gadget-window ( world -- )
- dup <FactorView>
- 2dup swap world>NSRect <ViewWindow>
- [ [ -> release ] [ install-window-delegate ] bi* ]
- [ <window-handle> ] 2bi
- >>handle drop ;
-
-M: cocoa-ui-backend set-title ( string world -- )
- handle>> window>> swap <NSString> -> setTitle: ;
-
-: enter-fullscreen ( world -- )
- handle>> view>>
- NSScreen -> mainScreen
- f -> enterFullScreenMode:withOptions:
- drop ;
-
-: exit-fullscreen ( world -- )
- handle>> view>> f -> exitFullScreenModeWithOptions: ;
-
-M: cocoa-ui-backend set-fullscreen* ( ? world -- )
- swap [ enter-fullscreen ] [ exit-fullscreen ] if ;
-
-M: cocoa-ui-backend fullscreen* ( world -- ? )
- handle>> view>> -> isInFullScreenMode zero? not ;
-
-: auto-position ( world -- )
- dup window-loc>> { 0 0 } = [
- handle>> window>> -> center
- ] [
- drop
- ] if ;
-
-M: cocoa-ui-backend (open-window) ( world -- )
- dup gadget-window
- dup auto-position
- handle>> window>> f -> makeKeyAndOrderFront: ;
-
-M: cocoa-ui-backend (close-window) ( handle -- )
- window>> -> release ;
-
-M: cocoa-ui-backend close-window ( gadget -- )
- find-world [
- handle>> [
- window>> f -> performClose:
- ] when*
- ] when* ;
-
-M: cocoa-ui-backend raise-window* ( world -- )
- handle>> [
- window>> dup f -> orderFront: -> makeKeyWindow
- NSApp 1 -> activateIgnoringOtherApps:
- ] when* ;
-
-: pixel-size ( pixel-format -- size )
- 0 <int> [ NSOpenGLPFAColorSize 0 -> getValues:forAttribute:forVirtualScreen: ]
- keep *int -3 shift ;
-
-: offscreen-buffer ( world pixel-format -- alien w h pitch )
- [ dim>> first2 ] [ pixel-size ] bi*
- { [ * * malloc ] [ 2drop ] [ drop nip ] [ nip * ] } 3cleave ;
-
-: gadget-offscreen-context ( world -- context buffer )
- NSOpenGLPFAOffScreen 1array <PixelFormat>
- [ nip NSOpenGLContext -> alloc swap f -> initWithFormat:shareContext: dup ]
- [ offscreen-buffer ] 2bi
- 4 npick [ -> setOffScreen:width:height:rowbytes: ] dip ;
-
-M: cocoa-ui-backend (open-offscreen-buffer) ( world -- )
- dup gadget-offscreen-context <offscreen-handle> >>handle drop ;
-
-M: cocoa-ui-backend (close-offscreen-buffer) ( handle -- )
- [ context>> -> release ]
- [ buffer>> free ] bi ;
-
-GENERIC: (gl-context) ( handle -- context )
-M: window-handle (gl-context) view>> -> openGLContext ;
-M: offscreen-handle (gl-context) context>> ;
-
-M: handle select-gl-context ( handle -- )
- (gl-context) -> makeCurrentContext ;
-
-M: handle flush-gl-context ( handle -- )
- (gl-context) -> flushBuffer ;
-
-M: cocoa-ui-backend offscreen-pixels ( world -- alien w h )
- [ handle>> buffer>> ] [ dim>> first2 neg ] bi ;
-
-M: cocoa-ui-backend beep ( -- )
- NSBeep ;
-
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "FactorApplicationDelegate" }
-}
-
-{ "applicationDidUpdate:" "void" { "id" "SEL" "id" }
- [ 3drop reset-run-loop ]
-} ;
-
-: install-app-delegate ( -- )
- NSApp FactorApplicationDelegate install-delegate ;
-
-SYMBOL: cocoa-init-hook
-
-cocoa-init-hook global [
- [ "MiniFactor.nib" load-nib install-app-delegate ] or
-] change-at
-
-M: cocoa-ui-backend (with-ui)
- "UI" assert.app [
- [
- init-clipboard
- cocoa-init-hook get call
- start-ui
- f io-thread-running? set-global
- init-thread-timer
- reset-run-loop
- NSApp -> run
- ] ui-running
- ] with-cocoa ;
-
-cocoa-ui-backend ui-backend set-global
-
-[ running.app? "ui.tools" "listener" ? ] main-vocab-hook set-global
+++ /dev/null
-Cocoa UI backend
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
\ No newline at end of file
+++ /dev/null
-UI text rendering implementation using Mac OS X Core Text
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test ui.cocoa.text ;
-IN: ui.cocoa.text.tests
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs accessors alien core-graphics.types core-text kernel
-hashtables namespaces sequences ui.gadgets.worlds ui.text
-ui.text.private opengl opengl.gl destructors combinators core-foundation
-core-foundation.strings io.styles memoize math math.vectors ;
-IN: ui.cocoa.text
-
-SINGLETON: core-text-renderer
-
-CONSTANT: font-names
- H{
- { "monospace" "Monaco" }
- { "sans-serif" "Helvetica" }
- { "serif" "Times" }
- }
-
-: font-name ( string -- string' )
- font-names at-default ;
-
-: (bold) ( x -- y ) kCTFontBoldTrait bitor ; inline
-
-: (italic) ( x -- y ) kCTFontItalicTrait bitor ; inline
-
-: font-traits ( style -- mask )
- [ 0 ] dip {
- { plain [ ] }
- { bold [ (bold) ] }
- { italic [ (italic) ] }
- { bold-italic [ (bold) (italic) ] }
- } case ;
-
-: apply-font-traits ( font style -- font' )
- [ drop ] [ [ 0.0 f ] dip font-traits dup ] 2bi
- CTFontCreateCopyWithSymbolicTraits
- dup [ [ CFRelease ] dip ] [ drop ] if ;
-
-MEMO: cache-font ( font -- open-font )
- [
- [
- [ first font-name <CFString> &CFRelease ] [ third ] bi
- f CTFontCreateWithName
- ] [ second ] bi apply-font-traits
- ] with-destructors ;
-
-M: core-text-renderer open-font
- dup alien? [ cache-font ] unless ;
-
-M: core-text-renderer string-dim
- [ " " string-dim { 0 1 } v* ] [ swap cached-line dim>> ] if-empty ;
-
-TUPLE: line-texture line texture age disposed ;
-
-: <line-texture> ( line -- texture )
- dup [ dim>> ] [ bitmap>> ] bi GL_RGBA make-texture
- 0 f \ line-texture boa ;
-
-M: line-texture dispose* texture>> delete-texture ;
-
-: line-texture ( string open-font -- texture )
- world get fonts>> [ cached-line <line-texture> ] 2cache ;
-
-: draw-line-texture ( line-texture -- )
- GL_TEXTURE_2D [
- GL_TEXTURE_BIT [
- GL_TEXTURE_COORD_ARRAY [
- GL_TEXTURE_2D over texture>> glBindTexture
- init-texture rect-texture-coords
- line>> dim>> fill-rect-vertices (gl-fill-rect)
- GL_TEXTURE_2D 0 glBindTexture
- ] do-enabled-client-state
- ] do-attribs
- ] do-enabled ;
-
-M: core-text-renderer draw-string ( font string loc -- )
- [ swap open-font line-texture draw-line-texture ] with-translation ;
-
-M: core-text-renderer x>offset ( x font string -- n )
- [ 2drop 0 ] [
- swap open-font cached-line line>>
- swap 0 <CGPoint> CTLineGetStringIndexForPosition
- ] if-empty ;
-
-M: core-text-renderer offset>x ( n font string -- x )
- swap open-font cached-line line>> swap f CTLineGetOffsetForStringIndex ;
-
-M: core-text-renderer free-fonts ( fonts -- )
- values dispose-each ;
-
-core-text-renderer font-renderer set-global
\ No newline at end of file
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Cocoa integration for UI developer tools
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2006, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax cocoa cocoa.nibs cocoa.application
-cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.subclassing
-core-foundation core-foundation.strings help.topics kernel
-memory namespaces parser system ui ui.tools.browser
-ui.tools.listener ui.cocoa eval locals tools.vocabs ;
-IN: ui.cocoa.tools
-
-: finder-run-files ( alien -- )
- CF>string-array listener-run-files
- NSApp NSApplicationDelegateReplySuccess
- -> replyToOpenOrPrint: ;
-
-: menu-run-files ( -- )
- open-panel [ listener-run-files ] when* ;
-
-: menu-save-image ( -- )
- image save-panel [ save-image ] when* ;
-
-! Handle Open events from the Finder
-CLASS: {
- { +superclass+ "FactorApplicationDelegate" }
- { +name+ "FactorWorkspaceApplicationDelegate" }
-}
-
-{ "application:openFiles:" "void" { "id" "SEL" "id" "id" }
- [ [ 3drop ] dip finder-run-files ]
-}
-
-{ "factorListener:" "id" { "id" "SEL" "id" }
- [ 3drop show-listener f ]
-}
-
-{ "factorBrowser:" "id" { "id" "SEL" "id" }
- [ 3drop show-browser f ]
-}
-
-{ "newFactorListener:" "id" { "id" "SEL" "id" }
- [ 3drop listener-window f ]
-}
-
-{ "newFactorBrowser:" "id" { "id" "SEL" "id" }
- [ 3drop browser-window f ]
-}
-
-{ "runFactorFile:" "id" { "id" "SEL" "id" }
- [ 3drop menu-run-files f ]
-}
-
-{ "saveFactorImage:" "id" { "id" "SEL" "id" }
- [ 3drop save f ]
-}
-
-{ "saveFactorImageAs:" "id" { "id" "SEL" "id" }
- [ 3drop menu-save-image f ]
-}
-
-{ "refreshAll:" "id" { "id" "SEL" "id" }
- [ 3drop [ refresh-all ] call-listener f ]
-} ;
-
-: install-app-delegate ( -- )
- NSApp FactorWorkspaceApplicationDelegate install-delegate ;
-
-! Service support; evaluate Factor code from other apps
-:: do-service ( pboard error quot -- )
- pboard error ?pasteboard-string
- dup [ quot call ] when
- [ pboard set-pasteboard-string ] when* ;
-
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "FactorServiceProvider" }
-} {
- "evalInListener:userData:error:"
- "void"
- { "id" "SEL" "id" "id" "id" }
- [ nip [ eval-listener f ] do-service 2drop ]
-} {
- "evalToString:userData:error:"
- "void"
- { "id" "SEL" "id" "id" "id" }
- [ nip [ eval>string ] do-service 2drop ]
-} ;
-
-: register-services ( -- )
- NSApp
- FactorServiceProvider -> alloc -> init
- -> setServicesProvider: ;
-
-FUNCTION: void NSUpdateDynamicServices ;
-
-[
- install-app-delegate
- "Factor.nib" load-nib
- register-services
-] cocoa-init-hook set-global
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Cocoa NSView implementation displaying Factor gadgets
+++ /dev/null
-unportable
+++ /dev/null
-IN: ui.cocoa.views.tests
-USING: ui.cocoa.views tools.test kernel math.geometry.rect
-namespaces ;
-
-[ t ] [
- T{ rect
- { loc { 0 0 } }
- { dim { 1000 1000 } }
- } "world" set
-
- T{ rect
- { loc { 1.5 2.25 } }
- { dim { 13.0 14.0 } }
- } dup "world" get rect>NSRect "world" get NSRect>rect =
-] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays assocs cocoa kernel
-math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views
-cocoa.application cocoa.pasteboard cocoa.types cocoa.windows
-sequences ui ui.gadgets ui.gadgets.worlds ui.gestures
-core-foundation.strings core-graphics core-graphics.types
-threads combinators math.geometry.rect ;
-IN: ui.cocoa.views
-
-: send-mouse-moved ( view event -- )
- [ mouse-location ] [ drop window ] 2bi move-hand fire-motion ;
-
-: button ( event -- n )
- #! Cocoa -> Factor UI button mapping
- -> buttonNumber H{ { 0 1 } { 2 2 } { 1 3 } } at ;
-
-CONSTANT: modifiers
- {
- { S+ HEX: 20000 }
- { C+ HEX: 40000 }
- { A+ HEX: 100000 }
- { M+ HEX: 80000 }
- }
-
-CONSTANT: key-codes
- H{
- { 71 "CLEAR" }
- { 36 "RET" }
- { 76 "ENTER" }
- { 53 "ESC" }
- { 48 "TAB" }
- { 51 "BACKSPACE" }
- { 115 "HOME" }
- { 117 "DELETE" }
- { 119 "END" }
- { 122 "F1" }
- { 120 "F2" }
- { 99 "F3" }
- { 118 "F4" }
- { 96 "F5" }
- { 97 "F6" }
- { 98 "F7" }
- { 100 "F8" }
- { 123 "LEFT" }
- { 124 "RIGHT" }
- { 125 "DOWN" }
- { 126 "UP" }
- { 116 "PAGE_UP" }
- { 121 "PAGE_DOWN" }
- }
-
-: key-code ( event -- string ? )
- dup -> keyCode key-codes at
- [ t ] [ -> charactersIgnoringModifiers CF>string f ] ?if ;
-
-: event-modifiers ( event -- modifiers )
- -> modifierFlags modifiers modifier ;
-
-: key-event>gesture ( event -- modifiers keycode action? )
- [ event-modifiers ] [ key-code ] bi ;
-
-: send-key-event ( view gesture -- )
- swap window propagate-key-gesture ;
-
-: interpret-key-event ( view event -- )
- NSArray swap -> arrayWithObject: -> interpretKeyEvents: ;
-
-: send-key-down-event ( view event -- )
- [ key-event>gesture <key-down> send-key-event ]
- [ interpret-key-event ]
- 2bi ;
-
-: send-key-up-event ( view event -- )
- key-event>gesture <key-up> send-key-event ;
-
-: mouse-event>gesture ( event -- modifiers button )
- [ event-modifiers ] [ button ] bi ;
-
-: send-button-down$ ( view event -- )
- [ nip mouse-event>gesture <button-down> ]
- [ mouse-location ]
- [ drop window ]
- 2tri send-button-down ;
-
-: send-button-up$ ( view event -- )
- [ nip mouse-event>gesture <button-up> ]
- [ mouse-location ]
- [ drop window ]
- 2tri send-button-up ;
-
-: send-wheel$ ( view event -- )
- [ nip [ -> deltaX ] [ -> deltaY ] bi [ sgn neg ] bi@ 2array ]
- [ mouse-location ]
- [ drop window ]
- 2tri send-wheel ;
-
-: send-action$ ( view event gesture -- junk )
- [ drop window ] dip send-action f ;
-
-: add-resize-observer ( observer object -- )
- [
- "updateFactorGadgetSize:"
- "NSViewFrameDidChangeNotification" <NSString>
- ] dip add-observer ;
-
-: string-or-nil? ( NSString -- ? )
- [ CF>string NSStringPboardType = ] [ t ] if* ;
-
-: valid-service? ( gadget send-type return-type -- ? )
- 2dup [ string-or-nil? ] [ string-or-nil? ] bi* and
- [ drop [ gadget-selection? ] [ drop t ] if ] [ 3drop f ] if ;
-
-: NSRect>rect ( NSRect world -- rect )
- [ [ [ CGRect-x ] [ CGRect-y ] bi ] [ dim>> second ] bi* swap - 2array ]
- [ drop [ CGRect-w ] [ CGRect-h ] bi 2array ]
- 2bi <rect> ;
-
-: rect>NSRect ( rect world -- NSRect )
- [ [ rect-loc first2 ] [ dim>> second ] bi* swap - ]
- [ drop rect-dim first2 ]
- 2bi <CGRect> ;
-
-CLASS: {
- { +superclass+ "NSOpenGLView" }
- { +name+ "FactorView" }
- { +protocols+ { "NSTextInput" } }
-}
-
-! Rendering
-{ "drawRect:" "void" { "id" "SEL" "NSRect" }
- [ 2drop window relayout-1 ]
-}
-
-! Events
-{ "acceptsFirstMouse:" "char" { "id" "SEL" "id" }
- [ 3drop 1 ]
-}
-
-{ "mouseEntered:" "void" { "id" "SEL" "id" }
- [ nip send-mouse-moved ]
-}
-
-{ "mouseExited:" "void" { "id" "SEL" "id" }
- [ 3drop forget-rollover ]
-}
-
-{ "mouseMoved:" "void" { "id" "SEL" "id" }
- [ nip send-mouse-moved ]
-}
-
-{ "mouseDragged:" "void" { "id" "SEL" "id" }
- [ nip send-mouse-moved ]
-}
-
-{ "rightMouseDragged:" "void" { "id" "SEL" "id" }
- [ nip send-mouse-moved ]
-}
-
-{ "otherMouseDragged:" "void" { "id" "SEL" "id" }
- [ nip send-mouse-moved ]
-}
-
-{ "mouseDown:" "void" { "id" "SEL" "id" }
- [ nip send-button-down$ ]
-}
-
-{ "mouseUp:" "void" { "id" "SEL" "id" }
- [ nip send-button-up$ ]
-}
-
-{ "rightMouseDown:" "void" { "id" "SEL" "id" }
- [ nip send-button-down$ ]
-}
-
-{ "rightMouseUp:" "void" { "id" "SEL" "id" }
- [ nip send-button-up$ ]
-}
-
-{ "otherMouseDown:" "void" { "id" "SEL" "id" }
- [ nip send-button-down$ ]
-}
-
-{ "otherMouseUp:" "void" { "id" "SEL" "id" }
- [ nip send-button-up$ ]
-}
-
-{ "scrollWheel:" "void" { "id" "SEL" "id" }
- [ nip send-wheel$ ]
-}
-
-{ "keyDown:" "void" { "id" "SEL" "id" }
- [ nip send-key-down-event ]
-}
-
-{ "keyUp:" "void" { "id" "SEL" "id" }
- [ nip send-key-up-event ]
-}
-
-{ "cut:" "id" { "id" "SEL" "id" }
- [ nip T{ cut-action } send-action$ ]
-}
-
-{ "copy:" "id" { "id" "SEL" "id" }
- [ nip T{ copy-action } send-action$ ]
-}
-
-{ "paste:" "id" { "id" "SEL" "id" }
- [ nip T{ paste-action } send-action$ ]
-}
-
-{ "delete:" "id" { "id" "SEL" "id" }
- [ nip T{ delete-action } send-action$ ]
-}
-
-{ "selectAll:" "id" { "id" "SEL" "id" }
- [ nip T{ select-all-action } send-action$ ]
-}
-
-! Multi-touch gestures: this is undocumented.
-! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html
-{ "magnifyWithEvent:" "void" { "id" "SEL" "id" }
- [
- nip
- dup -> deltaZ sgn {
- { 1 [ T{ zoom-in-action } send-action$ ] }
- { -1 [ T{ zoom-out-action } send-action$ ] }
- { 0 [ 2drop ] }
- } case
- ]
-}
-
-{ "swipeWithEvent:" "void" { "id" "SEL" "id" }
- [
- nip
- dup -> deltaX sgn {
- { 1 [ T{ left-action } send-action$ ] }
- { -1 [ T{ right-action } send-action$ ] }
- { 0
- [
- dup -> deltaY sgn {
- { 1 [ T{ up-action } send-action$ ] }
- { -1 [ T{ down-action } send-action$ ] }
- { 0 [ 2drop ] }
- } case
- ]
- }
- } case
- ]
-}
-
-! "rotateWithEvent:" "void" { "id" "SEL" "id" }}
-
-{ "acceptsFirstResponder" "char" { "id" "SEL" }
- [ 2drop 1 ]
-}
-
-! Services
-{ "validRequestorForSendType:returnType:" "id" { "id" "SEL" "id" "id" }
- [
- ! We return either self or nil
- [ over window-focus ] 2dip
- valid-service? [ drop ] [ 2drop f ] if
- ]
-}
-
-{ "writeSelectionToPasteboard:types:" "char" { "id" "SEL" "id" "id" }
- [
- CF>string-array NSStringPboardType swap member? [
- [ drop window-focus gadget-selection ] dip over
- [ set-pasteboard-string 1 ] [ 2drop 0 ] if
- ] [ 3drop 0 ] if
- ]
-}
-
-{ "readSelectionFromPasteboard:" "char" { "id" "SEL" "id" }
- [
- pasteboard-string dup [
- [ drop window ] dip swap user-input 1
- ] [ 3drop 0 ] if
- ]
-}
-
-! Text input
-{ "insertText:" "void" { "id" "SEL" "id" }
- [ nip CF>string swap window user-input ]
-}
-
-{ "hasMarkedText" "char" { "id" "SEL" }
- [ 2drop 0 ]
-}
-
-{ "markedRange" "NSRange" { "id" "SEL" }
- [ 2drop 0 0 <NSRange> ]
-}
-
-{ "selectedRange" "NSRange" { "id" "SEL" }
- [ 2drop 0 0 <NSRange> ]
-}
-
-{ "setMarkedText:selectedRange:" "void" { "id" "SEL" "id" "NSRange" }
- [ 2drop 2drop ]
-}
-
-{ "unmarkText" "void" { "id" "SEL" }
- [ 2drop ]
-}
-
-{ "validAttributesForMarkedText" "id" { "id" "SEL" }
- [ 2drop NSArray -> array ]
-}
-
-{ "attributedSubstringFromRange:" "id" { "id" "SEL" "NSRange" }
- [ 3drop f ]
-}
-
-{ "characterIndexForPoint:" "NSUInteger" { "id" "SEL" "NSPoint" }
- [ 3drop 0 ]
-}
-
-{ "firstRectForCharacterRange:" "NSRect" { "id" "SEL" "NSRange" }
- [ 3drop 0 0 0 0 <CGRect> ]
-}
-
-{ "conversationIdentifier" "NSInteger" { "id" "SEL" }
- [ drop alien-address ]
-}
-
-! Initialization
-{ "updateFactorGadgetSize:" "void" { "id" "SEL" "id" }
- [ 2drop dup view-dim swap window (>>dim) yield ]
-}
-
-{ "doCommandBySelector:" "void" { "id" "SEL" "SEL" }
- [ 3drop ]
-}
-
-{ "initWithFrame:pixelFormat:" "id" { "id" "SEL" "NSRect" "id" }
- [
- [ drop ] 2dip
- SUPER-> initWithFrame:pixelFormat:
- dup dup add-resize-observer
- ]
-}
-
-{ "dealloc" "void" { "id" "SEL" }
- [
- drop
- [ unregister-window ]
- [ remove-observer ]
- [ SUPER-> dealloc ]
- tri
- ]
-} ;
-
-: sync-refresh-to-screen ( GLView -- )
- -> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 <int>
- CGLSetParameter drop ;
-
-: <FactorView> ( world -- view )
- FactorView over rect-dim <GLView>
- [ sync-refresh-to-screen ] keep
- [ register-window ] keep ;
-
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "FactorWindowDelegate" }
-}
-
-{ "windowDidMove:" "void" { "id" "SEL" "id" }
- [
- 2nip -> object
- [ -> contentView window ]
- [ window-content-rect CGRect-x-y 2array ] bi
- >>window-loc drop
- ]
-}
-
-{ "windowDidBecomeKey:" "void" { "id" "SEL" "id" }
- [
- 2nip -> object -> contentView window focus-world
- ]
-}
-
-{ "windowDidResignKey:" "void" { "id" "SEL" "id" }
- [
- forget-rollover
- 2nip -> object -> contentView window unfocus-world
- ]
-}
-
-{ "windowShouldClose:" "char" { "id" "SEL" "id" }
- [
- 3drop 1
- ]
-}
-
-{ "windowWillClose:" "void" { "id" "SEL" "id" }
- [
- 2nip -> object -> contentView window ungraft
- ]
-} ;
-
-: install-window-delegate ( window -- )
- FactorWindowDelegate install-delegate ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.syntax help.markup strings kernel alien opengl
-opengl.sprites quotations ui.render io.styles freetype ;
-IN: ui.freetype
-
-HELP: freetype
-{ $values { "alien" alien } }
-{ $description "Outputs a native handle used by the FreeType library, initializing FreeType first if necessary." } ;
-
-HELP: open-fonts
-{ $var-description "Global variable. Hashtable mapping font descriptors to " { $link font } " instances." } ;
-
-{ font open-fonts open-font char-width string-width text-dim draw-string draw-text } related-words
-
-HELP: init-freetype
-{ $description "Initializes the FreeType library." }
-{ $notes "Do not call this word if you are using the UI." } ;
-
-HELP: font
-
-{ $class-description
-
-"A font which has been loaded by FreeType. Font instances have the following slots:"
-
-{
- $list
- {
- { $snippet "ascent" } ", "
- { $snippet "descent" } ", "
- { $snippet "height" } " - metrics."
- }
-
- {
- { $snippet "handle" }
- " - alien pointer to an "
- { $snippet "FT_Face" } "."
- }
-
- {
- { $snippet "widths" }
- " - sequence of character widths. Use "
- { $snippet "width" }
- " and "
- { $snippet "width" }
- " to compute string widths instead of reading this sequence directly."
- }
-}
-
-} ;
-
-HELP: close-freetype
-{ $description "Closes the FreeType library." }
-{ $notes "Do not call this word if you are using the UI." } ;
-
-HELP: open-face
-{ $values { "font" string } { "style" "one of " { $link plain } ", " { $link bold } ", " { $link italic } " or " { $link bold-italic } } { "face" "alien pointer to an " { $snippet "FT_Face" } } }
-{ $description "Loads a TrueType font with the requested logical font name and style." }
-{ $notes "This is a low-level word. Call " { $link open-font } " instead." } ;
-
-HELP: render-glyph
-{ $values { "font" font } { "char" "a non-negative integer" } { "bitmap" alien } }
-{ $description "Renders a character and outputs a pointer to the bitmap." } ;
-
-HELP: <char-sprite>
-{ $values { "open-font" font } { "char" "a non-negative integer" } { "sprite" sprite } }
-{ $description "Renders a character to an OpenGL texture and records a display list which draws a quad with this texture. This word allocates native resources which must be freed by " { $link free-sprites } "." } ;
-
-HELP: (draw-string)
-{ $values { "open-font" font } { "sprites" "a vector of " { $link sprite } " instances" } { "string" string } { "loc" "a pair of integers" } }
-{ $description "Draws a line of text." }
-{ $notes "This is a low-level word, UI code should use " { $link draw-string } " or " { $link draw-text } " instead." }
-{ $side-effects "sprites" } ;
-
-HELP: run-char-widths
-{ $values { "open-font" font } { "string" string } { "widths" "a sequence of integers" } }
-{ $description "Outputs a sequence of x co-ordinates of the midpoint of each character in the string." }
-{ $notes "This word is used to convert x offsets to document locations, for example when the user moves the caret by clicking the mouse." } ;
+++ /dev/null
-! Copyright (C) 2005, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.accessors alien.c-types arrays io kernel libc
-math math.vectors namespaces opengl opengl.gl opengl.sprites assocs
-sequences io.files io.styles continuations freetype
-ui.gadgets.worlds ui.text ui.text.private ui.backend byte-arrays accessors
-locals specialized-arrays.direct.uchar ;
-IN: ui.freetype
-
-SINGLETON: freetype-renderer
-
-SYMBOL: open-fonts
-
-: freetype-error ( n -- )
- zero? [ "FreeType error" throw ] unless ;
-
-DEFER: freetype
-
-: init-freetype ( -- )
- global [
- f <void*> dup FT_Init_FreeType freetype-error
- *void* \ freetype set
- H{ } clone open-fonts set
- ] bind ;
-
-: freetype ( -- alien )
- \ freetype get-global expired? [ init-freetype ] when
- \ freetype get-global ;
-
-TUPLE: font < identity-tuple
-ascent descent height handle widths ;
-
-M: font hashcode* drop font hashcode* ;
-
-: close-font ( font -- ) handle>> FT_Done_Face ;
-
-: close-freetype ( -- )
- global [
- open-fonts [ [ drop close-font ] assoc-each f ] change
- freetype [ FT_Done_FreeType f ] change
- ] bind ;
-
-M: freetype-renderer free-fonts ( world -- )
- values [ second free-sprites ] each ;
-
-: ttf-name ( font style -- name )
- 2array H{
- { { "monospace" plain } "VeraMono" }
- { { "monospace" bold } "VeraMoBd" }
- { { "monospace" bold-italic } "VeraMoBI" }
- { { "monospace" italic } "VeraMoIt" }
- { { "sans-serif" plain } "Vera" }
- { { "sans-serif" bold } "VeraBd" }
- { { "sans-serif" bold-italic } "VeraBI" }
- { { "sans-serif" italic } "VeraIt" }
- { { "serif" plain } "VeraSe" }
- { { "serif" bold } "VeraSeBd" }
- { { "serif" bold-italic } "VeraBI" }
- { { "serif" italic } "VeraIt" }
- } at ;
-
-: ttf-path ( name -- string )
- "resource:fonts/" ".ttf" surround ;
-
-: (open-face) ( path length -- face )
- #! We use FT_New_Memory_Face, not FT_New_Face, since
- #! FT_New_Face only takes an ASCII path name and causes
- #! problems on localized versions of Windows
- [ freetype ] 2dip 0 f <void*> [
- FT_New_Memory_Face freetype-error
- ] keep *void* ;
-
-: open-face ( font style -- face )
- ttf-name ttf-path malloc-file-contents (open-face) ;
-
-SYMBOL: dpi
-
-72 dpi set-global
-
-: ft-floor ( m -- n ) -6 shift ; inline
-
-: ft-ceil ( m -- n ) 63 + -64 bitand -6 shift ; inline
-
-: font-units>pixels ( n font -- n )
- face-size face-size-y-scale FT_MulFix ;
-
-: init-ascent ( font face -- font )
- dup face-y-max swap font-units>pixels >>ascent ; inline
-
-: init-descent ( font face -- font )
- dup face-y-min swap font-units>pixels >>descent ; inline
-
-: init-font ( font -- font )
- dup handle>> init-ascent
- dup handle>> init-descent
- dup [ ascent>> ] [ descent>> ] bi - ft-ceil >>height ; inline
-
-: set-char-size ( open-font size -- open-font )
- [ dup handle>> 0 ] dip
- 6 shift dpi get-global dup FT_Set_Char_Size freetype-error ;
-
-: <font> ( font -- open-font )
- font new
- H{ } clone >>widths
- over first2 open-face >>handle
- swap third set-char-size
- init-font ;
-
-M: freetype-renderer open-font ( font -- open-font )
- dup font? [
- freetype drop open-fonts get [ <font> ] cache
- ] unless ;
-
-: load-glyph ( font char -- glyph )
- [ handle>> dup ] dip 0 FT_Load_Char
- freetype-error face-glyph ;
-
-: char-width ( open-font char -- w )
- over widths>> [
- dupd load-glyph glyph-hori-advance ft-ceil
- ] cache nip ;
-
-M: freetype-renderer string-width ( open-font string -- w )
- [ 0 ] 2dip [ char-width + ] with each ;
-
-M: freetype-renderer string-height ( open-font string -- h )
- drop height>> ;
-
-: glyph-size ( glyph -- dim )
- [ glyph-hori-advance ft-ceil ]
- [ glyph-height ft-ceil ]
- bi 2array ;
-
-: render-glyph ( font char -- bitmap )
- load-glyph dup
- FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ;
-
-:: copy-pixel ( i j bitmap texture -- i j )
- 255 j texture set-nth
- i bitmap nth j 1 + texture set-nth
- i 1 + j 2 + ; inline
-
-:: (copy-row) ( i j bitmap texture end -- )
- i end < [
- i j bitmap texture copy-pixel
- bitmap texture end (copy-row)
- ] when ; inline recursive
-
-:: copy-row ( i j bitmap texture width width2 -- i j )
- i j bitmap texture i width + (copy-row)
- i width +
- j width2 + ; inline
-
-:: copy-bitmap ( glyph texture -- )
- [let* | bitmap [ glyph glyph-bitmap-buffer ]
- rows [ glyph glyph-bitmap-rows ]
- width [ glyph glyph-bitmap-width ]
- width2 [ width next-power-of-2 2 * ] |
- bitmap [
- bitmap rows width * <direct-uchar-array> :> bitmap'
- 0 0
- rows [ bitmap' texture width width2 copy-row ] times
- 2drop
- ] when
- ] ;
-
-: bitmap>texture ( glyph sprite -- id )
- tuck dim2>> product 2 * <byte-array>
- [ copy-bitmap ] keep [ dim2>> ] dip
- GL_LUMINANCE_ALPHA make-texture ;
-
-: glyph-texture-loc ( glyph font -- loc )
- [ drop glyph-hori-bearing-x ft-floor ]
- [ ascent>> swap glyph-hori-bearing-y - ft-floor ]
- 2bi 2array ;
-
-: glyph-texture-size ( glyph -- dim )
- [ glyph-bitmap-width next-power-of-2 ]
- [ glyph-bitmap-rows next-power-of-2 ]
- bi 2array ;
-
-: <char-sprite> ( open-font char -- sprite )
- over [ render-glyph dup ] dip glyph-texture-loc
- over glyph-size pick glyph-texture-size <sprite>
- [ bitmap>texture ] keep [ init-sprite ] keep ;
-
-:: char-sprite ( open-font sprites char -- sprite )
- char sprites [ open-font swap <char-sprite> ] cache ;
-
-: draw-char ( open-font sprites char loc -- )
- GL_MODELVIEW [
- 0 0 glTranslated
- char-sprite dlist>> glCallList
- ] do-matrix ;
-
-: char-widths ( open-font string -- widths )
- [ char-width ] with { } map-as ;
-
-: scan-sums ( seq -- seq' )
- 0 [ + ] accumulate nip ;
-
-:: (draw-string) ( open-font sprites string loc -- )
- GL_TEXTURE_2D [
- loc [
- string open-font string char-widths scan-sums [
- [ open-font sprites ] 2dip draw-char
- ] 2each
- ] with-translation
- ] do-enabled ;
-
-: font-sprites ( font world -- open-font sprites )
- fonts>> [ open-font H{ } clone 2array ] cache first2 ;
-
-M: freetype-renderer draw-string ( font string loc -- )
- [ world get font-sprites ] 2dip (draw-string) ;
-
-: run-char-widths ( open-font string -- widths )
- char-widths [ scan-sums ] [ 2 v/n ] bi v+ ;
-
-M: freetype-renderer x>offset ( x font string -- n )
- [ open-font ] dip
- [ run-char-widths [ <= ] with find drop ] keep swap
- [ ] [ length ] ?if ;
-
-M:: freetype-renderer offset>x ( n font string -- x )
- font open-font string n head string-width ;
-
-freetype-renderer font-renderer set-global
+++ /dev/null
-UI text rendering implementation using FreeType
+++ /dev/null
-unportable
$nl
"Editors have the following slots:"
{ $list
- { { $snippet "font" } " - a font specifier." }
- { { $snippet "color" } " - text color specifier." }
- { { $snippet "caret-color" } " - caret color specifier." }
- { { $snippet "selection-color" } " - selection background color specifier." }
- { { $snippet "caret" } " - a model storing a line/column pair." }
- { { $snippet "mark" } " - a model storing a line/column pair. If there is no selection, the mark is equal to the caret, otherwise the mark is located at the opposite end of the selection from the caret." }
+ { { $snippet "font" } " - a " { $link font } "." }
+ { { $snippet "color" } " - a " { $link color } "." }
+ { { $snippet "caret-color" } " - a " { $link color } ". }
+ { { $snippet "selection-color" } " - a " { $link color } ". }
+ { { $snippet "caret" } " - a " { $link model } " storing a line/column pair." }
+ { { $snippet "mark" } " - a " { $link model } " storing a line/column pair. If there is no selection, the mark is equal to the caret, otherwise the mark is located at the opposite end of the selection from the caret." }
{ { $snippet "focused?" } " - a boolean." }
} } ;
! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays documents kernel math models models.filter
-namespaces locals fry make opengl opengl.gl sequences strings io.styles
+namespaces locals fry make opengl opengl.gl sequences strings
math.vectors sorting colors combinators assocs math.order fry
calendar alarms continuations ui.clipboards ui.commands
ui.gadgets ui.gadgets.borders ui.gadgets.buttons
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces make sequences words io
-io.styles math.vectors ui.gadgets columns accessors
+math.vectors ui.gadgets columns accessors
math.geometry.rect locals fry ;
IN: ui.gadgets.grids
background [ solid-interior ] apply-style ;
: specified-font ( style -- font )
- [ font swap at "monospace" or ] keep
- [ font-style swap at plain or ] keep
- font-size swap at 12 or 3array ;
+ <font>
+ swap
+ [ font swap at "monospace" or >>name ]
+ [
+ font-style swap at {
+ { plain [ ] }
+ { bold [ t >>bold ] }
+ { italic [ t >>italic ] }
+ { bold-italic [ t >>bold t >>italic ] }
+ } case
+ ]
+ [ font-size swap at 12 or >>size ]
+ tri ;
: apply-font-style ( style gadget -- style gadget )
over specified-font >>font ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays accessors definitions hashtables io kernel
-sequences strings io.styles words help math models
-namespaces quotations
+sequences strings words help math models namespaces quotations
ui.gadgets ui.gadgets.borders ui.gadgets.buttons
ui.gadgets.labels ui.gadgets.menus ui.gadgets.worlds
ui.gadgets.status-bar ui.commands ui.operations ui.gestures ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays colors fry io.styles kernel math
+USING: accessors arrays colors fry kernel math
math.geometry.rect math.order math.vectors namespaces opengl
sequences ui.gadgets ui.gadgets.scrollers ui.gadgets.status-bar
ui.gadgets.worlds ui.gadgets.theme ui.gestures ui.render ui.text
! Copyright (C) 2005, 2008 Slava Pestov.
! Copyright (C) 2006, 2007 Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel sequences io.styles ui.gadgets ui.render
-colors colors.gray accessors ;
+USING: arrays kernel sequences ui.gadgets ui.render
+ui.text colors colors.gray accessors ;
QUALIFIED: colors
IN: ui.gadgets.theme
T{ gray f 0.5 1.0 }
} <gradient> ;
-: sans-serif-font { "sans-serif" plain 12 } ;
+CONSTANT: sans-serif-font T{ font { name "sans-serif" } { size 12 } }
-: monospace-font { "monospace" plain 12 } ;
+CONSTANT: monospace-font T{ font { name "monospace" } { size 12 } }
! 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
+vectors combinators math.vectors ui.gadgets colors
math.order math.geometry.rect locals specialized-arrays.float ;
IN: ui.render
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+UI text rendering implementation using Mac OS X Core Text
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test ui.text.core-text ;
+IN: ui.text.core-text.tests
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs accessors alien core-graphics.types core-text kernel
+hashtables namespaces sequences ui.gadgets.worlds ui.text
+ui.text.private opengl opengl.gl destructors combinators core-foundation
+core-foundation.strings memoize math math.vectors ;
+IN: ui.text.core-text
+
+SINGLETON: core-text-renderer
+
+CONSTANT: font-names
+ H{
+ { "monospace" "Monaco" }
+ { "sans-serif" "Helvetica" }
+ { "serif" "Times" }
+ }
+
+: font-name ( string -- string' )
+ font-names at-default ;
+
+: (bold) ( x -- y ) kCTFontBoldTrait bitor ; inline
+
+: (italic) ( x -- y ) kCTFontItalicTrait bitor ; inline
+
+: font-traits ( font -- n )
+ [ 0 ] dip
+ [ bold>> [ (bold) ] when ]
+ [ italic>> [ (italic) ] when ] bi ;
+
+: apply-font-traits ( font style -- font' )
+ [ drop ] [ [ 0.0 f ] dip font-traits dup ] 2bi
+ CTFontCreateCopyWithSymbolicTraits
+ dup [ [ CFRelease ] dip ] [ drop ] if ;
+
+MEMO: cache-font ( font -- open-font )
+ [
+ [
+ [ name>> font-name <CFString> &CFRelease ] [ size>> ] bi
+ f CTFontCreateWithName
+ ] keep apply-font-traits
+ ] with-destructors ;
+
+M: core-text-renderer open-font
+ dup alien? [ cache-font ] unless ;
+
+M: core-text-renderer string-dim
+ [ " " string-dim { 0 1 } v* ] [ swap cached-line dim>> ] if-empty ;
+
+TUPLE: line-texture line texture age disposed ;
+
+: <line-texture> ( line -- texture )
+ dup [ dim>> ] [ bitmap>> ] bi GL_RGBA make-texture
+ 0 f \ line-texture boa ;
+
+M: line-texture dispose* texture>> delete-texture ;
+
+: line-texture ( string open-font -- texture )
+ world get fonts>> [ cached-line <line-texture> ] 2cache ;
+
+: draw-line-texture ( line-texture -- )
+ GL_TEXTURE_2D [
+ GL_TEXTURE_BIT [
+ GL_TEXTURE_COORD_ARRAY [
+ GL_TEXTURE_2D over texture>> glBindTexture
+ init-texture rect-texture-coords
+ line>> dim>> fill-rect-vertices (gl-fill-rect)
+ GL_TEXTURE_2D 0 glBindTexture
+ ] do-enabled-client-state
+ ] do-attribs
+ ] do-enabled ;
+
+M: core-text-renderer draw-string ( font string loc -- )
+ [ swap open-font line-texture draw-line-texture ] with-translation ;
+
+M: core-text-renderer x>offset ( x font string -- n )
+ [ 2drop 0 ] [
+ swap open-font cached-line line>>
+ swap 0 <CGPoint> CTLineGetStringIndexForPosition
+ ] if-empty ;
+
+M: core-text-renderer offset>x ( n font string -- x )
+ swap open-font cached-line line>> swap f CTLineGetOffsetForStringIndex ;
+
+M: core-text-renderer free-fonts ( fonts -- )
+ values dispose-each ;
+
+core-text-renderer font-renderer set-global
\ No newline at end of file
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.syntax help.markup strings kernel alien opengl
+opengl.sprites quotations ui.render freetype ;
+IN: ui.text.freetype
+
+HELP: freetype
+{ $values { "alien" alien } }
+{ $description "Outputs a native handle used by the FreeType library, initializing FreeType first if necessary." } ;
+
+HELP: open-fonts
+{ $var-description "Global variable. Hashtable mapping font descriptors to " { $link font } " instances." } ;
+
+{ font open-fonts open-font char-width string-width text-dim draw-string draw-text } related-words
+
+HELP: init-freetype
+{ $description "Initializes the FreeType library." }
+{ $notes "Do not call this word if you are using the UI." } ;
+
+HELP: font
+
+{ $class-description
+
+"A font which has been loaded by FreeType. Font instances have the following slots:"
+
+{
+ $list
+ {
+ { $snippet "ascent" } ", "
+ { $snippet "descent" } ", "
+ { $snippet "height" } " - metrics."
+ }
+
+ {
+ { $snippet "handle" }
+ " - alien pointer to an "
+ { $snippet "FT_Face" } "."
+ }
+
+ {
+ { $snippet "widths" }
+ " - sequence of character widths. Use "
+ { $snippet "width" }
+ " and "
+ { $snippet "width" }
+ " to compute string widths instead of reading this sequence directly."
+ }
+}
+
+} ;
+
+HELP: close-freetype
+{ $description "Closes the FreeType library." }
+{ $notes "Do not call this word if you are using the UI." } ;
+
+HELP: open-face
+{ $values { "font" string } { "style" "one of " { $link plain } ", " { $link bold } ", " { $link italic } " or " { $link bold-italic } } { "face" "alien pointer to an " { $snippet "FT_Face" } } }
+{ $description "Loads a TrueType font with the requested logical font name and style." }
+{ $notes "This is a low-level word. Call " { $link open-font } " instead." } ;
+
+HELP: render-glyph
+{ $values { "font" font } { "char" "a non-negative integer" } { "bitmap" alien } }
+{ $description "Renders a character and outputs a pointer to the bitmap." } ;
+
+HELP: <char-sprite>
+{ $values { "open-font" font } { "char" "a non-negative integer" } { "sprite" sprite } }
+{ $description "Renders a character to an OpenGL texture and records a display list which draws a quad with this texture. This word allocates native resources which must be freed by " { $link free-sprites } "." } ;
+
+HELP: (draw-string)
+{ $values { "open-font" font } { "sprites" "a vector of " { $link sprite } " instances" } { "string" string } { "loc" "a pair of integers" } }
+{ $description "Draws a line of text." }
+{ $notes "This is a low-level word, UI code should use " { $link draw-string } " or " { $link draw-text } " instead." }
+{ $side-effects "sprites" } ;
+
+HELP: run-char-widths
+{ $values { "open-font" font } { "string" string } { "widths" "a sequence of integers" } }
+{ $description "Outputs a sequence of x co-ordinates of the midpoint of each character in the string." }
+{ $notes "This word is used to convert x offsets to document locations, for example when the user moves the caret by clicking the mouse." } ;
--- /dev/null
+! Copyright (C) 2005, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.accessors alien.c-types arrays io kernel libc
+math math.vectors namespaces opengl opengl.gl opengl.sprites assocs
+sequences io.files continuations freetype
+ui.gadgets.worlds ui.text ui.text.private ui.backend
+byte-arrays accessors locals specialized-arrays.direct.uchar
+combinators.smart ;
+IN: ui.text.freetype
+
+SINGLETON: freetype-renderer
+
+SYMBOL: open-fonts
+
+: freetype-error ( n -- )
+ zero? [ "FreeType error" throw ] unless ;
+
+DEFER: freetype
+
+: init-freetype ( -- )
+ global [
+ f <void*> dup FT_Init_FreeType freetype-error
+ *void* \ freetype set
+ H{ } clone open-fonts set
+ ] bind ;
+
+: freetype ( -- alien )
+ \ freetype get-global expired? [ init-freetype ] when
+ \ freetype get-global ;
+
+TUPLE: freetype-font < identity-tuple
+ascent descent height handle widths ;
+
+M: freetype-font hashcode* drop freetype-font hashcode* ;
+
+: close-font ( font -- ) handle>> FT_Done_Face ;
+
+: close-freetype ( -- )
+ global [
+ open-fonts [ [ drop close-font ] assoc-each f ] change
+ freetype [ FT_Done_FreeType f ] change
+ ] bind ;
+
+M: freetype-renderer free-fonts ( world -- )
+ values [ second free-sprites ] each ;
+
+: ttf-name ( font -- name )
+ [ [ name>> ] [ bold>> ] [ italic>> ] tri ] output>array H{
+ { { "monospace" f f } "VeraMono" }
+ { { "monospace" t f } "VeraMoBd" }
+ { { "monospace" t t } "VeraMoBI" }
+ { { "monospace" f t } "VeraMoIt" }
+ { { "sans-serif" f f } "Vera" }
+ { { "sans-serif" t f } "VeraBd" }
+ { { "sans-serif" t t } "VeraBI" }
+ { { "sans-serif" f t } "VeraIt" }
+ { { "serif" f f } "VeraSe" }
+ { { "serif" t f } "VeraSeBd" }
+ { { "serif" t t } "VeraBI" }
+ { { "serif" f t } "VeraIt" }
+ } at ;
+
+: ttf-path ( name -- string )
+ "resource:fonts/" ".ttf" surround ;
+
+: (open-face) ( path length -- face )
+ #! We use FT_New_Memory_Face, not FT_New_Face, since
+ #! FT_New_Face only takes an ASCII path name and causes
+ #! problems on localized versions of Windows
+ [ freetype ] 2dip 0 f <void*> [
+ FT_New_Memory_Face freetype-error
+ ] keep *void* ;
+
+: open-face ( font style -- face )
+ ttf-name ttf-path malloc-file-contents (open-face) ;
+
+SYMBOL: dpi
+
+72 dpi set-global
+
+: ft-floor ( m -- n ) -6 shift ; inline
+
+: ft-ceil ( m -- n ) 63 + -64 bitand -6 shift ; inline
+
+: font-units>pixels ( n font -- n )
+ face-size face-size-y-scale FT_MulFix ;
+
+: init-ascent ( font face -- font )
+ dup face-y-max swap font-units>pixels >>ascent ; inline
+
+: init-descent ( font face -- font )
+ dup face-y-min swap font-units>pixels >>descent ; inline
+
+: init-font ( font -- font )
+ dup handle>> init-ascent
+ dup handle>> init-descent
+ dup [ ascent>> ] [ descent>> ] bi - ft-ceil >>height ; inline
+
+: set-char-size ( open-font size -- open-font )
+ [ dup handle>> 0 ] dip
+ 6 shift dpi get-global dup FT_Set_Char_Size freetype-error ;
+
+: <freetype-font> ( font -- open-font )
+ freetype-font new
+ H{ } clone >>widths
+ over open-face >>handle
+ swap size>> set-char-size
+ init-font ;
+
+M: freetype-renderer open-font ( font -- open-font )
+ dup font? [
+ freetype drop open-fonts get [ <freetype-font> ] cache
+ ] unless ;
+
+: load-glyph ( font char -- glyph )
+ [ handle>> dup ] dip 0 FT_Load_Char
+ freetype-error face-glyph ;
+
+: char-width ( open-font char -- w )
+ over widths>> [
+ dupd load-glyph glyph-hori-advance ft-ceil
+ ] cache nip ;
+
+M: freetype-renderer string-width ( open-font string -- w )
+ [ 0 ] 2dip [ char-width + ] with each ;
+
+M: freetype-renderer string-height ( open-font string -- h )
+ drop height>> ;
+
+: glyph-size ( glyph -- dim )
+ [ glyph-hori-advance ft-ceil ]
+ [ glyph-height ft-ceil ]
+ bi 2array ;
+
+: render-glyph ( font char -- bitmap )
+ load-glyph dup
+ FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ;
+
+:: copy-pixel ( i j bitmap texture -- i j )
+ 255 j texture set-nth
+ i bitmap nth j 1 + texture set-nth
+ i 1 + j 2 + ; inline
+
+:: (copy-row) ( i j bitmap texture end -- )
+ i end < [
+ i j bitmap texture copy-pixel
+ bitmap texture end (copy-row)
+ ] when ; inline recursive
+
+:: copy-row ( i j bitmap texture width width2 -- i j )
+ i j bitmap texture i width + (copy-row)
+ i width +
+ j width2 + ; inline
+
+:: copy-bitmap ( glyph texture -- )
+ [let* | bitmap [ glyph glyph-bitmap-buffer ]
+ rows [ glyph glyph-bitmap-rows ]
+ width [ glyph glyph-bitmap-width ]
+ width2 [ width next-power-of-2 2 * ] |
+ bitmap [
+ bitmap rows width * <direct-uchar-array> :> bitmap'
+ 0 0
+ rows [ bitmap' texture width width2 copy-row ] times
+ 2drop
+ ] when
+ ] ;
+
+: bitmap>texture ( glyph sprite -- id )
+ tuck dim2>> product 2 * <byte-array>
+ [ copy-bitmap ] keep [ dim2>> ] dip
+ GL_LUMINANCE_ALPHA make-texture ;
+
+: glyph-texture-loc ( glyph font -- loc )
+ [ drop glyph-hori-bearing-x ft-floor ]
+ [ ascent>> swap glyph-hori-bearing-y - ft-floor ]
+ 2bi 2array ;
+
+: glyph-texture-size ( glyph -- dim )
+ [ glyph-bitmap-width next-power-of-2 ]
+ [ glyph-bitmap-rows next-power-of-2 ]
+ bi 2array ;
+
+: <char-sprite> ( open-font char -- sprite )
+ over [ render-glyph dup ] dip glyph-texture-loc
+ over glyph-size pick glyph-texture-size <sprite>
+ [ bitmap>texture ] keep [ init-sprite ] keep ;
+
+:: char-sprite ( open-font sprites char -- sprite )
+ char sprites [ open-font swap <char-sprite> ] cache ;
+
+: draw-char ( open-font sprites char loc -- )
+ GL_MODELVIEW [
+ 0 0 glTranslated
+ char-sprite dlist>> glCallList
+ ] do-matrix ;
+
+: char-widths ( open-font string -- widths )
+ [ char-width ] with { } map-as ;
+
+: scan-sums ( seq -- seq' )
+ 0 [ + ] accumulate nip ;
+
+:: (draw-string) ( open-font sprites string loc -- )
+ GL_TEXTURE_2D [
+ loc [
+ string open-font string char-widths scan-sums [
+ [ open-font sprites ] 2dip draw-char
+ ] 2each
+ ] with-translation
+ ] do-enabled ;
+
+: font-sprites ( font world -- open-font sprites )
+ fonts>> [ open-font H{ } clone 2array ] cache first2 ;
+
+M: freetype-renderer draw-string ( font string loc -- )
+ [ world get font-sprites ] 2dip (draw-string) ;
+
+: run-char-widths ( open-font string -- widths )
+ char-widths [ scan-sums ] [ 2 v/n ] bi v+ ;
+
+M: freetype-renderer x>offset ( x font string -- n )
+ [ open-font ] dip
+ [ run-char-widths [ <= ] with find drop ] keep swap
+ [ ] [ length ] ?if ;
+
+M:: freetype-renderer offset>x ( n font string -- x )
+ font open-font string n head string-width ;
+
+freetype-renderer font-renderer set-global
--- /dev/null
+UI text rendering implementation using FreeType
--- /dev/null
+unportable
USING: help.markup help.syntax kernel ui.text.private strings math ;
HELP: open-font
-{ $values { "font" "a font specifier" } { "open-font" object } }
+{ $values { "font" font } { "open-font" object } }
{ $contract "Loads a font if it has not already been loaded, otherwise outputs the existing font." }
{ $errors "Throws an error if the font does not exist." }
{ $notes "This word should not be called by user code. All high-level text rendering words will call " { $link open-font } " automatically." } ;
{ $notes "This is a low-level word; use " { $link text-width } " instead." } ;
HELP: text-width
-{ $values { "font" "a font specifier" } { "text" "a string or sequence of strings" } { "w" "a positive integer" } }
+{ $values { "font" font } { "text" "a string or sequence of strings" } { "w" "a positive integer" } }
{ $description "Outputs the width of a piece of text." } ;
HELP: string-height
{ $notes "This is a low-level word; use " { $link text-height } " instead." } ;
HELP: text-height
-{ $values { "font" "a font specifier" } { "text" "a string or sequence of strings" } { "h" "a positive integer" } }
+{ $values { "font" font } { "text" "a string or sequence of strings" } { "h" "a positive integer" } }
{ $description "Outputs the height of a piece of text." } ;
HELP: string-dim
{ $notes "This is a low-level word; use " { $link text-dim } " instead." } ;
HELP: text-dim
-{ $values { "font" "a font specifier" } { "text" "a string or sequence of strings" } { "dim" "a pair of integers" } }
+{ $values { "font" font } { "text" "a string or sequence of strings" } { "dim" "a pair of integers" } }
{ $description "Outputs the dimensions of a piece of text, which is either a single-line string or an array of lines." } ;
HELP: draw-string
-{ $values { "font" "a font specifier" } { "string" string } { "loc" "a pair of integers" } }
+{ $values { "font" font } { "string" string } { "loc" "a pair of integers" } }
{ $contract "Draws a line of text." } ;
HELP: draw-text
-{ $values { "font" "a font specifier" } { "text" "a string or an array of strings" } { "loc" "a pair of integers" } }
+{ $values { "font" font } { "text" "a string or an array of strings" } { "loc" "a pair of integers" } }
{ $description "Draws a piece of text." } ;
HELP: x>offset
-{ $values { "x" real } { "font" "a font specifier" } { "string" string } { "n" integer } }
+{ $values { "x" real } { "font" font } { "string" string } { "n" integer } }
{ $contract "Outputs the string index closest to the given x co-ordinate." } ;
HELP: offset>x
-{ $values { "n" integer } { "font" "a font specifier" } { "string" string } { "x" real } }
+{ $values { "n" integer } { "font" font } { "string" string } { "x" real } }
{ $contract "Outputs the x co-ordinate of the character at the given index." } ;
ARTICLE: "text-rendering" "Rendering text"
USING: kernel arrays sequences math math.order opengl opengl.gl strings ;
IN: ui.text
+TUPLE: font name size bold? italic? ;
+
<PRIVATE
SYMBOL: font-renderer
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors documents io.styles kernel math math.order
+USING: accessors documents kernel math math.order
sequences fry ;
IN: ui.tools.listener.history
USING: help.markup help.syntax strings quotations debugger
-io.styles namespaces ui.backend ui.gadgets ui.gadgets.worlds
-ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids math.geometry.rect colors ;
+namespaces ui.backend ui.gadgets ui.gadgets.worlds
+ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids
+math.geometry.rect colors ;
IN: ui
HELP: windows
{ $table
{ "color" { "an instance of " { $link color } } }
{ "dimension" "a pair of integers denoting pixel size on screen" }
- { "font specifier"
- { "an array of three elements:"
- { $list
- { "font family - one of " { $snippet "serif" } ", " { $snippet "sans-serif" } " or " { $snippet "monospace" } }
- { "font style - one of " { $link plain } ", " { $link bold } ", " { $link italic } " or " { $link bold-italic } }
- "font size in points"
- }
- }
- }
+ { "font" { "an instance of " { link font } } }
{ "gadget" { "a graphical element which responds to user input. Gadgets are tuples which (directly or indirectly) inherit from " { $link gadget } "." } }
{ "label specifier" { "a string, " { $link f } " or a gadget. See " { $link "ui.gadgets.buttons" } } }
{ "orientation specifier" { "one of " { $snippet "{ 0 1 }" } " or " { $snippet "{ 1 0 }" } ", with the former denoting vertical orientation and the latter denoting horizontal. Using a vector instead of symbolic constants allows these values to be directly useful in co-ordinate calculations" } }
+++ /dev/null
-Doug Coleman
+++ /dev/null
-unportable
+++ /dev/null
-! 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 ui.freetype 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.geometry.rect math.order ascii calendar
-io.encodings.utf16n ;
-IN: ui.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) ;
-
-: wm-keydown-codes ( -- key )
- 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
- H{
- { 16 "SHIFT" }
- { 17 "CTRL" }
- { 18 "ALT" }
- { 20 "CAPS-LOCK" }
- } ;
-
-: exclude-keys-wm-char
- ! Values are ignored
- 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 ] [ rect-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
-Slava Pestov
+++ /dev/null
-unportable
+++ /dev/null
-! 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 ui.freetype 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.geometry.rect
-environment ascii ;
-IN: ui.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 ;
-
-: modifiers
- {
- { S+ HEX: 1 }
- { C+ HEX: 4 }
- { A+ HEX: 8 }
- } ;
-
-: 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 <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 )
- dup event-modifiers swap 0 XLookupKeysym key-code <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 contains? ;
-
-: 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 -- )
- dup xic>> XDestroyIC
- dup glx>> destroy-glx
- window>> dup unregister-window
- destroy-window ;
-
-M: world client-event
- swap close-box? [ ungraft ] [ drop ] if ;
-
-: gadget-window ( world -- )
- dup window-loc>> over rect-dim glx-window
- over "Factor" create-xic rot <x11-handle>
- 2dup window>> register-window
- >>handle drop ;
-
-: wait-event ( -- event )
- QueuedAfterFlush events-queued 0 > [
- next-event dup
- None XFilterEvent zero? [ 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
projects / factor.git / commitdiff