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.application cocoa.nibs
- sequences system ui ui.backend ui.clipboards ui.gadgets
- ui.gadgets.worlds ui.cocoa.views core-foundation threads
- math.geometry.rect fry ;
-cocoa.windows cocoa.classes cocoa.application sequences system
++cocoa.windows cocoa.classes sequences system
+ ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
+ ui.cocoa.views core-foundation threads math.geometry.rect fry
+ libc generalizations alien.c-types cocoa.views combinators ;
IN: ui.cocoa
- TUPLE: handle view window ;
+ TUPLE: handle ;
+ TUPLE: window-handle < handle view window ;
+ TUPLE: offscreen-handle < handle context buffer ;
- C: <handle> handle
+ C: <window-handle> window-handle
+ C: <offscreen-handle> offscreen-handle
SINGLETON: cocoa-ui-backend
: gadget-window ( world -- )
dup <FactorView>
2dup swap world>NSRect <ViewWindow>
- [ [ -> release ] [ install-window-delegate ] bi* ] [ <handle> ] 2bi
+ [ [ -> release ] [ install-window-delegate ] bi* ]
+ [ <window-handle> ] 2bi
>>handle drop ;
M: cocoa-ui-backend set-title ( string world -- )
NSApp 1 -> activateIgnoringOtherApps:
] when* ;
- M: cocoa-ui-backend select-gl-context ( handle -- )
- view>> -> openGLContext -> makeCurrentContext ;
+ : pixel-size ( pixel-format -- size )
+ 0 <int> [ NSOpenGLPFAColorSize 0 -> getValues:forAttribute:forVirtualScreen: ]
+ keep *int -3 shift ;
- M: cocoa-ui-backend flush-gl-context ( handle -- )
- view>> -> openGLContext -> flushBuffer ;
+ : 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: offscreen-handle offscreen-pixels ( handle -- alien )
+ buffer>> ;
M: cocoa-ui-backend beep ( -- )
NSBeep ;
SYMBOL: cocoa-init-hook
-cocoa-init-hook global [ [ install-app-delegate ] or ] change-at
+cocoa-init-hook global [
+ [ "MiniFactor.nib" load-nib install-app-delegate ] or
+] change-at
M: cocoa-ui-backend ui
"UI" assert.app [
USING: accessors arrays assocs continuations kernel math models
namespaces opengl sequences io combinators fry math.vectors
ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
-debugger math.geometry.rect ;
+math.geometry.rect ;
IN: ui.gadgets.worlds
TUPLE: world < track
fonts handle
window-loc ;
+ TUPLE: offscreen-world < world ;
+
: find-world ( gadget -- world/f ) [ world? ] find-parent ;
: show-status ( string/f gadget -- )
2dup eq?
[ 2drop ] [ dup focused?>> (request-focus) ] if ;
- : <world> ( gadget title status -- world )
- { 0 1 } world new-track
+ : new-world ( gadget title status class -- world )
+ { 0 1 } swap new-track
t >>root?
t >>active?
H{ } clone >>fonts
swap 1 track-add
dup request-focus ;
+ : <world> ( gadget title status -- world )
+ world new-world ;
+ : <offscreen-world> ( gadget title status -- world )
+ offscreen-world new-world ;
+
M: world layout*
dup call-next-method
dup glass>> [
SYMBOL: ui-error-hook
: ui-error ( error -- )
- ui-error-hook get [ call ] [ print-error ] if* ;
+ ui-error-hook get [ call ] [ die ] if* ;
ui-error-hook global [ [ rethrow ] or ] change-at
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs io kernel math models namespaces make
-prettyprint dlists deques sequences threads sequences words
-debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
-ui.gestures ui.backend ui.render continuations init combinators
-hashtables concurrency.flags sets accessors calendar ;
+dlists deques sequences threads sequences words ui.gadgets
+ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend
+ui.render continuations init combinators hashtables
+concurrency.flags sets accessors calendar ;
IN: ui
! Assoc mapping aliens to gadgets
focus-path f swap focus-gestures ;
M: world graft*
- dup (open-window)
- dup title>> over set-title
- request-focus ;
+ [ (open-window) ]
+ [ [ title>> ] keep set-title ]
+ [ request-focus ] tri ;
: reset-world ( world -- )
#! This is used when a window is being closed, but also
#! when restoring saved worlds on image startup.
- dup fonts>> clear-assoc
- dup unfocus-world
- f >>handle drop ;
+ [ fonts>> clear-assoc ]
+ [ unfocus-world ]
+ [ f >>handle drop ] tri ;
+
+ : (ungraft-world) ( world -- )
+ [ free-fonts ]
+ [ hand-clicked close-global ]
+ [ hand-gadget close-global ] tri ;
M: world ungraft*
- dup free-fonts
- dup hand-clicked close-global
- dup hand-gadget close-global
- dup handle>> (close-window)
- reset-world ;
+ [ (ungraft-world) ]
+ [ handle>> (close-window) ]
+ [ reset-world ] tri ;
: find-window ( quot -- world )
windows get values
windows.nt windows threads libc combinators
combinators.short-circuit continuations command-line shuffle
opengl ui.render ascii math.bitwise locals symbols accessors
-math.geometry.rect math.order ascii calendar ;
+math.geometry.rect math.order ascii calendar
+io.encodings.utf16n ;
IN: ui.windows
SINGLETON: windows-ui-backend
<pasteboard> clipboard set-global
<clipboard> selection set-global ;
- ! world-handle is a <win>
- TUPLE: win hWnd hDC hRC world title ;
+ TUPLE: win-base hDC hRC ;
+ TUPLE: win hWnd < win-base 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 ;
f class-name-ptr set-global
f msg-obj set-global ;
- : setup-pixel-format ( hdc -- )
+ : setup-pixel-format ( hdc flags -- )
16 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep
swapd SetPixelFormat win32-error=0/f ;
[ wglMakeCurrent win32-error=0/f ] keep ;
: setup-gl ( hwnd -- hDC hRC )
- get-dc dup setup-pixel-format dup get-rc ;
+ get-dc dup windowed-pfd-dwFlags setup-pixel-format dup get-rc ;
M: windows-ui-backend (open-window) ( world -- )
[ create-window dup setup-gl ] keep
dupd (>>handle)
hWnd>> show-window ;
- M: windows-ui-backend select-gl-context ( handle -- )
+ M: win-base select-gl-context ( handle -- )
[ hDC>> ] keep hRC>> wglMakeCurrent win32-error=0/f ;
- M: windows-ui-backend flush-gl-context ( handle -- )
+ 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 swap 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
+ swap (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>> DeleteObject drop ]
+ [ hBitmap>> DeleteObject drop ] bi ;
+
+ M: win-offscreen offscreen-pixels ( handle -- alien )
+ bits>> ;
+
! Move window to front
M: windows-ui-backend raise-window* ( world -- )
handle>> [
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 debugger command-line qualified
+io.encodings.utf8 combinators command-line qualified
math.vectors classes.tuple opengl.gl threads math.geometry.rect
environment ascii ;
IN: ui.x11
dpy get swap window>> XRaiseWindow drop
] when* ;
- M: x11-ui-backend select-gl-context ( handle -- )
+ M: x11-handle select-gl-context ( handle -- )
dpy get swap
dup window>> swap glx>> glXMakeCurrent
[ "Failed to set current GLX context" throw ] unless ;
- M: x11-ui-backend flush-gl-context ( handle -- )
+ M: x11-handle flush-gl-context ( handle -- )
dpy get swap window>> glXSwapBuffers ;
M: x11-ui-backend ui ( -- )
--- /dev/null
-
+ USING: accessors continuations graphics.bitmap kernel math
+ sequences ui.gadgets ui.gadgets.worlds ui ui.backend ;
+ IN: ui.offscreen
+
+ TUPLE: offscreen-world < world ;
+
+ : <offscreen-world> ( gadget title status -- world )
+ offscreen-world new-world ;
+
+ M: offscreen-world graft*
+ (open-offscreen-buffer) ;
+
+ M: offscreen-world ungraft*
+ [ (ungraft-world) ]
+ [ handle>> (close-offscreen-buffer) ]
+ [ reset-world ] tri ;
+
+ : open-offscreen ( gadget -- world )
+ "" f <offscreen-world> [ open-world-window ] keep
+ notify-queued ;
+
+ : close-offscreen ( world -- )
+ ungraft notify-queued ;
+
+ : offscreen-world>bitmap ( world -- bitmap )
+ [ handle>> offscreen-pixels ] [ dim>> first2 neg ] bi
+ bgra>bitmap ;
++
+ : do-offscreen ( gadget quot: ( offscreen-world -- ) -- )
+ [ open-offscreen ] dip
+ over [ slip ] [ close-offscreen ] [ ] cleanup ;
projects / factor.git / commitdiff