Merge remote-tracking branch 'factorcode/master'
John Benediktsson
commit
cc68afddce
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -30,16 +30,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 ( members -- )
|
||||
[
|
||||
[ drop define-singleton-class ]
|
||||
[ define-enum-value ] 2bi
|
||||
] assoc-each ;
|
||||
[ first define-singleton-class ] each ;
|
||||
|
||||
: define-enum-constructor ( word -- )
|
||||
[ name>> "<" ">" surround create-in ] keep
|
||||
|
|
@ -47,10 +44,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
|
||||
[ define-enum-members ]
|
||||
[ <enum-c-type> swap typedef ] bi ;
|
||||
|
||||
: define-enum ( word base-type members -- )
|
||||
[ (define-enum) ]
|
||||
[ [ define-enum-value ] assoc-each ] bi ;
|
||||
|
||||
PREDICATE: enum-c-type-word < c-type-word
|
||||
"c-type" word-prop enum-c-type? ;
|
||||
|
|
|
|||
|
|
@ -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 classes.parser ;
|
||||
vocabs.parser words.constant classes.parser alien.enums ;
|
||||
IN: alien.parser
|
||||
|
||||
SYMBOL: current-library
|
||||
|
|
@ -84,7 +84,8 @@ M: pointer return-type-name to>> return-type-name CHAR: * suffix ;
|
|||
[ [ <pointer> ] dip parse-pointers ] when ;
|
||||
|
||||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -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,6 +2,8 @@ USING: alien sequences sequences.private arrays bit-arrays kernel
|
|||
tools.test math random ;
|
||||
IN: bit-arrays.tests
|
||||
|
||||
[ -1 <bit-array> ] [ T{ bad-array-length f -1 } = ] must-fail-with
|
||||
|
||||
[ 100 ] [ 100 <bit-array> length ] unit-test
|
||||
|
||||
[
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007, 2010 Slava Pestov.
|
||||
! Copyright (C) 2007, 2011 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.data accessors io.binary math math.bitwise
|
||||
alien.accessors kernel kernel.private sequences
|
||||
|
|
@ -41,8 +41,12 @@ TUPLE: bit-array
|
|||
|
||||
PRIVATE>
|
||||
|
||||
ERROR: bad-array-length n ;
|
||||
|
||||
: <bit-array> ( n -- bit-array )
|
||||
dup bits>bytes <byte-array> bit-array boa ; inline
|
||||
dup 0 < [ bad-array-length ] when
|
||||
dup bits>bytes <byte-array>
|
||||
bit-array boa ; inline
|
||||
|
||||
M: bit-array length length>> ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -43,7 +43,9 @@ SYNTAX: IMPORT: scan [ ] import-objc-class ;
|
|||
"NSApplication"
|
||||
"NSArray"
|
||||
"NSAutoreleasePool"
|
||||
"NSBitmapImageRep"
|
||||
"NSBundle"
|
||||
"NSColorSpace"
|
||||
"NSData"
|
||||
"NSDictionary"
|
||||
"NSError"
|
||||
|
|
|
|||
|
|
@ -109,7 +109,7 @@ H{
|
|||
{ "d" c:double }
|
||||
{ "B" c:bool }
|
||||
{ "v" c:void }
|
||||
{ "*" c:c-string }
|
||||
{ "*" c:void* }
|
||||
{ "?" unknown_type }
|
||||
{ "@" id }
|
||||
{ "#" Class }
|
||||
|
|
|
|||
|
|
@ -1,12 +1,12 @@
|
|||
! Copyright (C) 2010 Anton Gorenko.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.libraries alien.syntax combinators
|
||||
gobject-introspection kernel system vocabs.loader ;
|
||||
USING: alien alien.data alien.libraries alien.syntax
|
||||
combinators gio.ffi glib.ffi gmodule.ffi gobject-introspection
|
||||
gobject.ffi kernel libc sequences system ;
|
||||
EXCLUDE: alien.c-types => pointer ;
|
||||
IN: gdk.pixbuf.ffi
|
||||
|
||||
<<
|
||||
"gio.ffi" require
|
||||
>>
|
||||
|
||||
LIBRARY: gdk.pixbuf
|
||||
|
||||
|
|
@ -18,3 +18,12 @@ LIBRARY: gdk.pixbuf
|
|||
>>
|
||||
|
||||
GIR: vocab:gdk/pixbuf/GdkPixbuf-2.0.gir
|
||||
|
||||
: data>GInputStream ( data -- GInputStream )
|
||||
[ malloc-byte-array &free ] [ length ] bi
|
||||
f g_memory_input_stream_new_from_data ;
|
||||
|
||||
: GInputStream>GdkPixbuf ( GInputStream -- GdkPixbuf )
|
||||
f { { pointer: GError initial: f } }
|
||||
[ gdk_pixbuf_new_from_stream ] with-out-parameters
|
||||
handle-GError ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2010 Anton Gorenko.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.destructors alien.libraries alien.syntax
|
||||
combinators kernel gobject-introspection
|
||||
gobject-introspection.standard-types system ;
|
||||
USING: accessors alien alien.c-types alien.destructors
|
||||
alien.libraries alien.strings alien.syntax combinators
|
||||
gobject-introspection gobject-introspection.standard-types
|
||||
io.encodings.utf8 kernel system vocabs.parser words ;
|
||||
IN: glib.ffi
|
||||
|
||||
LIBRARY: glib
|
||||
|
|
@ -15,7 +16,62 @@ LIBRARY: glib
|
|||
} cond
|
||||
>>
|
||||
|
||||
IMPLEMENT-STRUCTS: GPollFD GSource GSourceFuncs ;
|
||||
|
||||
TYPEDEF: char gchar
|
||||
TYPEDEF: uchar guchar
|
||||
TYPEDEF: short gshort
|
||||
TYPEDEF: ushort gushort
|
||||
TYPEDEF: long glong
|
||||
TYPEDEF: ulong gulong
|
||||
TYPEDEF: int gint
|
||||
TYPEDEF: uint guint
|
||||
|
||||
<<
|
||||
int c-type clone
|
||||
[ >c-bool ] >>unboxer-quot
|
||||
[ c-bool> ] >>boxer-quot
|
||||
object >>boxed-class
|
||||
"gboolean" current-vocab create typedef
|
||||
>>
|
||||
|
||||
TYPEDEF: char gint8
|
||||
TYPEDEF: uchar guint8
|
||||
TYPEDEF: short gint16
|
||||
TYPEDEF: ushort guint16
|
||||
TYPEDEF: int gint32
|
||||
TYPEDEF: uint guint32
|
||||
TYPEDEF: longlong gint64
|
||||
TYPEDEF: ulonglong guint64
|
||||
|
||||
TYPEDEF: float gfloat
|
||||
TYPEDEF: double gdouble
|
||||
|
||||
TYPEDEF: long ssize_t
|
||||
TYPEDEF: long time_t
|
||||
TYPEDEF: size_t gsize
|
||||
TYPEDEF: ssize_t gssize
|
||||
TYPEDEF: size_t GType
|
||||
|
||||
TYPEDEF: void* gpointer
|
||||
TYPEDEF: void* gconstpointer
|
||||
|
||||
TYPEDEF: guint8 GDateDay
|
||||
TYPEDEF: guint16 GDateYear
|
||||
TYPEDEF: gint GPid
|
||||
TYPEDEF: guint32 GQuark
|
||||
TYPEDEF: gint32 GTime
|
||||
TYPEDEF: glong gintptr
|
||||
TYPEDEF: gint64 goffset
|
||||
TYPEDEF: gulong guintptr
|
||||
TYPEDEF: guint32 gunichar
|
||||
TYPEDEF: guint16 gunichar2
|
||||
|
||||
TYPEDEF: gpointer pointer
|
||||
|
||||
REPLACE-C-TYPE: long\sdouble double
|
||||
REPLACE-C-TYPE: any gpointer
|
||||
|
||||
IMPLEMENT-STRUCTS: GError GPollFD GSource GSourceFuncs ;
|
||||
|
||||
CONSTANT: G_MININT8 HEX: -80
|
||||
CONSTANT: G_MAXINT8 HEX: 7f
|
||||
|
|
@ -38,3 +94,18 @@ DESTRUCTOR: g_free
|
|||
CALLBACK: gboolean GSourceFuncsPrepareFunc ( GSource* source, gint* timeout_ ) ;
|
||||
CALLBACK: gboolean GSourceFuncsCheckFunc ( GSource* source ) ;
|
||||
CALLBACK: gboolean GSourceFuncsDispatchFunc ( GSource* source, GSourceFunc callback, gpointer user_data ) ;
|
||||
|
||||
ERROR: g-error domain code message ;
|
||||
|
||||
: GError>g-error ( GError -- g-error )
|
||||
[ domain>> g_quark_to_string utf8 alien>string ]
|
||||
[ code>> ]
|
||||
[ message>> utf8 alien>string ] tri
|
||||
\ g-error boa ;
|
||||
|
||||
: handle-GError ( GError/f -- )
|
||||
[
|
||||
[ GError>g-error ]
|
||||
[ g_error_free ] bi
|
||||
throw
|
||||
] when* ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
macosx
|
||||
|
|
@ -0,0 +1 @@
|
|||
Image loading using MacOS X's native Cocoa APIs
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
windows
|
||||
|
|
@ -0,0 +1 @@
|
|||
Philipp Brüschweiler
|
||||
|
|
@ -0,0 +1,68 @@
|
|||
! Copyright (C) 2010 Philipp Brüschweiler.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.c-types alien.data arrays combinators
|
||||
destructors gdk.pixbuf.ffi gobject.ffi grouping images
|
||||
images.loader io kernel locals math sequences
|
||||
specialized-arrays ;
|
||||
IN: images.gtk
|
||||
SPECIALIZED-ARRAY: uchar
|
||||
|
||||
SINGLETON: gtk-image
|
||||
"png" gtk-image register-image-class
|
||||
"tif" gtk-image register-image-class
|
||||
"tiff" gtk-image register-image-class
|
||||
"gif" gtk-image register-image-class
|
||||
"jpg" gtk-image register-image-class
|
||||
"jpeg" gtk-image register-image-class
|
||||
"bmp" gtk-image register-image-class
|
||||
"ico" gtk-image register-image-class
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: image-data ( GdkPixbuf -- data )
|
||||
{
|
||||
[ gdk_pixbuf_get_pixels ]
|
||||
[ gdk_pixbuf_get_width ]
|
||||
[ gdk_pixbuf_get_height ]
|
||||
[ gdk_pixbuf_get_rowstride ]
|
||||
[ gdk_pixbuf_get_n_channels ]
|
||||
[ gdk_pixbuf_get_bits_per_sample ]
|
||||
} cleave
|
||||
[let :> ( pixels w h rowstride channels bps )
|
||||
bps channels * 7 + 8 /i w * :> bytes-per-row
|
||||
|
||||
bytes-per-row rowstride =
|
||||
[ pixels h rowstride * memory>byte-array ]
|
||||
[
|
||||
pixels rowstride h * <direct-uchar-array>
|
||||
rowstride <sliced-groups>
|
||||
[ bytes-per-row head-slice ] map concat
|
||||
] if
|
||||
] ;
|
||||
|
||||
: component-type ( GdkPixbuf -- component-type )
|
||||
gdk_pixbuf_get_bits_per_sample {
|
||||
{ 8 [ ubyte-components ] }
|
||||
{ 16 [ ushort-components ] }
|
||||
{ 32 [ uint-components ] }
|
||||
} case ;
|
||||
|
||||
: GdkPixbuf>image ( GdkPixbuf -- image )
|
||||
[ image new ] dip
|
||||
{
|
||||
[ [ gdk_pixbuf_get_width ] [ gdk_pixbuf_get_height ] bi 2array >>dim ]
|
||||
[ image-data >>bitmap ]
|
||||
[ gdk_pixbuf_get_has_alpha RGBA RGB ? >>component-order ]
|
||||
[ component-type >>component-type ]
|
||||
} cleave
|
||||
f >>premultiplied-alpha?
|
||||
f >>upside-down? ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: gtk-image stream>image
|
||||
drop [
|
||||
stream-contents data>GInputStream &g_object_unref
|
||||
GInputStream>GdkPixbuf &g_object_unref
|
||||
GdkPixbuf>image
|
||||
] with-destructors ;
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
linux
|
||||
bsd
|
||||
|
|
@ -0,0 +1 @@
|
|||
Image loading using GTK's GdkPixbuf API
|
||||
|
|
@ -3,7 +3,7 @@
|
|||
USING: images tools.test kernel accessors ;
|
||||
IN: images.tests
|
||||
|
||||
[ B{ 57 57 57 255 } ] [ 1 1 T{ image f { 2 3 } RGBA ubyte-components f B{
|
||||
[ B{ 57 57 57 255 } ] [ 1 1 T{ image f { 2 3 } RGBA ubyte-components f f B{
|
||||
0 0 0 0
|
||||
0 0 0 0
|
||||
0 0 0 0
|
||||
|
|
@ -19,7 +19,7 @@ IN: images.tests
|
|||
57 57 57 255
|
||||
0 0 0 0
|
||||
0 0 0 0
|
||||
} ] [ B{ 57 57 57 255 } 1 1 T{ image f { 2 3 } RGBA ubyte-components f B{
|
||||
} ] [ B{ 57 57 57 255 } 1 1 T{ image f { 2 3 } RGBA ubyte-components f f B{
|
||||
0 0 0 0
|
||||
0 0 0 0
|
||||
0 0 0 0
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -10,12 +10,12 @@ IN: images.tesselation
|
|||
[
|
||||
{
|
||||
{
|
||||
T{ image f { 2 2 } L ubyte-components f B{ 1 2 5 6 } }
|
||||
T{ image f { 2 2 } L ubyte-components f B{ 3 4 7 8 } }
|
||||
T{ image f { 2 2 } L ubyte-components f f B{ 1 2 5 6 } }
|
||||
T{ image f { 2 2 } L ubyte-components f f B{ 3 4 7 8 } }
|
||||
}
|
||||
{
|
||||
T{ image f { 2 2 } L ubyte-components f B{ 9 10 13 14 } }
|
||||
T{ image f { 2 2 } L ubyte-components f B{ 11 12 15 16 } }
|
||||
T{ image f { 2 2 } L ubyte-components f f B{ 9 10 13 14 } }
|
||||
T{ image f { 2 2 } L ubyte-components f f B{ 11 12 15 16 } }
|
||||
}
|
||||
}
|
||||
] [
|
||||
|
|
@ -30,12 +30,12 @@ IN: images.tesselation
|
|||
[
|
||||
{
|
||||
{
|
||||
T{ image f { 2 2 } L ubyte-components f B{ 1 2 4 5 } }
|
||||
T{ image f { 1 2 } L ubyte-components f B{ 3 6 } }
|
||||
T{ image f { 2 2 } L ubyte-components f f B{ 1 2 4 5 } }
|
||||
T{ image f { 1 2 } L ubyte-components f f B{ 3 6 } }
|
||||
}
|
||||
{
|
||||
T{ image f { 2 1 } L ubyte-components f B{ 7 8 } }
|
||||
T{ image f { 1 1 } L ubyte-components f B{ 9 } }
|
||||
T{ image f { 2 1 } L ubyte-components f f B{ 7 8 } }
|
||||
T{ image f { 1 1 } L ubyte-components f f B{ 9 } }
|
||||
}
|
||||
}
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -1,6 +1,8 @@
|
|||
USING: nibble-arrays tools.test sequences kernel math ;
|
||||
IN: nibble-arrays.tests
|
||||
|
||||
[ -1 <nibble-array> ] [ T{ bad-array-length f -1 } = ] must-fail-with
|
||||
|
||||
[ t ] [ 16 iota dup >nibble-array sequence= ] unit-test
|
||||
[ N{ 4 2 1 3 } ] [ N{ 3 1 2 4 } reverse ] unit-test
|
||||
[ N{ 1 4 9 0 9 4 } ] [ N{ 1 2 3 4 5 6 } [ sq ] map ] unit-test
|
||||
|
|
|
|||
|
|
@ -30,7 +30,10 @@ CONSTANT: nibble BIN: 1111
|
|||
|
||||
PRIVATE>
|
||||
|
||||
ERROR: bad-array-length n ;
|
||||
|
||||
: <nibble-array> ( n -- nibble-array )
|
||||
dup 0 < [ bad-array-length ] when
|
||||
dup nibbles>bytes <byte-array> nibble-array boa ; inline
|
||||
|
||||
M: nibble-array length length>> ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -100,6 +100,13 @@ IN: tools.deploy.shaker
|
|||
run-file
|
||||
] when ;
|
||||
|
||||
: strip-gtk-icon ( -- )
|
||||
"ui.backend.gtk" vocab [
|
||||
"Stripping GTK icon loading code" show
|
||||
"vocab:tools/deploy/shaker/strip-gtk-icon.factor"
|
||||
run-file
|
||||
] when ;
|
||||
|
||||
: strip-specialized-arrays ( -- )
|
||||
strip-dictionary? "specialized-arrays" vocab and [
|
||||
"Stripping specialized arrays" show
|
||||
|
|
@ -542,6 +549,7 @@ SYMBOL: deploy-vocab
|
|||
strip-call
|
||||
strip-cocoa
|
||||
strip-gobject
|
||||
strip-gtk-icon
|
||||
strip-debugger
|
||||
strip-ui-error-hook
|
||||
strip-specialized-arrays
|
||||
|
|
|
|||
|
|
@ -0,0 +1,13 @@
|
|||
! Copyright (C) 2010 Philipp Brüschweiler
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel tools.deploy.shaker literals namespaces
|
||||
vocabs.loader io.pathnames io.files io.encodings.binary ;
|
||||
IN: ui.backend.gtk
|
||||
|
||||
CONSTANT: get-icon-data
|
||||
$[
|
||||
deploy-vocab get
|
||||
dup vocab-dir "icon.png" append-path vocab-append-path
|
||||
[ exists? ] keep "resource:misc/icons/Factor_48x48.png" ?
|
||||
binary file-contents
|
||||
]
|
||||
|
|
@ -1,9 +1,8 @@
|
|||
! Copyright (C) 2008 James Cash
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io io.pathnames io.directories io.files
|
||||
io.files.info.unix io.backend kernel namespaces make sequences
|
||||
system tools.deploy.backend tools.deploy.config
|
||||
tools.deploy.config.editor assocs hashtables prettyprint ;
|
||||
USING: io io.backend io.directories io.files.info.unix kernel
|
||||
namespaces sequences system tools.deploy.backend
|
||||
tools.deploy.config tools.deploy.config.editor ;
|
||||
IN: tools.deploy.unix
|
||||
|
||||
: create-app-dir ( vocab bundle-name -- vm )
|
||||
|
|
@ -14,12 +13,12 @@ IN: tools.deploy.unix
|
|||
deploy-name get ;
|
||||
|
||||
M: unix deploy* ( vocab -- )
|
||||
"." resource-path [
|
||||
"resource:" [
|
||||
dup deploy-config [
|
||||
[ bundle-name create-app-dir ] keep
|
||||
[ bundle-name image-name ] keep
|
||||
namespace make-deploy-image
|
||||
bundle-name "" [ copy-resources ] [ copy-libraries ] 3bi
|
||||
bundle-name normalize-path [ "Binary deployed to " % % "." % ] "" make print
|
||||
bundle-name normalize-path "Binary deployed to " "." surround print
|
||||
] bind
|
||||
] with-directory ;
|
||||
|
|
|
|||
|
|
@ -3,14 +3,18 @@
|
|||
USING: accessors alien.accessors alien.c-types alien.data
|
||||
alien.strings arrays assocs classes.struct command-line
|
||||
continuations destructors environment gdk.ffi gdk.gl.ffi
|
||||
glib.ffi gobject-introspection.standard-types gobject.ffi
|
||||
gtk.ffi gtk.gl.ffi io.encodings.utf8 kernel libc literals locals
|
||||
math math.bitwise math.order math.vectors namespaces sequences
|
||||
strings system threads ui ui.backend ui.backend.gtk.input-methods
|
||||
ui.backend.gtk.io ui.clipboards ui.event-loop ui.gadgets
|
||||
ui.gadgets.private ui.gadgets.worlds ui.gestures
|
||||
ui.pixel-formats ui.pixel-formats.private ui.private
|
||||
vocabs.loader combinators prettyprint io ;
|
||||
gdk.pixbuf.ffi glib.ffi
|
||||
gobject-introspection.standard-types
|
||||
gobject.ffi gtk.ffi gtk.gl.ffi io.backend
|
||||
io.backend.unix.multiplexers io.encodings.binary
|
||||
io.encodings.utf8 io.files io.thread kernel libc literals
|
||||
locals math math.bitwise math.order math.vectors namespaces
|
||||
sequences strings system threads ui ui.backend ui.backend.gtk.input-methods
|
||||
ui.backend.gtk.io ui.clipboards
|
||||
ui.commands ui.event-loop ui.gadgets ui.gadgets.editors
|
||||
ui.gadgets.menus ui.gadgets.private ui.gadgets.worlds
|
||||
ui.gestures ui.pixel-formats ui.pixel-formats.private
|
||||
ui.private vocabs.loader combinators io ;
|
||||
IN: ui.backend.gtk
|
||||
|
||||
SINGLETON: gtk-ui-backend
|
||||
|
|
@ -156,9 +160,6 @@ CONSTANT: action-key-codes
|
|||
{ $ GDK_SCROLL_RIGHT { 1 0 } }
|
||||
} at ;
|
||||
|
||||
: mouse-event>gesture ( event -- modifiers button loc )
|
||||
[ event-modifiers ] [ button>> ] [ event-loc ] tri ;
|
||||
|
||||
: on-motion ( win event user-data -- ? )
|
||||
drop swap
|
||||
[ event-loc ] dip window
|
||||
|
|
@ -169,23 +170,33 @@ CONSTANT: action-key-codes
|
|||
|
||||
:: on-button-press ( win event user-data -- ? )
|
||||
win window :> world
|
||||
event mouse-event>gesture :> ( modifiers button loc )
|
||||
button {
|
||||
{ 8 [ ] }
|
||||
{ 9 [ ] }
|
||||
[ modifiers swap <button-down> loc world
|
||||
send-button-down ]
|
||||
} case t ;
|
||||
event type>> GDK_BUTTON_PRESS = [
|
||||
event button>> {
|
||||
{ 8 [ ] }
|
||||
{ 9 [ ] }
|
||||
[
|
||||
event event-modifiers swap <button-down>
|
||||
event event-loc
|
||||
world
|
||||
send-button-down
|
||||
]
|
||||
} case
|
||||
] when t ;
|
||||
|
||||
:: on-button-release ( win event user-data -- ? )
|
||||
win window :> world
|
||||
event mouse-event>gesture :> ( modifiers button loc )
|
||||
button {
|
||||
{ 8 [ world left-action send-action ] }
|
||||
{ 9 [ world right-action send-action ] }
|
||||
[ modifiers swap <button-up> loc world
|
||||
send-button-up ]
|
||||
} case t ;
|
||||
event type>> GDK_BUTTON_RELEASE = [
|
||||
event button>> {
|
||||
{ 8 [ world left-action send-action ] }
|
||||
{ 9 [ world right-action send-action ] }
|
||||
[
|
||||
event event-modifiers swap <button-up>
|
||||
event event-loc
|
||||
world
|
||||
send-button-up
|
||||
]
|
||||
} case
|
||||
] when t ;
|
||||
|
||||
: on-scroll ( win event user-data -- ? )
|
||||
drop swap [
|
||||
|
|
@ -198,7 +209,7 @@ CONSTANT: action-key-codes
|
|||
|
||||
: key-event>gesture ( event -- mods sym/f action? )
|
||||
[ event-modifiers ] [ key-sym ] bi ;
|
||||
|
||||
|
||||
: on-key-press ( win event user-data -- ? )
|
||||
drop swap [ key-event>gesture <key-down> ] [ window ] bi*
|
||||
propagate-key-gesture t ;
|
||||
|
|
@ -213,6 +224,17 @@ CONSTANT: action-key-codes
|
|||
: on-focus-out ( win event user-data -- ? )
|
||||
2drop window unfocus-world t ;
|
||||
|
||||
! This word gets replaced when deploying. See 'Vocabulary icons'
|
||||
! in the docs and tools.deploy.shaker.gtk-icon
|
||||
: get-icon-data ( -- byte-array )
|
||||
"resource:misc/icons/Factor_48x48.png" binary file-contents ;
|
||||
|
||||
: load-icon ( -- )
|
||||
get-icon-data [
|
||||
data>GInputStream &g_object_unref
|
||||
GInputStream>GdkPixbuf gtk_window_set_default_icon
|
||||
] with-destructors ;
|
||||
|
||||
:: connect-user-input-signals ( win -- )
|
||||
win events-mask gtk_widget_add_events
|
||||
win "motion-notify-event" [ on-motion yield ]
|
||||
|
|
@ -303,7 +325,7 @@ CONSTANT: action-key-codes
|
|||
:: configure-im ( win im -- )
|
||||
im win gtk_widget_get_window gtk_im_context_set_client_window
|
||||
im f gtk_im_context_set_use_preedit
|
||||
|
||||
|
||||
im "commit" [ on-commit yield ]
|
||||
GtkIMContext:commit win connect-signal-with-data
|
||||
im "retrieve-surrounding" [ on-retrieve-surrounding yield ]
|
||||
|
|
@ -334,7 +356,7 @@ CONSTANT: window-controls>decor-flags
|
|||
{ normal-title-bar $ GDK_DECOR_TITLE }
|
||||
{ textured-background 0 }
|
||||
}
|
||||
|
||||
|
||||
CONSTANT: window-controls>func-flags
|
||||
H{
|
||||
{ close-button $ GDK_FUNC_CLOSE }
|
||||
|
|
@ -429,18 +451,18 @@ M:: gtk-ui-backend (open-window) ( world -- )
|
|||
win im <window-handle> world handle<<
|
||||
|
||||
world win register-window
|
||||
|
||||
|
||||
win world [ window-loc>> auto-position ]
|
||||
[ dim>> first2 gtk_window_set_default_size ] 2bi
|
||||
|
||||
win "factor" "Factor" [ utf8 string>alien ] bi@
|
||||
gtk_window_set_wmclass
|
||||
|
||||
|
||||
world configure-gl
|
||||
|
||||
win gtk_widget_realize
|
||||
win world window-controls>> configure-window-controls
|
||||
|
||||
|
||||
win im configure-im
|
||||
win connect-user-input-signals
|
||||
win connect-win-state-signals
|
||||
|
|
@ -463,7 +485,7 @@ M: gtk-ui-backend (set-fullscreen)
|
|||
|
||||
M: gtk-ui-backend (fullscreen?)
|
||||
handle>> fullscreen?>> ;
|
||||
|
||||
|
||||
M: gtk-ui-backend raise-window*
|
||||
handle>> window>> gtk_window_present ;
|
||||
|
||||
|
|
@ -502,6 +524,7 @@ M: gtk-ui-backend (with-ui)
|
|||
[
|
||||
0 gint <ref> f void* <ref> gtk_init
|
||||
0 gint <ref> f void* <ref> gtk_gl_init
|
||||
load-icon
|
||||
init-clipboard
|
||||
start-ui
|
||||
[
|
||||
|
|
|
|||
|
|
@ -45,7 +45,7 @@ PRIVATE>
|
|||
|
||||
: show-glass ( owner child visible-rect -- )
|
||||
<glass>
|
||||
dup gadget-child hand-clicked set
|
||||
dup gadget-child hand-clicked set-global
|
||||
dup owner>> find-world add-glass ;
|
||||
|
||||
\ glass H{
|
||||
|
|
|
|||
|
|
@ -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,11 @@ PRIVATE>
|
|||
|
||||
: image-dim ( image-name -- dim )
|
||||
cached-image dim>> ;
|
||||
|
||||
<<
|
||||
{
|
||||
{ [ os macosx? ] [ "images.cocoa" require ] }
|
||||
{ [ os winnt? ] [ "images.gdiplus" require ] }
|
||||
[ "images.gtk" require ]
|
||||
} cond
|
||||
>>
|
||||
|
|
|
|||
|
|
@ -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 ) ;
|
||||
|
|
@ -50,3 +99,5 @@ FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
|
|||
over [ com-release ] curry [ ] cleanup ; inline
|
||||
|
||||
DESTRUCTOR: com-release
|
||||
|
||||
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1 @@
|
|||
windows
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
windows
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
IStream interface wrapper for Factor stream objects
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -17,6 +17,7 @@ CONSTANT: MAX_UNICODE_PATH 32768
|
|||
{ "iphlpapi" "iphlpapi.dll" stdcall }
|
||||
{ "libc" "msvcrt.dll" cdecl }
|
||||
{ "libm" "msvcrt.dll" cdecl }
|
||||
{ "gdiplus" "gdiplus.dll" stdcall }
|
||||
{ "gl" "opengl32.dll" stdcall }
|
||||
{ "glu" "glu32.dll" stdcall }
|
||||
{ "ole32" "ole32.dll" stdcall }
|
||||
|
|
|
|||
|
|
@ -28,7 +28,12 @@ ARTICLE: "vocabs.roots" "Vocabulary roots"
|
|||
{ $subsections "add-vocab-roots" } ;
|
||||
|
||||
ARTICLE: "vocabs.icons" "Vocabulary icons"
|
||||
"An icon file representing the vocabulary can be provided for use by " { $link "tools.deploy" } ". A file named " { $snippet "icon.ico" } " will be used as the application icon when the application is deployed on Windows. A file named " { $snippet "icon.icns" } " will be used when the application is deployed on MacOS X." ;
|
||||
"An icon file representing the vocabulary can be provided for use by " { $link "tools.deploy" } ". If any of the following files exist inside the vocabulary directory, they will be used as icons when the application is deployed."
|
||||
{ $list
|
||||
{ { $snippet "icon.ico" } " on Windows" }
|
||||
{ { $snippet "icon.icns" } " on MacOS X" }
|
||||
{ { $snippet "icon.png" } " on Linux and *BSD" }
|
||||
} ;
|
||||
|
||||
ARTICLE: "vocabs.loader" "Vocabulary loader"
|
||||
"The " { $link POSTPONE: USE: } " and " { $link POSTPONE: USING: } " words load vocabularies using the vocabulary loader. The vocabulary loader is implemented in the " { $vocab-link "vocabs.loader" } " vocabulary."
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ HELP: ffi-errors
|
|||
|
||||
HELP: supported-engines
|
||||
{ $values
|
||||
{ "value" array }
|
||||
{ "seq" array }
|
||||
}
|
||||
{ $description "An " { $link array } " of " { $link string } "s representing all valid " { $emphasis "layout engines" } ". For example, the " { $emphasis "dot" } " engine is typically included in a Graphviz installation, so " { $snippet "\"dot\"" } " will be an element of " { $link supported-engines } ". See " { $url "http://graphviz.org/Documentation.php" } " for more details." }
|
||||
{ $notes "This constant's definition is determined at parse-time by asking the system's Graphviz installation what engines are supported." }
|
||||
|
|
@ -21,7 +21,7 @@ HELP: supported-engines
|
|||
|
||||
HELP: supported-formats
|
||||
{ $values
|
||||
{ "value" array }
|
||||
{ "seq" array }
|
||||
}
|
||||
{ $description "An " { $link array } " of " { $link string } "s representing all valid " { $emphasis "layout formats" } ". For example, Graphviz can typically render using the Postscript format, in which case " { $snippet "\"ps\"" } " will be an element of " { $link supported-formats } ". See " { $url "http://graphviz.org/Documentation.php" } " for more details." }
|
||||
{ $notes "This constant's definition is determined at parse-time by asking the system's Graphviz installation what formats are supported."
|
||||
|
|
|
|||
|
|
@ -3,12 +3,9 @@
|
|||
USING: accessors alien alien.c-types alien.destructors
|
||||
alien.libraries alien.syntax combinators debugger destructors
|
||||
fry io kernel literals math prettyprint sequences splitting
|
||||
system words.constant
|
||||
graphviz
|
||||
;
|
||||
system memoize graphviz ;
|
||||
IN: graphviz.ffi
|
||||
|
||||
<<
|
||||
"libgraph" {
|
||||
{ [ os macosx? ] [ "libgraph.dylib" ] }
|
||||
{ [ os unix? ] [ "libgraph.so" ] }
|
||||
|
|
@ -21,7 +18,6 @@ IN: graphviz.ffi
|
|||
{ [ os unix? ] [ "libgvc.so" ] }
|
||||
{ [ os winnt? ] [ "gvc.dll" ] }
|
||||
} cond cdecl add-library
|
||||
>>
|
||||
|
||||
LIBRARY: libgraph
|
||||
|
||||
|
|
@ -85,11 +81,7 @@ FUNCTION: int agsafeset ( void* obj,
|
|||
LIBRARY: libgvc
|
||||
|
||||
! Graphviz contexts
|
||||
! This must be wrapped in << >> so that GVC_t*, gvContext, and
|
||||
! &gvFreeContext can be used to compute the supported-engines
|
||||
! and supported-formats constants below.
|
||||
|
||||
<<
|
||||
C-TYPE: GVC_t
|
||||
|
||||
FUNCTION: GVC_t* gvContext ( ) ;
|
||||
|
|
@ -112,7 +104,6 @@ M: ffi-errors error.
|
|||
int-gvFreeContext dup zero? [ drop ] [ ffi-errors ] if ;
|
||||
|
||||
DESTRUCTOR: gvFreeContext
|
||||
>>
|
||||
|
||||
! Layout
|
||||
|
||||
|
|
@ -130,8 +121,6 @@ FUNCTION: int gvRenderFilename ( GVC_t* gvc,
|
|||
|
||||
! Supported layout engines (dot, neato, etc.) and output
|
||||
! formats (png, jpg, etc.)
|
||||
|
||||
<<
|
||||
<PRIVATE
|
||||
|
||||
ENUM: api_t
|
||||
|
|
@ -152,7 +141,6 @@ FUNCTION: c-string
|
|||
] with-destructors ;
|
||||
|
||||
PRIVATE>
|
||||
>>
|
||||
|
||||
CONSTANT: supported-engines $[ API_layout plugin-list ]
|
||||
CONSTANT: supported-formats $[ API_device plugin-list ]
|
||||
MEMO: supported-engines ( -- seq ) API_layout plugin-list ;
|
||||
MEMO: supported-formats ( -- seq ) API_device plugin-list ;
|
||||
|
|
|
|||
|
|
@ -1,11 +1,9 @@
|
|||
! Copyright (C) 2011 Alex Vondrak.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators continuations destructors
|
||||
images.viewer io.backend io.files.unique kernel locals
|
||||
namespaces parser sequences summary unicode.case words
|
||||
graphviz.ffi
|
||||
graphviz.builder
|
||||
;
|
||||
USING: accessors combinators compiler.units continuations
|
||||
destructors images.viewer io.backend io.files.unique kernel
|
||||
locals namespaces parser sequences summary unicode.case words
|
||||
graphviz.ffi graphviz.builder ;
|
||||
IN: graphviz.render
|
||||
|
||||
SYMBOL: default-layout
|
||||
|
|
@ -109,8 +107,6 @@ PRIVATE>
|
|||
: preview-window ( graph -- )
|
||||
(preview) image-window ; inline
|
||||
|
||||
<<
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: define-graphviz-by-engine ( -K -- )
|
||||
|
|
@ -130,7 +126,7 @@ PRIVATE>
|
|||
|
||||
PRIVATE>
|
||||
|
||||
supported-engines [ define-graphviz-by-engine ] each
|
||||
supported-formats [ define-graphviz-by-format ] each
|
||||
|
||||
>>
|
||||
[
|
||||
supported-engines [ define-graphviz-by-engine ] each
|
||||
supported-formats [ define-graphviz-by-format ] each
|
||||
] with-compilation-unit
|
||||
|
|
|
|||
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
|
|
@ -88,12 +88,18 @@ TUPLE: vbo
|
|||
index-buffer index-count vertex-format texture bump ka ;
|
||||
|
||||
: white-image ( -- image )
|
||||
{ 1 1 } BGR ubyte-components f
|
||||
B{ 255 255 255 } image boa ;
|
||||
<image>
|
||||
{ 1 1 } >>dim
|
||||
BGR >>component-order
|
||||
ubyte-components >>component-type
|
||||
B{ 255 255 255 } >>bitmap ;
|
||||
|
||||
: up-image ( -- image )
|
||||
{ 1 1 } BGR ubyte-components f
|
||||
B{ 0 0 0 } image boa ;
|
||||
<image>
|
||||
{ 1 1 } >>dim
|
||||
BGR >>component-order
|
||||
ubyte-components >>component-type
|
||||
B{ 0 0 0 } >>bitmap ;
|
||||
|
||||
: make-texture ( pathname alt -- texture )
|
||||
swap [ nip load-image ] [ ] if*
|
||||
|
|
|
|||
Loading…
Reference in New Issue