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

Refactor Core Foundation binding a bit, add new >cf word to convert Factor objects to CF values

db4
Slava Pestov 2009-01-20 23:06:23 -06:00
parent 088ad42370
commit 9f76476d26
20 changed files with 247 additions and 146 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
basis/cocoa/application/application-docs.factor
View File

@ -8,12 +8,6 @@ HELP: <NSString>
{ <NSString> <CFString> CF>string } related-words
HELP: <NSArray>
{ $values { "seq" "a sequence of " { $link alien } " instances" } { "alien" alien } }
{ $description "Allocates an autoreleased " { $snippet "CFArray" } "." } ;
{ <NSArray> <CFArray> } related-words
HELP: with-autorelease-pool
{ $values { "quot" quotation } }
{ $description "Sets up a new " { $snippet "NSAutoreleasePool" } ", calls the quotation and frees the pool." } ;

21
basis/cocoa/application/application.factor
View File

@ -1,27 +1,17 @@
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax io kernel namespaces core-foundation
core-foundation.arrays core-foundation.data
core-foundation.strings cocoa.messages cocoa cocoa.classes
cocoa.runtime sequences threads init summary kernel.private
assocs ;
IN: cocoa.application
: <NSString> ( str -- alien ) <CFString> -> autorelease ;
: <NSArray> ( seq -- alien ) <CFArray> -> autorelease ;
: <NSNumber> ( number -- alien ) <CFNumber> -> autorelease ;
: <NSData> ( byte-array -- alien ) <CFData> -> autorelease ;
: <NSDictionary> ( assoc -- alien )
NSMutableDictionary over assoc-size -> dictionaryWithCapacity:
[
[
spin -> setObject:forKey:
] curry assoc-each
] keep ;
: NSApplicationDelegateReplySuccess 0 ;
: NSApplicationDelegateReplyCancel 1 ;
: NSApplicationDelegateReplyFailure 2 ;
C-ENUM:
NSApplicationDelegateReplySuccess
NSApplicationDelegateReplyCancel
NSApplicationDelegateReplyFailure ;
: with-autorelease-pool ( quot -- )
NSAutoreleasePool -> new slip -> release ; inline
@ -45,7 +35,8 @@ FUNCTION: void NSBeep ( ) ;
[ NSNotificationCenter -> defaultCenter ] dip
-> removeObserver: ;
: cocoa-app ( quot -- ) [ call NSApp -> run ] with-cocoa ; inline
: cocoa-app ( quot -- )
[ call NSApp -> run ] with-cocoa ; inline
: install-delegate ( receiver delegate -- )
-> alloc -> init -> setDelegate: ;

4
basis/cocoa/pasteboard/pasteboard.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.accessors arrays kernel cocoa.messages
cocoa.classes cocoa.application sequences cocoa core-foundation
@ -15,7 +15,7 @@ IN: cocoa.pasteboard
dup [ CF>string ] when ;
: set-pasteboard-types ( seq pasteboard -- )
swap <NSArray> f -> declareTypes:owner: drop ;
swap <CFArray> -> autorelease f -> declareTypes:owner: drop ;
: set-pasteboard-string ( str pasteboard -- )
NSStringPboardType <NSString>

58
basis/cocoa/plists/plists.factor
View File

@ -1,42 +1,29 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! Copyright (C) 2007, 2009 Slava Pestov.
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: strings arrays hashtables assocs sequences
USING: strings arrays hashtables assocs sequences fry macros
cocoa.messages cocoa.classes cocoa.application cocoa kernel
namespaces io.backend math cocoa.enumeration byte-arrays
combinators alien.c-types core-foundation core-foundation.data ;
combinators alien.c-types words core-foundation
core-foundation.data core-foundation.utilities ;
IN: cocoa.plists
GENERIC: >plist ( value -- plist )
M: number >plist
<NSNumber> ;
M: t >plist
<NSNumber> ;
M: f >plist
<NSNumber> ;
M: string >plist
<NSString> ;
M: byte-array >plist
<NSData> ;
M: hashtable >plist
[ [ >plist ] bi@ ] assoc-map <NSDictionary> ;
M: sequence >plist
[ >plist ] map <NSArray> ;
: >plist ( value -- plist ) >cf -> autorelease ;
: write-plist ( assoc path -- )
[ >plist ] [ normalize-path <NSString> ] bi* 0
-> writeToFile:atomically:
[ >plist ] [ normalize-path <NSString> ] bi* 0 -> writeToFile:atomically:
[ "write-plist failed" throw ] unless ;
DEFER: plist>
<PRIVATE
: (plist-NSString>) ( NSString -- string )
-> UTF8String ;
: (plist-NSNumber>) ( NSNumber -- number )
dup -> doubleValue dup >integer =
[ -> longLongValue ]
[ -> doubleValue ] if ;
[ -> longLongValue ] [ -> doubleValue ] if ;
: (plist-NSData>) ( NSData -- byte-array )
dup -> length <byte-array> [ -> getBytes: ] keep ;
@ -48,21 +35,26 @@ DEFER: plist>
dup [ [ -> valueForKey: ] keep swap [ plist> ] bi@ 2array ] with
NSFastEnumeration-map >hashtable ;
: plist> ( plist -- value )
{
{ [ dup NSString -> isKindOfClass: c-bool> ] [ (plist-NSString>) ] }
{ [ dup NSNumber -> isKindOfClass: c-bool> ] [ (plist-NSNumber>) ] }
{ [ dup NSData -> isKindOfClass: c-bool> ] [ (plist-NSData>) ] }
{ [ dup NSArray -> isKindOfClass: c-bool> ] [ (plist-NSArray>) ] }
{ [ dup NSDictionary -> isKindOfClass: c-bool> ] [ (plist-NSDictionary>) ] }
[ ]
} cond ;
: (read-plist) ( NSData -- id )
NSPropertyListSerialization swap kCFPropertyListImmutable f f <void*>
[ -> propertyListFromData:mutabilityOption:format:errorDescription: ] keep
*void* [ -> release "read-plist failed" throw ] when* ;
MACRO: objc-class-case ( alist -- quot )
[ [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip ] assoc-map '[ _ cond ] ;
PRIVATE>
: plist> ( plist -- value )
{
{ NSString [ (plist-NSString>) ] }
{ NSNumber [ (plist-NSNumber>) ] }
{ NSData [ (plist-NSData>) ] }
{ NSArray [ (plist-NSArray>) ] }
{ NSDictionary [ (plist-NSDictionary>) ] }
{ NSObject [ ] }
} objc-class-case ;
: read-plist ( path -- assoc )
normalize-path <NSString>
NSData swap -> dataWithContentsOfFile:

12
basis/core-foundation/attributed-strings/attributed-strings.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel core-foundation
core-foundation.strings core-foundation.dictionaries ;
USING: alien.syntax kernel destructors core-foundation
core-foundation.utilities ;
IN: core-foundation.attributed-strings
TYPEDEF: void* CFAttributedStringRef
@ -13,7 +13,7 @@ FUNCTION: CFAttributedStringRef CFAttributedStringCreate (
) ;
: <CFAttributedString> ( string alist -- alien )
[ <CFString> ] [ <CFDictionary> ] bi*
[ [ kCFAllocatorDefault ] 2dip CFAttributedStringCreate ]
[ [ CFRelease ] bi@ ]
2bi ;
[
[ >cf &CFRelease ] bi@
[ kCFAllocatorDefault ] 2dip CFAttributedStringCreate
] with-destructors ;

39
basis/core-foundation/data/data.factor
View File

@ -1,55 +1,20 @@
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax alien.c-types sequences kernel math ;
USING: alien.c-types alien.syntax core-foundation.numbers kernel math
sequences core-foundation.numbers ;
IN: core-foundation.data
TYPEDEF: void* CFDataRef
TYPEDEF: void* CFNumberRef
TYPEDEF: void* CFSetRef
TYPEDEF: int CFNumberType
CONSTANT: kCFNumberSInt8Type 1
CONSTANT: kCFNumberSInt16Type 2
CONSTANT: kCFNumberSInt32Type 3
CONSTANT: kCFNumberSInt64Type 4
CONSTANT: kCFNumberFloat32Type 5
CONSTANT: kCFNumberFloat64Type 6
CONSTANT: kCFNumberCharType 7
CONSTANT: kCFNumberShortType 8
CONSTANT: kCFNumberIntType 9
CONSTANT: kCFNumberLongType 10
CONSTANT: kCFNumberLongLongType 11
CONSTANT: kCFNumberFloatType 12
CONSTANT: kCFNumberDoubleType 13
CONSTANT: kCFNumberCFIndexType 14
CONSTANT: kCFNumberNSIntegerType 15
CONSTANT: kCFNumberCGFloatType 16
CONSTANT: kCFNumberMaxType 16
TYPEDEF: int CFPropertyListMutabilityOptions
CONSTANT: kCFPropertyListImmutable 0
CONSTANT: kCFPropertyListMutableContainers 1
CONSTANT: kCFPropertyListMutableContainersAndLeaves 2
FUNCTION: CFNumberRef CFNumberCreate ( CFAllocatorRef allocator, CFNumberType theType, void* valuePtr ) ;
FUNCTION: CFDataRef CFDataCreate ( CFAllocatorRef allocator, uchar* bytes, CFIndex length ) ;
FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ;
GENERIC: <CFNumber> ( number -- alien )
M: integer <CFNumber>
[ f kCFNumberLongLongType ] dip <longlong> CFNumberCreate ;
M: float <CFNumber>
[ f kCFNumberDoubleType ] dip <double> CFNumberCreate ;
M: t <CFNumber>
drop f kCFNumberIntType 1 <int> CFNumberCreate ;
M: f <CFNumber>
drop f kCFNumberIntType 0 <int> CFNumberCreate ;
: <CFData> ( byte-array -- alien )
[ f ] dip dup length CFDataCreate ;

1
basis/core-foundation/numbers/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

4
basis/core-foundation/numbers/numbers-tests.factor Normal file
View File

@ -0,0 +1,4 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test core-foundation.numbers ;
IN: core-foundation.numbers.tests

42
basis/core-foundation/numbers/numbers.factor Normal file
View File

@ -0,0 +1,42 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.syntax kernel math core-foundation ;
IN: core-foundation.numbers
TYPEDEF: void* CFNumberRef
TYPEDEF: int CFNumberType
CONSTANT: kCFNumberSInt8Type 1
CONSTANT: kCFNumberSInt16Type 2
CONSTANT: kCFNumberSInt32Type 3
CONSTANT: kCFNumberSInt64Type 4
CONSTANT: kCFNumberFloat32Type 5
CONSTANT: kCFNumberFloat64Type 6
CONSTANT: kCFNumberCharType 7
CONSTANT: kCFNumberShortType 8
CONSTANT: kCFNumberIntType 9
CONSTANT: kCFNumberLongType 10
CONSTANT: kCFNumberLongLongType 11
CONSTANT: kCFNumberFloatType 12
CONSTANT: kCFNumberDoubleType 13
CONSTANT: kCFNumberCFIndexType 14
CONSTANT: kCFNumberNSIntegerType 15
CONSTANT: kCFNumberCGFloatType 16
CONSTANT: kCFNumberMaxType 16
FUNCTION: CFNumberRef CFNumberCreate ( CFAllocatorRef allocator, CFNumberType theType, void* valuePtr ) ;
GENERIC: <CFNumber> ( number -- alien )
M: integer <CFNumber>
[ f kCFNumberLongLongType ] dip <longlong> CFNumberCreate ;
M: float <CFNumber>
[ f kCFNumberDoubleType ] dip <double> CFNumberCreate ;
M: t <CFNumber>
drop f kCFNumberIntType 1 <int> CFNumberCreate ;
M: f <CFNumber>
drop f kCFNumberIntType 0 <int> CFNumberCreate ;

1
basis/core-foundation/numbers/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

1
basis/core-foundation/utilities/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
basis/core-foundation/utilities/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

4
basis/core-foundation/utilities/utilities-tests.factor Normal file
View File

@ -0,0 +1,4 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test core-foundation.utilities ;
IN: core-foundation.utilities.tests

21
basis/core-foundation/utilities/utilities.factor Normal file
View File

@ -0,0 +1,21 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math assocs kernel sequences byte-arrays strings
hashtables alien destructors
core-foundation.numbers core-foundation.strings
core-foundation.arrays core-foundation.dictionaries
core-foundation.data core-foundation ;
IN: core-foundation.utilities
GENERIC: (>cf) ( obj -- cf )
M: number (>cf) <CFNumber> ;
M: t (>cf) <CFNumber> ;
M: f (>cf) <CFNumber> ;
M: string (>cf) <CFString> ;
M: byte-array (>cf) <CFData> ;
M: hashtable (>cf) [ [ (>cf) &CFRelease ] bi@ ] assoc-map <CFDictionary> ;
M: sequence (>cf) [ (>cf) &CFRelease ] map <CFArray> ;
M: alien (>cf) CFRetain ;
: >cf ( obj -- cf ) [ (>cf) ] with-destructors ;

26
basis/core-graphics/core-graphics.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.destructors alien.syntax
destructors fry kernel math sequences
destructors fry kernel math sequences libc
core-graphics.types ;
IN: core-graphics
@ -69,15 +69,25 @@ FUNCTION: void CGContextSetTextPosition (
FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;
: <CGBitmapContext> ( data dim -- context )
[
[ first2 8 ] keep first 4 *
FUNCTION: void* CGBitmapContextGetData ( CGContextRef c ) ;
<PRIVATE
: <CGBitmapContext> ( dim -- context )
[ product "uint" malloc-array &free ] [ first2 8 ] [ first 4 * ] tri
CGColorSpaceCreateDeviceRGB &CGColorSpaceRelease
kCGImageAlphaPremultipliedLast CGBitmapContextCreate
] with-destructors ;
[ "CGBitmapContextCreate failed" throw ] unless* ;
: bitmap-data ( bitmap dim -- data )
[ CGBitmapContextGetData ]
[ product "uint" heap-size * ] bi*
memory>byte-array ;
PRIVATE>
: with-bitmap-context ( dim quot -- data )
'[
[ product "uint" <c-array> ] keep
[ <CGBitmapContext> &CGContextRelease @ ] [ drop ] 2bi
[
[ [ <CGBitmapContext> &CGContextRelease ] keep ] dip
[ nip call ] [ drop bitmap-data ] 3bi
] with-destructors ; inline

4
basis/core-text/core-text-tests.factor
View File

@ -3,11 +3,11 @@
USING: tools.test core-text core-foundation
core-foundation.dictionaries destructors
arrays kernel generalizations math accessors
combinators ;
combinators hashtables ;
IN: core-text.tests
: test-font ( -- object )
"Helvetica" 12 <CTFont> ;
"Helvetica" kCTFontNameAttribute associate <CTFont> ;
[ ] [ test-font CFRelease ] unit-test

73
basis/core-text/core-text.factor
View File

@ -1,28 +1,16 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays alien alien.c-types alien.syntax kernel destructors words
parser accessors fry words hashtables sequences memoize
assocs math math.functions locals init
USING: arrays alien alien.c-types alien.syntax kernel
destructors words parser accessors fry words hashtables
sequences memoize assocs math math.functions locals init
core-foundation core-foundation.strings
core-foundation.attributed-strings
core-foundation.attributed-strings core-foundation.utilities
core-graphics core-graphics.types ;
IN: core-text
TYPEDEF: void* CTLineRef
TYPEDEF: void* CTFontRef
FUNCTION: CTFontRef CTFontCreateWithName (
CFStringRef name,
CGFloat size,
CGAffineTransform* matrix
) ;
: <CTFont> ( name size -- font )
[
[ <CFString> &CFRelease ] dip f CTFontCreateWithName
] with-destructors ;
MEMO: cached-font ( name size -- font ) <CTFont> ;
TYPEDEF: void* CTFontDescriptorRef
<<
@ -33,6 +21,52 @@ MEMO: cached-font ( name size -- font ) <CTFont> ;
>>
C-GLOBAL: kCTFontSymbolicTrait
C-GLOBAL: kCTFontWeightTrait
C-GLOBAL: kCTFontWidthTrait
C-GLOBAL: kCTFontSlantTrait
C-GLOBAL: kCTFontNameAttribute
C-GLOBAL: kCTFontDisplayNameAttribute
C-GLOBAL: kCTFontFamilyNameAttribute
C-GLOBAL: kCTFontStyleNameAttribute
C-GLOBAL: kCTFontTraitsAttribute
C-GLOBAL: kCTFontVariationAttribute
C-GLOBAL: kCTFontSizeAttribute
C-GLOBAL: kCTFontMatrixAttribute
C-GLOBAL: kCTFontCascadeListAttribute
C-GLOBAL: kCTFontCharacterSetAttribute
C-GLOBAL: kCTFontLanguagesAttribute
C-GLOBAL: kCTFontBaselineAdjustAttribute
C-GLOBAL: kCTFontMacintoshEncodingsAttribute
C-GLOBAL: kCTFontFeaturesAttribute
C-GLOBAL: kCTFontFeatureSettingsAttribute
C-GLOBAL: kCTFontFixedAdvanceAttribute
C-GLOBAL: kCTFontOrientationAttribute
FUNCTION: CTFontDescriptorRef CTFontDescriptorCreateWithAttributes (
CFDictionaryRef attributes
) ;
FUNCTION: CTFontRef CTFontCreateWithName (
CFStringRef name,
CGFloat size,
CGAffineTransform* matrix
) ;
FUNCTION: CTFontRef CTFontCreateWithFontDescriptor (
CTFontDescriptorRef descriptor,
CGFloat size,
CGAffineTransform* matrix
) ;
: <CTFont> ( attrs -- font )
[
>cf &CFRelease
CTFontDescriptorCreateWithAttributes &CFRelease
0.0 f CTFontCreateWithFontDescriptor
] with-destructors ;
C-GLOBAL: kCTFontAttributeName
C-GLOBAL: kCTKernAttributeName
C-GLOBAL: kCTLigatureAttributeName
@ -114,7 +148,4 @@ PRIVATE>
: cached-line ( string font -- line ) (cached-line) 0 >>age ;
[
\ cached-font reset-memoized
\ (cached-line) reset-memoized
] "core-text" add-init-hook
[ \ (cached-line) reset-memoized ] "core-text" add-init-hook

57
basis/ui/cocoa/text/text.factor
View File

@ -1,7 +1,10 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors alien core-graphics.types core-text kernel
namespaces sequences ui.gadgets.worlds ui.render opengl opengl.gl ;
hashtables namespaces sequences ui.gadgets.worlds ui.render
opengl opengl.gl destructors combinators combinators.smart
core-foundation core-foundation.dictionaries core-foundation.numbers
core-foundation.strings io.styles memoize ;
IN: ui.cocoa.text
SINGLETON: core-text-renderer
@ -13,13 +16,46 @@ CONSTANT: font-names
{ "serif" "Times" }
}
USING: classes.algebra unicode.case.private ;
: (bold) ( -- ) 1.0 kCTFontWeightTrait set ;
: font-name/size ( font -- name size )
[ first font-names at-default ] [ third ] bi ;
: (italic) ( -- ) 1.0 kCTFontSlantTrait set ;
: font-traits ( style -- dictionary )
[
{
{ plain [ ] }
{ bold [ (bold) ] }
{ italic [ (italic) ] }
{ bold-italic [ (bold) (italic) ] }
} case
] H{ } make-assoc ;
: font-name-attr ( name -- )
font-names at-default kCTFontNameAttribute set ;
: font-traits-attr ( style -- )
font-traits kCTFontTraitsAttribute set ;
: font-size-attr ( size -- )
kCTFontSizeAttribute set ;
: font-attrs ( font -- dictionary )
[
[
[
[ font-name-attr ]
[ font-traits-attr ]
[ font-size-attr ]
tri*
] input<sequence
] H{ } make-assoc
] with-destructors ;
MEMO: cache-font ( font -- open-font )
font-attrs <CTFont> ;
M: core-text-renderer open-font
dup alien? [ font-name/size cached-font ] unless ;
dup alien? [ cache-font ] unless ;
: string-dim ( open-font string -- dim )
swap cached-line dim>> ;
@ -30,11 +66,13 @@ M: core-text-renderer string-width ( open-font string -- w )
M: core-text-renderer string-height ( open-font string -- h )
[ " " ] when-empty string-dim second ;
TUPLE: line-texture line texture age ;
TUPLE: line-texture line texture age disposed ;
: <line-texture> ( line -- texture )
dup [ dim>> ] [ bitmap>> ] bi GL_RGBA make-texture
0 \ line-texture boa ;
0 f \ line-texture boa ;
M: line-texture dispose* texture>> delete-texture ;
: line-texture ( string open-font -- texture )
world get fonts>> [ cached-line <line-texture> ] 2cache ;
@ -55,6 +93,9 @@ M: core-text-renderer draw-string ( font string loc -- )
[ swap open-font line-texture draw-line-texture ] with-translation ;
M: core-text-renderer x>offset ( x font string -- n )
swap cached-line swap 0 <CGPoint> CTLineGetStringIndexForPosition ;
swap open-font cached-line line>> swap 0 <CGPoint> CTLineGetStringIndexForPosition ;
M: core-text-renderer free-fonts ( fonts -- )
values dispose-each ;
core-text-renderer font-renderer set-global

3
basis/ui/freetype/freetype.factor
View File

@ -41,8 +41,7 @@ M: font hashcode* drop font hashcode* ;
] bind ;
M: freetype-renderer free-fonts ( world -- )
[ handle>> select-gl-context ]
[ fonts>> [ nip second free-sprites ] assoc-each ] bi ;
values [ second free-sprites ] each ;
: ttf-name ( font style -- name )
2array H{

7
basis/ui/ui.factor
View File

@ -60,9 +60,12 @@ M: world graft*
[ f >>handle drop ] tri ;
: (ungraft-world) ( world -- )
[ free-fonts ]
{
[ handle>> select-gl-context ]
[ fonts>> free-fonts ]
[ hand-clicked close-global ]
[ hand-gadget close-global ] tri ;
[ hand-gadget close-global ]
} cleave ;
M: world ungraft*
[ (ungraft-world) ]