steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://repo.or.cz/factor/jcg

db4
Slava Pestov 2008-12-11 23:33:16 -06:00
parent e9d80dcb63 b7bad6b2bb
commit 07ff3a4441
23 changed files with 437 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
basis/cocoa/views/views.factor
View File

@ -55,10 +55,9 @@ PRIVATE>
: with-multisample ( quot -- )
t +multisample+ pick with-variable ; inline
: <PixelFormat> ( -- pixelfmt )
NSOpenGLPixelFormat -> alloc [
NSOpenGLPFAWindow ,
NSOpenGLPFADoubleBuffer ,
: <PixelFormat> ( attributes -- pixelfmt )
NSOpenGLPixelFormat -> alloc swap [
%
NSOpenGLPFADepthSize , 16 ,
+software-renderer+ get [
NSOpenGLPFARendererID , kCGLRendererGenericFloatID ,
@ -74,7 +73,8 @@ PRIVATE>
-> autorelease ;
: <GLView> ( class dim -- view )
[ -> alloc 0 0 ] dip first2 <NSRect> <PixelFormat>
[ -> alloc 0 0 ] dip first2 <NSRect>
NSOpenGLPFAWindow NSOpenGLPFADoubleBuffer 2array <PixelFormat>
-> initWithFrame:pixelFormat:
dup 1 -> setPostsBoundsChangedNotifications:
dup 1 -> setPostsFrameChangedNotifications: ;

10
basis/ui/backend/backend.factor Normal file → Executable file
View File

@ -17,11 +17,17 @@ HOOK: (open-window) ui-backend ( world -- )
HOOK: (close-window) ui-backend ( handle -- )
HOOK: (open-offscreen-buffer) ui-backend ( world -- )
HOOK: (close-offscreen-buffer) ui-backend ( handle -- )
HOOK: raise-window* ui-backend ( world -- )
HOOK: select-gl-context ui-backend ( handle -- )
GENERIC: select-gl-context ( handle -- )
HOOK: flush-gl-context ui-backend ( handle -- )
GENERIC: flush-gl-context ( handle -- )
HOOK: offscreen-pixels ui-backend ( world -- alien w h )
HOOK: beep ui-backend ( -- )

54
basis/ui/cocoa/cocoa.factor Normal file → Executable file
View File

@ -3,15 +3,18 @@
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.nibs 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
@ -39,7 +42,8 @@ M: pasteboard set-clipboard-contents
: 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 -- )
@ -88,11 +92,39 @@ M: cocoa-ui-backend raise-window* ( 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: cocoa-ui-backend offscreen-pixels ( world -- alien w h )
[ handle>> buffer>> ] [ dim>> first2 neg ] bi ;
M: cocoa-ui-backend beep ( -- )
NSBeep ;

7
basis/ui/gadgets/worlds/worlds.factor
View File

@ -38,8 +38,8 @@ M: world request-focus-on ( child 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
@ -49,6 +49,9 @@ M: world request-focus-on ( child gadget -- )
swap 1 track-add
dup request-focus ;
: <world> ( gadget title status -- world )
world new-world ;
M: world layout*
dup call-next-method
dup glass>> [

25
basis/ui/ui.factor
View File

@ -60,23 +60,26 @@ SYMBOL: stop-after-last-window?
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

75
basis/ui/windows/windows.factor
View File

@ -6,7 +6,7 @@ ui.gadgets ui.backend ui.clipboards ui.gadgets.worlds
ui.gestures 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
windows.nt windows threads libc combinators fry
combinators.short-circuit continuations command-line shuffle
opengl ui.render ascii math.bitwise locals symbols accessors
math.geometry.rect math.order ascii calendar
@ -70,9 +70,11 @@ M: pasteboard set-clipboard-contents drop copy ;
<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 < 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 ;
@ -479,8 +481,8 @@ M: windows-ui-backend do-events
f class-name-ptr set-global
f msg-obj set-global ;
: setup-pixel-format ( hdc -- )
16 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep
: 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 ;
@ -490,22 +492,73 @@ M: windows-ui-backend do-events
[ 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
[ create-window [ setup-gl ] keep ] keep
[ f <win> ] keep
[ swap hWnd>> register-window ] 2keep
dupd (>>handle)
hWnd>> show-window ;
M: windows-ui-backend select-gl-context ( handle -- )
[ hDC>> ] keep hRC>> wglMakeCurrent win32-error=0/f ;
M: win-base select-gl-context ( handle -- )
[ hDC>> ] keep hRC>> wglMakeCurrent win32-error=0/f
GdiFlush drop ;
M: windows-ui-backend flush-gl-context ( handle -- )
M: win-base flush-gl-context ( handle -- )
hDC>> SwapBuffers win32-error=0/f ;
! Move window to front
: (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

32
basis/ui/x11/x11.factor
View File

@ -14,9 +14,12 @@ SINGLETON: x11-ui-backend
: XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ;
TUPLE: x11-handle window glx xic ;
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 ;
@ -184,7 +187,7 @@ M: world client-event
: gadget-window ( world -- )
dup window-loc>> over rect-dim glx-window
over "Factor" create-xic <x11-handle>
over "Factor" create-xic rot <x11-handle>
2dup window>> register-window
>>handle drop ;
@ -247,14 +250,33 @@ M: x11-ui-backend raise-window* ( world -- )
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
[ window>> ] [ glx>> ] bi 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-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 ui ( -- )
[
f [

18
basis/windows/gdi32/gdi32.factor Normal file → Executable file
View File

@ -26,6 +26,14 @@ IN: windows.gdi32
: DC_BRUSH 18 ; inline
: DC_PEN 19 ; inline
: BI_RGB 0 ; inline
: BI_RLE8 1 ; inline
: BI_RLE4 2 ; inline
: BI_BITFIELDS 3 ; inline
: DIB_RGB_COLORS 0 ; inline
: DIB_PAL_COLORS 1 ; inline
LIBRARY: gdi32
! FUNCTION: AbortPath
@ -75,13 +83,13 @@ FUNCTION: int ChoosePixelFormat ( HDC hDC, PFD* ppfd ) ;
! FUNCTION: CreateColorSpaceA
! FUNCTION: CreateColorSpaceW
! FUNCTION: CreateCompatibleBitmap
! FUNCTION: CreateCompatibleDC
FUNCTION: HDC CreateCompatibleDC ( HDC hdc ) ;
! FUNCTION: CreateDCA
! FUNCTION: CreateDCW
! FUNCTION: CreateDIBitmap
! FUNCTION: CreateDIBPatternBrush
! FUNCTION: CreateDIBPatternBrushPt
! FUNCTION: CreateDIBSection
FUNCTION: HBITMAP CreateDIBSection ( HDC hdc, BITMAPINFO* pbmi, UINT iUsage, void** ppvBits, HANDLE hSection, DWORD dwOffset ) ;
! FUNCTION: CreateDiscardableBitmap
! FUNCTION: CreateEllipticRgn
! FUNCTION: CreateEllipticRgnIndirect
@ -169,7 +177,7 @@ FUNCTION: HRGN CreateRectRgn ( int x, int y, int w, int h ) ;
! FUNCTION: DdEntry8
! FUNCTION: DdEntry9
! FUNCTION: DeleteColorSpace
! FUNCTION: DeleteDC
FUNCTION: BOOL DeleteDC ( HDC hdc ) ;
! FUNCTION: DeleteEnhMetaFile
! FUNCTION: DeleteMetaFile
FUNCTION: BOOL DeleteObject ( HGDIOBJ hObject ) ;
@ -313,7 +321,7 @@ FUNCTION: BOOL DeleteObject ( HGDIOBJ hObject ) ;
! FUNCTION: GdiEntry8
! FUNCTION: GdiEntry9
! FUNCTION: GdiFixUpHandle
! FUNCTION: GdiFlush
FUNCTION: BOOL GdiFlush ( ) ;
! FUNCTION: GdiFullscreenControl
! FUNCTION: GdiGetBatchLimit
! FUNCTION: GdiGetCharDimensions
@ -552,7 +560,7 @@ FUNCTION: HGDIOBJ GetStockObject ( int fnObject ) ;
! FUNCTION: SelectClipPath
FUNCTION: int SelectClipRgn ( HDC hDC, HRGN hrgn ) ;
! FUNCTION: SelectFontLocal
! FUNCTION: SelectObject
FUNCTION: HGDIOBJ SelectObject ( HDC hdc, HGDIOBJ hgdiobj ) ;
! FUNCTION: SelectPalette
! FUNCTION: SetAbortProc
! FUNCTION: SetArcDirection

8
basis/windows/opengl32/opengl32.factor Normal file → Executable file
View File

@ -71,15 +71,17 @@ IN: windows.opengl32
: WGL_SWAP_UNDERLAY14 HEX: 20000000 ; inline
: WGL_SWAP_UNDERLAY15 HEX: 40000000 ; inline
: pfd-dwFlags ( -- n )
: windowed-pfd-dwFlags ( -- n )
{ PFD_DRAW_TO_WINDOW PFD_SUPPORT_OPENGL PFD_DOUBLEBUFFER } flags ;
: offscreen-pfd-dwFlags ( -- n )
{ PFD_DRAW_TO_BITMAP PFD_SUPPORT_OPENGL } flags ;
! TODO: compare to http://www.nullterminator.net/opengl32.html
: make-pfd ( bits -- pfd )
: make-pfd ( flags bits -- pfd )
"PIXELFORMATDESCRIPTOR" <c-object>
"PIXELFORMATDESCRIPTOR" heap-size over set-PIXELFORMATDESCRIPTOR-nSize
1 over set-PIXELFORMATDESCRIPTOR-nVersion
pfd-dwFlags over set-PIXELFORMATDESCRIPTOR-dwFlags
rot over set-PIXELFORMATDESCRIPTOR-dwFlags
PFD_TYPE_RGBA over set-PIXELFORMATDESCRIPTOR-iPixelType
[ set-PIXELFORMATDESCRIPTOR-cColorBits ] keep
16 over set-PIXELFORMATDESCRIPTOR-cDepthBits

23
basis/windows/types/types.factor Normal file → Executable file
View File

@ -253,6 +253,29 @@ C-STRUCT: RECT
! { "BYTE[32]" "rgbReserved" }
! ;
C-STRUCT: BITMAPINFOHEADER
{ "DWORD" "biSize" }
{ "LONG" "biWidth" }
{ "LONG" "biHeight" }
{ "WORD" "biPlanes" }
{ "WORD" "biBitCount" }
{ "DWORD" "biCompression" }
{ "DWORD" "biSizeImage" }
{ "LONG" "biXPelsPerMeter" }
{ "LONG" "biYPelsPerMeter" }
{ "DWORD" "biClrUsed" }
{ "DWORD" "biClrImportant" } ;
C-STRUCT: RGBQUAD
{ "BYTE" "rgbBlue" }
{ "BYTE" "rgbGreen" }
{ "BYTE" "rgbRed" }
{ "BYTE" "rgbReserved" } ;
C-STRUCT: BITMAPINFO
{ "BITMAPINFOHEADER" "bmiHeader" }
{ "RGBQUAD[1]" "bmiColors" } ;
TYPEDEF: void* LPPAINTSTRUCT
TYPEDEF: void* PAINTSTRUCT

12
basis/x11/glx/glx.factor
View File

@ -84,13 +84,13 @@ FUNCTION: void* glXGetProcAddress ( char* procname ) ;
FUNCTION: void* glXGetProcAddressARB ( char* procname ) ;
! GLX Events
! (also skipped for now. only has GLXPbufferClobberEvent, the rest is handled by xlib methinks
! (also skipped for now. only has GLXPbufferClobberEvent, the rest is handled by xlib methinks)
: choose-visual ( -- XVisualInfo* )
dpy get scr get
: choose-visual ( flags -- XVisualInfo* )
[ dpy get scr get ] dip
[
%
GLX_RGBA ,
GLX_DOUBLEBUFFER ,
GLX_DEPTH_SIZE , 16 ,
0 ,
] int-array{ } make underlying>>
@ -98,8 +98,8 @@ FUNCTION: void* glXGetProcAddressARB ( char* procname ) ;
[ "Could not get a double-buffered GLX RGBA visual" throw ] unless* ;
: create-glx ( XVisualInfo* -- GLXContext )
>r dpy get r> f 1 glXCreateContext
[ dpy get ] dip f 1 glXCreateContext
[ "Failed to create GLX context" throw ] unless* ;
: destroy-glx ( GLXContext -- )
dpy get swap glXDestroyContext ;
dpy get swap glXDestroyContext ;

28
basis/x11/windows/windows.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types hashtables kernel math math.vectors
math.bitwise namespaces sequences x11.xlib x11.constants x11.glx ;
math.bitwise namespaces sequences x11.xlib x11.constants x11.glx
arrays fry ;
IN: x11.windows
: create-window-mask ( -- n )
@ -50,11 +51,30 @@ IN: x11.windows
dup r> auto-position ;
: glx-window ( loc dim -- window glx )
choose-visual
GLX_DOUBLEBUFFER 1array choose-visual
[ create-window ] keep
[ create-glx ] keep
XFree ;
: create-pixmap ( dim visual -- pixmap )
[ [ { 0 0 } swap ] dip create-window ] [
drop [ dpy get ] 2dip first2 24 XCreatePixmap
[ "Failed to create offscreen pixmap" throw ] unless*
] 2bi ;
: (create-glx-pixmap) ( pixmap visual -- pixmap glx-pixmap )
[ drop ] [
[ dpy get ] 2dip swap glXCreateGLXPixmap
[ "Failed to create offscreen GLXPixmap" throw ] unless*
] 2bi ;
: create-glx-pixmap ( dim visual -- pixmap glx-pixmap )
[ create-pixmap ] [ (create-glx-pixmap) ] bi ;
: glx-pixmap ( dim -- glx pixmap glx-pixmap )
{ } choose-visual
[ nip create-glx ] [ create-glx-pixmap ] [ nip XFree ] 2tri ;
: destroy-window ( win -- )
dpy get swap XDestroyWindow drop ;
@ -65,3 +85,7 @@ IN: x11.windows
: map-window ( win -- ) dpy get swap XMapWindow drop ;
: unmap-window ( win -- ) dpy get swap XUnmapWindow drop ;
: pixmap-bits ( dim pixmap -- alien )
swap first2 '[ dpy get _ 0 0 _ _ AllPlanes ZPixmap XGetImage ] call
[ XImage-pixels ] [ XDestroyImage drop ] bi ;

54
basis/x11/xlib/xlib.factor
View File

@ -272,6 +272,17 @@ FUNCTION: Window XGetSelectionOwner ( Display* display, Atom selection ) ;
FUNCTION: int XConvertSelection ( Display* display, Atom selection, Atom target, Atom property, Window requestor, Time time ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 5 - Pixmap and Cursor Functions
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 5.1 - Creating and Freeing Pixmaps
FUNCTION: Pixmap XCreatePixmap ( Display* display, Drawable d, uint width, uint height, uint depth ) ;
FUNCTION: int XFreePixmap ( Display* display, Pixmap pixmap ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 6 - Color Management Functions
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -429,6 +440,49 @@ FUNCTION: Status XDrawString (
char* string,
int length ) ;
! 8.7 - Transferring Images between Client and Server
: XYBitmap 0 ; inline
: XYPixmap 1 ; inline
: ZPixmap 2 ; inline
: AllPlanes -1 ; inline
C-STRUCT: XImage-funcs
{ "void*" "create_image" }
{ "void*" "destroy_image" }
{ "void*" "get_pixel" }
{ "void*" "put_pixel" }
{ "void*" "sub_image" }
{ "void*" "add_pixel" } ;
C-STRUCT: XImage
{ "int" "width" }
{ "int" "height" }
{ "int" "xoffset" }
{ "int" "format" }
{ "char*" "data" }
{ "int" "byte_order" }
{ "int" "bitmap_unit" }
{ "int" "bitmap_bit_order" }
{ "int" "bitmap_pad" }
{ "int" "depth" }
{ "int" "bytes_per_line" }
{ "int" "bits_per_pixel" }
{ "ulong" "red_mask" }
{ "ulong" "green_mask" }
{ "ulong" "blue_mask" }
{ "XPointer" "obdata" }
{ "XImage-funcs" "f" } ;
FUNCTION: XImage* XGetImage ( Display* display, Drawable d, int x, int y, uint width, uint height, ulong plane_mask, int format ) ;
FUNCTION: int XDestroyImage ( XImage *ximage ) ;
: XImage-size ( ximage -- size )
[ XImage-height ] [ XImage-bytes_per_line ] bi * ;
: XImage-pixels ( ximage -- byte-array )
[ XImage-data ] [ XImage-size ] bi memory>byte-array ;
!
! 9 - Window and Session Manager Functions
!

31
extra/graphics/bitmap/bitmap.factor
View File

@ -4,24 +4,35 @@
USING: alien arrays byte-arrays combinators summary io.backend
graphics.viewer io io.binary io.files kernel libc math
math.functions math.bitwise namespaces opengl opengl.gl
prettyprint sequences strings ui ui.gadgets.panes
io.encodings.binary accessors grouping ;
prettyprint sequences strings ui ui.gadgets.panes fry
io.encodings.binary accessors grouping macros alien.c-types ;
IN: graphics.bitmap
! Currently can only handle 24bit bitmaps.
! Currently can only handle 24/32bit bitmaps.
! Handles row-reversed bitmaps (their height is negative)
TUPLE: bitmap magic size reserved offset header-length width
height planes bit-count compression size-image
x-pels y-pels color-used color-important rgb-quads color-index array ;
: (array-copy) ( bitmap array -- bitmap array' )
over size-image>> abs memory>byte-array ;
MACRO: (nbits>bitmap) ( bits -- )
[ -3 shift ] keep '[
bitmap new
2over * _ * >>size-image
swap >>height
swap >>width
swap (array-copy) [ >>array ] [ >>color-index ] bi
_ >>bit-count
] ;
: bgr>bitmap ( array height width -- bitmap )
bitmap new
2over * 3 * >>size-image
swap >>height
swap >>width
swap [ >>array ] [ >>color-index ] bi
24 >>bit-count ;
24 (nbits>bitmap) ;
: bgra>bitmap ( array height width -- bitmap )
32 (nbits>bitmap) ;
: 8bit>array ( bitmap -- array )
[ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
@ -124,7 +135,7 @@ M: bitmap draw-image ( bitmap -- )
[
[ height>> abs ] keep
bit-count>> {
! { 32 [ GL_BGRA GL_UNSIGNED_INT_8_8_8_8 ] } ! broken
{ 32 [ GL_BGRA GL_UNSIGNED_BYTE ] }
{ 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
{ 8 [ GL_BGR GL_UNSIGNED_BYTE ] }
{ 4 [ GL_BGR GL_UNSIGNED_BYTE ] }

2
extra/key-caps/key-caps.factor
View File

@ -139,7 +139,7 @@ TUPLE: key-caps-gadget < gadget keys alarm ;
: make-key-gadget ( scancode dim array -- )
[
swap [
" " [ ] <bevel-button>
" " [ drop ] <bevel-button>
swap [ first >>loc ] [ second >>dim ] bi
] [ execute ] bi*
] dip set-nth ;

12
extra/literals/literals-tests.factor Normal file
View File

@ -0,0 +1,12 @@
USING: kernel literals tools.test ;
IN: literals.tests
<<
: five 5 ;
: seven-eleven 7 11 ;
: six-six-six 6 6 6 ;
>>
[ { 5 } ] [ { $ five } ] unit-test
[ { 7 11 } ] [ { $ seven-eleven } ] unit-test
[ { 6 6 6 } ] [ { $ six-six-six } ] unit-test

4
extra/literals/literals.factor Normal file
View File

@ -0,0 +1,4 @@
USING: continuations kernel parser words ;
IN: literals
: $ scan-word [ execute ] curry with-datastack ; parsing

1
extra/ui/offscreen/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

63
extra/ui/offscreen/offscreen-docs.factor Normal file
View File

@ -0,0 +1,63 @@
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel quotations ui.gadgets
graphics.bitmap strings ui.gadgets.worlds ;
IN: ui.offscreen
HELP: <offscreen-world>
{ $values
{ "gadget" gadget } { "title" string } { "status" "a boolean" }
{ "world" offscreen-world }
}
{ $description "Constructs an " { $link offscreen-world } " gadget with " { $snippet "gadget" } " as its only child. Generally you should use " { $link open-offscreen } " or " { $link do-offscreen } " instead of calling this word directly." } ;
HELP: close-offscreen
{ $values
{ "world" offscreen-world }
}
{ $description "Releases the resources used by the rendering buffer for " { $snippet "world" } "." } ;
HELP: do-offscreen
{ $values
{ "gadget" gadget } { "quot" quotation }
}
{ $description "Constructs an " { $link offscreen-world } " around " { $snippet "gadget" } " with " { $link open-offscreen } ", calls " { $snippet "quotation" } " with the world on the top of the stack, and cleans up the world with " { $link close-offscreen } " at the end of " { $snippet "quotation" } "." } ;
HELP: gadget>bitmap
{ $values
{ "gadget" gadget }
{ "bitmap" bitmap }
}
{ $description "Renders " { $snippet "gadget" } " to an " { $link offscreen-world } " and creates a " { $link bitmap } " from its contents." } ;
HELP: offscreen-world
{ $class-description "The class of " { $link world } " objects that render to an offscreen buffer." } ;
HELP: offscreen-world>bitmap
{ $values
{ "world" offscreen-world }
{ "bitmap" bitmap }
}
{ $description "Saves a copy of the contents of " { $snippet "world" } " to a " { $link bitmap } " object." } ;
HELP: open-offscreen
{ $values
{ "gadget" gadget }
{ "world" offscreen-world }
}
{ $description "Creates and sets up an " { $link offscreen-world } " with " { $snippet "gadget" } " as its only child." } ;
{ offscreen-world open-offscreen close-offscreen do-offscreen } related-words
ARTICLE: "ui.offscreen" "Offscreen UI rendering"
"The " { $vocab-link "ui.offscreen" } " provides words for rendering gadgets to an offscreen buffer so that bitmaps can be made from their contents."
{ $subsection offscreen-world }
"Opening gadgets offscreen:"
{ $subsection open-offscreen }
{ $subsection close-offscreen }
{ $subsection do-offscreen }
"Creating bitmaps from offscreen buffers:"
{ $subsection offscreen-world>bitmap }
{ $subsection gadget>bitmap } ;
ABOUT: "ui.offscreen"

37
extra/ui/offscreen/offscreen.factor Executable file
View File

@ -0,0 +1,37 @@
USING: accessors continuations graphics.bitmap kernel math
sequences ui.gadgets ui.gadgets.worlds ui ui.backend
destructors ;
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 dup relayout-1 ] keep
notify-queued ;
: close-offscreen ( world -- )
ungraft notify-queued ;
M: offscreen-world dispose close-offscreen ;
: offscreen-world>bitmap ( world -- bitmap )
offscreen-pixels bgra>bitmap ;
: do-offscreen ( gadget quot: ( offscreen-world -- ) -- )
[ open-offscreen ] dip
over [ slip ] [ close-offscreen ] [ ] cleanup ; inline
: gadget>bitmap ( gadget -- bitmap )
[ offscreen-world>bitmap ] do-offscreen ;

1
extra/ui/offscreen/summary.txt Normal file
View File

@ -0,0 +1 @@
Offscreen world gadgets for rendering UI elements to bitmaps

3
extra/ui/offscreen/tags.txt Normal file
View File

@ -0,0 +1,3 @@
unportable
ui
graphics

2
vm/Config.macosx
View File

@ -6,7 +6,7 @@ PLAF_DLL_OBJS += vm/os-macosx.o vm/mach_signal.o
DLL_EXTENSION = .dylib
ifdef X11
LIBS = -lm -framework Foundation $(X11_UI_LIBS) -Wl,-dylib_file,/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib:/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib
LIBS = -lm -framework Cocoa $(X11_UI_LIBS) -Wl,-dylib_file,/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib:/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib
else
LIBS = -lm -framework Cocoa -framework AppKit
endif