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

Merge remote branch 'origin/native-image-loader' into gtk-image-loader

db4
Philipp Brüschweiler 2010-07-17 11:26:45 +02:00
parent 32952a6071 a4e71b2cad
commit d2530a4365
25 changed files with 2053 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
Raytrace.app/Contents/Info.plist Normal file
View File

@ -0,0 +1,18 @@
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
<plist version="1.0">
<dict>
<key>CFBundleExecutable</key>
<string>gpu.demos.raytrace</string>
<key>CFBundleIconFile</key>
<string>Icon.icns</string>
<key>CFBundleIdentifier</key>
<string>org.factor.gpu.demos.raytrace</string>
<key>CFBundleInfoDictionaryVersion</key>
<string>6.0</string>
<key>CFBundleName</key>
<string>Raytrace.app</string>
<key>CFBundlePackageType</key>
<string>APPL</string>
</dict>
</plist>

16
basis/alien/enums/enums-tests.factor
View File

@ -33,3 +33,19 @@ ENUM: instrument_t < ushort trombone trumpet ;
{ V{ { red 0 } { green 3 } { blue 4 } } }
[ color_t "c-type" word-prop members>> ] unit-test
ENUM: colores { rojo red } { verde green } { azul blue } { colorado rojo } ;
[ { 0 3 4 0 } ] [ { rojo verde azul colorado } [ enum>number ] map ] unit-test
SYMBOLS: couleurs rouge vert bleu jaune azure ;
<< couleurs int {
{ rouge red }
{ vert green }
{ bleu blue }
{ jaune 14 }
{ azure bleu }
} define-enum >>
[ { 0 3 4 14 4 } ] [ { rouge vert bleu jaune azure } [ enum>number ] map ] unit-test

19
basis/alien/enums/enums.factor
View File

@ -12,7 +12,7 @@ PRIVATE>
GENERIC: enum>number ( enum -- number ) foldable
M: integer enum>number ;
M: symbol enum>number "enum-value" word-prop ;
M: word enum>number "enum-value" word-prop ;
<PRIVATE
: enum-boxer ( members -- quot )
@ -29,16 +29,13 @@ M: enum-c-type c-type-unboxer-quot drop [ enum>number ] ;
M: enum-c-type c-type-setter
[ enum>number ] swap base-type>> c-type-setter '[ _ 2dip @ ] ;
: define-enum-value ( class value -- )
enum>number "enum-value" set-word-prop ;
<PRIVATE
: define-enum-value ( class value -- )
"enum-value" set-word-prop ;
: define-enum-members ( member-names -- )
[
[ first define-symbol ]
[ first2 define-enum-value ] bi
] each ;
[ first define-symbol ] each ;
: define-enum-constructor ( word -- )
[ name>> "<" ">" surround create-in ] keep
@ -46,10 +43,14 @@ M: enum-c-type c-type-setter
PRIVATE>
: define-enum ( word base-type members -- )
: (define-enum) ( word base-type members -- )
[ dup define-enum-constructor ] 2dip
dup define-enum-members
<enum-c-type> swap typedef ;
: define-enum ( word base-type members -- )
[ (define-enum) ]
[ [ first2 define-enum-value ] each ] bi ;
PREDICATE: enum-c-type-word < c-type-word
"c-type" word-prop enum-c-type? ;

8
basis/alien/parser/parser.factor
View File

@ -4,7 +4,7 @@ USING: accessors alien alien.c-types alien.libraries arrays
assocs classes combinators combinators.short-circuit
compiler.units effects grouping kernel parser sequences
splitting words fry locals lexer namespaces summary math
vocabs.parser words.constant ;
vocabs.parser words.constant alien.enums ;
IN: alien.parser
SYMBOL: current-library
@ -75,8 +75,12 @@ M: pointer return-type-name to>> return-type-name CHAR: * suffix ;
"*" ?head
[ [ <pointer> ] dip parse-pointers ] when ;
: define-enum-value ( class value -- )
enum>number "enum-value" set-word-prop ;
: next-enum-member ( members name value -- members value' )
[ 2array suffix! ] [ 1 + ] bi ;
[ define-enum-value ]
[ [ 2array suffix! ] [ enum>number 1 + ] bi ] 2bi ;
: parse-enum-name ( -- name )
scan (CREATE-C-TYPE) dup save-location ;

2
basis/alien/syntax/syntax.factor
View File

@ -29,7 +29,7 @@ SYNTAX: TYPEDEF:
scan-c-type CREATE-C-TYPE dup save-location typedef ;
SYNTAX: ENUM:
parse-enum define-enum ;
parse-enum (define-enum) ;
SYNTAX: C-TYPE:
void CREATE-C-TYPE typedef ;

2
basis/cocoa/cocoa.factor
View File

@ -43,7 +43,9 @@ SYNTAX: IMPORT: scan [ ] import-objc-class ;
"NSApplication"
"NSArray"
"NSAutoreleasePool"
"NSBitmapImageRep"
"NSBundle"
"NSColorSpace"
"NSData"
"NSDictionary"
"NSError"

2
basis/cocoa/messages/messages.factor
View File

@ -109,7 +109,7 @@ H{
{ "d" c:double }
{ "B" c:bool }
{ "v" c:void }
{ "*" c:c-string }
{ "*" c:void* }
{ "?" unknown_type }
{ "@" id }
{ "#" Class }

1
basis/images/cocoa/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

66
basis/images/cocoa/cocoa.factor Normal file
View File

@ -0,0 +1,66 @@
! (c)2010 Joe Groff bsd license
USING: accessors alien.data cocoa cocoa.classes cocoa.messages
combinators core-foundation.data core-graphics.types fry images
images.loader io kernel literals math sequences ;
IN: images.cocoa
SINGLETON: ns-image
"png" ns-image register-image-class
"tif" ns-image register-image-class
"tiff" ns-image register-image-class
"gif" ns-image register-image-class
"jpg" ns-image register-image-class
"jpeg" ns-image register-image-class
"bmp" ns-image register-image-class
"ico" ns-image register-image-class
CONSTANT: NSImageRepLoadStatusUnknownType -1
CONSTANT: NSImageRepLoadStatusReadingHeader -2
CONSTANT: NSImageRepLoadStatusWillNeedAllData -3
CONSTANT: NSImageRepLoadStatusInvalidData -4
CONSTANT: NSImageRepLoadStatusUnexpectedEOF -5
CONSTANT: NSImageRepLoadStatusCompleted -6
CONSTANT: NSColorRenderingIntentDefault 0
CONSTANT: NSColorRenderingIntentAbsoluteColorimetric 1
CONSTANT: NSColorRenderingIntentRelativeColorimetric 2
CONSTANT: NSColorRenderingIntentPerceptual 3
CONSTANT: NSColorRenderingIntentSaturation 4
ERROR: ns-image-unknown-type ;
ERROR: ns-image-invalid-data ;
ERROR: ns-image-unexpected-eof ;
ERROR: ns-image-planar-images-not-supported ;
<PRIVATE
: check-return ( n -- )
{
{ $ NSImageRepLoadStatusUnknownType [ ns-image-unknown-type ] }
{ $ NSImageRepLoadStatusInvalidData [ ns-image-invalid-data ] }
{ $ NSImageRepLoadStatusUnexpectedEOF [ ns-image-unexpected-eof ] }
[ drop ]
} case ;
PRIVATE>
: load-image-rep ( -- image-rep )
NSBitmapImageRep contents <CFData> -> autorelease -> imageRepWithData:
NSColorSpace -> genericRGBColorSpace
NSColorRenderingIntentDefault
-> bitmapImageRepByConvertingToColorSpace:renderingIntent: ;
: image-rep>image ( image-rep -- image )
image new swap {
[ -> size CGSize>dim [ >integer ] map >>dim ]
[ -> bitmapData ]
[ -> bytesPerPlane memory>byte-array >>bitmap ]
} cleave
RGBA >>component-order
ubyte-components >>component-type
t >>premultiplied-alpha?
f >>upside-down? ;
M: ns-image stream>image
drop
[ load-image-rep ] with-input-stream image-rep>image ;

1
basis/images/cocoa/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/images/cocoa/summary.txt Normal file
View File

@ -0,0 +1 @@
Image loading using MacOS X's native Cocoa APIs

63
basis/images/gdiplus/gdiplus.factor Normal file
View File

@ -0,0 +1,63 @@
! (c)2010 Joe Groff bsd license
USING: accessors alien.c-types alien.data alien.enums
classes.struct destructors images images.loader
io.streams.limited kernel locals math windows.com
windows.gdiplus windows.streams windows.types typed
byte-arrays grouping sequences ;
IN: images.gdiplus
SINGLETON: gdi+-image
"png" gdi+-image register-image-class
"tif" gdi+-image register-image-class
"tiff" gdi+-image register-image-class
"gif" gdi+-image register-image-class
"jpg" gdi+-image register-image-class
"jpeg" gdi+-image register-image-class
"bmp" gdi+-image register-image-class
"ico" gdi+-image register-image-class
<PRIVATE
: <GpRect> ( x y w h -- rect )
GpRect <struct-boa> ; inline
: stream>gdi+-bitmap ( stream -- bitmap )
stream>IStream &com-release
{ void* } [ GdipCreateBitmapFromStream check-gdi+-status ]
[ ] with-out-parameters &GdipFree ;
: gdi+-bitmap-width ( bitmap -- w )
{ UINT } [ GdipGetImageWidth check-gdi+-status ]
[ ] with-out-parameters ;
: gdi+-bitmap-height ( bitmap -- w )
{ UINT } [ GdipGetImageHeight check-gdi+-status ]
[ ] with-out-parameters ;
: gdi+-lock-bitmap ( bitmap rect mode format -- data )
{ BitmapData } [ GdipBitmapLockBits check-gdi+-status ]
[ clone ] with-out-parameters ;
:: gdi+-bitmap>data ( bitmap -- w h pixels )
bitmap [ gdi+-bitmap-width ] [ gdi+-bitmap-height ] bi :> ( w h )
bitmap 0 0 w h <GpRect> ImageLockModeRead enum>number
PixelFormat32bppARGB gdi+-lock-bitmap :> bitmap-data
bitmap-data [ Scan0>> ] [ Stride>> ] [ Height>> * ] tri
memory>byte-array :> pixels
bitmap bitmap-data GdipBitmapUnlockBits check-gdi+-status
w h pixels ;
:: data>image ( w h pixels -- image )
image new
{ w h } >>dim
pixels >>bitmap
BGRA >>component-order
ubyte-components >>component-type
f >>upside-down? ;
PRIVATE>
M: gdi+-image stream>image
drop [
start-gdi+ &stop-gdi+ drop
stream>gdi+-bitmap
gdi+-bitmap>data
data>image
] with-destructors ;

5
basis/images/images.factor
View File

@ -62,7 +62,10 @@ UNION: alpha-channel BGRA RGBA ABGR ARGB LA A INTENSITY ;
UNION: alpha-channel-precedes-colors ABGR ARGB XBGR XRGB ;
TUPLE: image dim component-order component-type upside-down? bitmap ;
TUPLE: image
dim component-order component-type
upside-down? premultiplied-alpha?
bitmap ;
: <image> ( -- image ) image new ; inline

15
basis/opengl/textures/textures.factor
View File

@ -312,12 +312,21 @@ TUPLE: single-texture < disposable image dim loc texture-coords texture display-
[ init-texture texture-coords>> gl-texture-coord-pointer ] tri
swap gl-fill-rect ;
: set-blend-mode ( texture -- )
image>> dup has-alpha?
[ premultiplied-alpha?>> [ GL_ONE GL_ONE_MINUS_SRC_ALPHA glBlendFunc ] when ]
[ drop GL_BLEND glDisable ] if ;
: reset-blend-mode ( texture -- )
image>> dup has-alpha?
[ premultiplied-alpha?>> [ GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc ] when ]
[ drop GL_BLEND glEnable ] if ;
: draw-textured-rect ( dim texture -- )
[
[ image>> has-alpha? [ GL_BLEND glDisable ] unless ]
[ set-blend-mode ]
[ (draw-textured-rect) GL_TEXTURE_2D 0 glBindTexture ]
[ image>> has-alpha? [ GL_BLEND glEnable ] unless ]
tri
[ reset-blend-mode ] tri
] with-texturing ;
: texture-coords ( texture -- coords )

17
basis/ui/images/images.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces cache images images.loader accessors assocs
kernel opengl opengl.gl opengl.textures ui.gadgets.worlds
memoize images.png images.tiff ;
USING: accessors assocs cache combinators images images.loader
kernel memoize namespaces opengl opengl.gl opengl.textures system
ui.gadgets.worlds vocabs.loader ;
IN: ui.images
TUPLE: image-name path ;
@ -30,3 +30,14 @@ PRIVATE>
: image-dim ( image-name -- dim )
cached-image dim>> ;
<<
{
{ [ os macosx? ] [ "images.cocoa" require ] }
{ [ os winnt? ] [ "images.gdiplus" require ] }
[
"images.png" require
"images.tiff" require
]
} cond
>>

53
basis/windows/com/com.factor
View File

@ -1,6 +1,6 @@
USING: alien alien.c-types alien.destructors windows.com.syntax
windows.ole32 windows.types continuations kernel alien.syntax
libc destructors accessors alien.data ;
libc destructors accessors alien.data classes.struct windows.kernel32 ;
IN: windows.com
LIBRARY: ole32
@ -31,6 +31,55 @@ COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046}
HRESULT DragLeave ( )
HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ;
COM-INTERFACE: ISequentialStream IUnknown {0C733A30-2A1C-11CE-ADE5-00AA0044773D}
HRESULT Read ( void* pv, ULONG cb, ULONG* pcbRead )
HRESULT Write ( void* pv, ULONG cb, ULONG* pcbWritten ) ;
STRUCT: STATSTG
{ pwcsName LPOLESTR }
{ type DWORD }
{ cbSize ULARGE_INTEGER }
{ mtime FILETIME }
{ ctime FILETIME }
{ atime FILETIME }
{ grfMode DWORD }
{ grfLocksSupported DWORD }
{ clsid CLSID }
{ grfStateBits DWORD }
{ reserved DWORD } ;
CONSTANT: STGM_READ 0
CONSTANT: STGM_WRITE 1
CONSTANT: STGM_READWRITE 2
CONSTANT: STG_E_INVALIDFUNCTION HEX: 80030001
CONSTANT: STGTY_STORAGE 1
CONSTANT: STGTY_STREAM 2
CONSTANT: STGTY_LOCKBYTES 3
CONSTANT: STGTY_PROPERTY 4
CONSTANT: STREAM_SEEK_SET 0
CONSTANT: STREAM_SEEK_CUR 1
CONSTANT: STREAM_SEEK_END 2
CONSTANT: LOCK_WRITE 1
CONSTANT: LOCK_EXCLUSIVE 2
CONSTANT: LOCK_ONLYONCE 4
CONSTANT: GUID_NULL GUID: {00000000-0000-0000-0000-000000000000}
COM-INTERFACE: IStream ISequentialStream {0000000C-0000-0000-C000-000000000046}
HRESULT Seek ( LARGE_INTEGER dlibMove, DWORD dwOrigin, ULARGE_INTEGER* plibNewPosition )
HRESULT SetSize ( ULARGE_INTEGER* libNewSize )
HRESULT CopyTo ( IStream* pstm, ULARGE_INTEGER cb, ULARGE_INTEGER* pcbRead, ULARGE_INTEGER* pcbWritten )
HRESULT Commit ( DWORD grfCommitFlags )
HRESULT Revert ( )
HRESULT LockRegion ( ULARGE_INTEGER libOffset, ULARGE_INTEGER cb, DWORD dwLockType )
HRESULT UnlockRegion ( ULARGE_INTEGER libOffset, ULARGE_INTEGER cb, DWORD dwLockType )
HRESULT Stat ( STATSTG* pstatstg, DWORD grfStatFlag )
HRESULT Clone ( IStream** ppstm ) ;
FUNCTION: HRESULT RegisterDragDrop ( HWND hWnd, IDropTarget* pDropTarget ) ;
FUNCTION: HRESULT RevokeDragDrop ( HWND hWnd ) ;
FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
@ -51,3 +100,5 @@ FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
over [ com-release ] curry [ ] cleanup ; inline
DESTRUCTOR: com-release

1649
basis/windows/gdiplus/gdiplus.factor Normal file
View File

File diff suppressed because it is too large Load Diff

1
basis/windows/gdiplus/platforms.txt Normal file
View File

@ -0,0 +1 @@
windows

1
basis/windows/nt/nt.factor
View File

@ -12,6 +12,7 @@ USING: alien sequences alien.libraries ;
{ "libm" "msvcrt.dll" cdecl }
{ "gl" "opengl32.dll" stdcall }
{ "glu" "glu32.dll" stdcall }
{ "gdiplus" "gdiplus.dll" stdcall }
{ "ole32" "ole32.dll" stdcall }
{ "usp10" "usp10.dll" stdcall }
{ "psapi" "psapi.dll" stdcall }

3
basis/windows/ole32/ole32.factor
View File

@ -13,6 +13,9 @@ TYPEDEF: void* LPUNKNOWN
TYPEDEF: LPWSTR LPOLESTR
TYPEDEF: LPWSTR LPCOLESTR
TYPEDEF: GUID IID
TYPEDEF: GUID CLSID
TYPEDEF: REFGUID LPGUID
TYPEDEF: REFGUID REFIID
TYPEDEF: REFGUID REFCLSID

1
basis/windows/streams/platforms.txt Normal file
View File

@ -0,0 +1 @@
windows

123
basis/windows/streams/streams.factor Normal file
View File

@ -0,0 +1,123 @@
USING: accessors alien.c-types classes.struct combinators
continuations io kernel libc literals locals sequences
specialized-arrays windows.com memoize
windows.com.wrapper windows.kernel32 windows.ole32
windows.types ;
IN: windows.streams
SPECIALIZED-ARRAY: uchar
<PRIVATE
: with-hresult ( quot: ( -- result ) -- result )
[ drop E_FAIL ] recover ; inline
:: IStream-read ( stream pv cb out-read -- hresult )
[
cb stream stream-read :> buf
buf length :> bytes
pv buf bytes memcpy
out-read [ bytes out-read 0 ULONG set-alien-value ] when
cb bytes = [ S_OK ] [ S_FALSE ] if
] with-hresult ; inline
:: IStream-write ( stream pv cb out-written -- hresult )
[
pv cb <direct-uchar-array> stream stream-write
out-written [ cb out-written 0 ULONG set-alien-value ] when
S_OK
] with-hresult ; inline
: origin>seek-type ( origin -- seek-type )
{
{ $ STREAM_SEEK_SET [ seek-absolute ] }
{ $ STREAM_SEEK_CUR [ seek-relative ] }
{ $ STREAM_SEEK_END [ seek-end ] }
} case ;
:: IStream-seek ( stream move origin new-position -- hresult )
[
move origin origin>seek-type stream stream-seek
new-position [
stream stream-tell new-position 0 ULARGE_INTEGER set-alien-value
] when
S_OK
] with-hresult ; inline
:: IStream-set-size ( stream new-size -- hresult )
STG_E_INVALIDFUNCTION ;
:: IStream-copy-to ( stream other-stream cb out-read out-written -- hresult )
[
cb stream stream-read :> buf
buf length :> bytes
out-read [ bytes out-read 0 ULONG set-alien-value ] when
other-stream buf bytes out-written IStream::Write
] with-hresult ; inline
:: IStream-commit ( stream flags -- hresult )
stream stream-flush S_OK ;
:: IStream-revert ( stream -- hresult )
STG_E_INVALIDFUNCTION ;
:: IStream-lock-region ( stream offset cb lock-type -- hresult )
STG_E_INVALIDFUNCTION ;
:: IStream-unlock-region ( stream offset cb lock-type -- hresult )
STG_E_INVALIDFUNCTION ;
:: stream-size ( stream -- size )
stream stream-tell :> old-pos
0 seek-end stream stream-seek
stream stream-tell :> size
old-pos seek-absolute stream stream-seek
size ;
:: IStream-stat ( stream out-stat stat-flag -- hresult )
[
out-stat
f >>pwcsName
STGTY_STREAM >>type
stream stream-size >>cbSize
FILETIME <struct> >>mtime
FILETIME <struct> >>ctime
FILETIME <struct> >>atime
STGM_READWRITE >>grfMode
0 >>grfLocksSupported
GUID_NULL >>clsid
0 >>grfStateBits
0 >>reserved
drop
S_OK
] with-hresult ;
:: IStream-clone ( out-clone-stream -- hresult )
f out-clone-stream 0 void* set-alien-value
STG_E_INVALIDFUNCTION ;
CONSTANT: stream-wrapper
$[
{
{ IStream {
[ IStream-read ]
[ IStream-write ]
[ IStream-seek ]
[ IStream-set-size ]
[ IStream-copy-to ]
[ IStream-commit ]
[ IStream-revert ]
[ IStream-lock-region ]
[ IStream-unlock-region ]
[ IStream-stat ]
[ IStream-clone ]
} }
} <com-wrapper>
]
PRIVATE>
: stream>IStream ( stream -- IStream )
stream-wrapper com-wrap ;

1
basis/windows/streams/summary.txt Normal file
View File

@ -0,0 +1 @@
IStream interface wrapper for Factor stream objects

6
basis/windows/types/types.factor
View File

@ -16,6 +16,8 @@ TYPEDEF: wchar_t WCHAR
TYPEDEF: short SHORT
TYPEDEF: ushort USHORT
TYPEDEF: short INT16
TYPEDEF: ushort UINT16
TYPEDEF: ushort WORD
TYPEDEF: ulong DWORD
@ -94,7 +96,7 @@ TYPEDEF: HANDLE HDDEDATA
TYPEDEF: HANDLE HDESK
TYPEDEF: HANDLE HDROP
TYPEDEF: HANDLE HDWP
TYPEDEF: HANDLE HENMETAFILE
TYPEDEF: HANDLE HENHMETAFILE
TYPEDEF: HANDLE HFONT
TYPEDEF: HANDLE HGDIOBJ
TYPEDEF: HANDLE HGLOBAL
@ -398,3 +400,5 @@ STRUCT: TEXTMETRICW
{ tmCharSet BYTE } ;
TYPEDEF: TEXTMETRICW* LPTEXTMETRIC
TYPEDEF: ULONG PROPID

2
extra/gpu/textures/textures.factor
View File

@ -309,7 +309,7 @@ TYPED: read-compressed-texture ( tdt: texture-data-target level: integer -- byte
: read-texture-image ( tdt level -- image )
[ texture-dim ]
[ drop texture-object [ component-order>> ] [ component-type>> ] bi f ]
[ drop texture-object [ component-order>> ] [ component-type>> ] bi f f ]
[ read-texture ] 2tri
image boa ; inline