More work on Core Text binding

basis/cocoa/types/types-docs.factor

@@ -1,29 +0,0 @@
-USING: math help.markup help.syntax ;
-IN: cocoa.types
-
-HELP: <NSRect>
-{ $values { "x" real } { "y" real } { "w" real } { "h" real } { "rect" "an " { $snippet "NSRect" } } }
-{ $description "Allocates a new " { $snippet "NSRect" } " in the Factor heap." } ;
-
-HELP: <NSPoint>
-{ $values { "x" real } { "y" real } { "point" "an " { $snippet "NSPoint" } } }
-{ $description "Allocates a new " { $snippet "NSPoint" } " in the Factor heap." } ;
-
-HELP: <NSSize>
-{ $values { "w" real } { "h" real } { "size" "an " { $snippet "NSSize" } } }
-{ $description "Allocates a new " { $snippet "NSSize" } " in the Factor heap." } ;
-
-ARTICLE: "cocoa-types" "Cocoa types"
-"The Cocoa binding defines some common C structs:"
-{ $code
-    "NSRect"
-    "NSPoint"
-    "NSSize"
-}
-"Some words for working with the above:"
-{ $subsection <NSRect> }
-{ $subsection <NSPoint> }
-{ $subsection <NSSize> } ;
-
-IN: cocoa.types
-ABOUT: "cocoa-types"

basis/core-graphics/core-graphics-tests.factor

@@ -3,4 +3,4 @@
 USING: tools.test core-graphics kernel byte-arrays ;
 IN: core-graphics.tests
 
-[ t ] [ 100 200 [ drop ] with-bitmap-context byte-array? ] unit-test
+[ t ] [ { 100 200 } [ drop ] with-bitmap-context byte-array? ] unit-test

basis/core-graphics/core-graphics.factor

@@ -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 locals math sequences
+destructors fry kernel math sequences
 core-graphics.types ;
 IN: core-graphics
 
@@ -69,15 +69,15 @@ FUNCTION: void CGContextSetTextPosition (
 
 FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;
 
-:: <CGBitmapContext> ( data w h -- context )
+: <CGBitmapContext> ( data dim -- context )
     [
-        data w h 8 w 4 *
+        [ first2 8 ] keep first 4 *
         CGColorSpaceCreateDeviceRGB &CGColorSpaceRelease
         kCGImageAlphaPremultipliedLast CGBitmapContextCreate
     ] with-destructors ;
 
-: with-bitmap-context ( w h quot -- data )
+: with-bitmap-context ( dim quot -- data )
     '[
-        [ * "uint" <c-array> ] 2keep
+        [ product "uint" <c-array> ] keep
-        [ <CGBitmapContext> &CGContextRelease @ ] [ 2drop ] 3bi
+        [ <CGBitmapContext> &CGContextRelease @ ] [ drop ] 2bi
     ] with-destructors ; inline

basis/core-graphics/types/types.factor

@@ -8,6 +8,9 @@ IN: core-graphics.types
 : <CGFloat> ( x -- alien )
     cell 4 = [ <float> ] [ <double> ] if ; inline
 
+: *CGFloat ( alien -- x )
+    cell 4 = [ *float ] [ *double ] if ; inline
+
 C-STRUCT: CGPoint
     { "CGFloat" "x" }
     { "CGFloat" "y" } ;

basis/core-text/core-text-tests.factor

@@ -2,14 +2,33 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: tools.test core-text core-foundation
 core-foundation.dictionaries destructors
-arrays kernel ;
+arrays kernel generalizations math accessors
+combinators ;
 IN: core-text.tests
 
-[ ] [ "Helvetica" 12 <CTFont> CFRelease ] unit-test
+: test-font ( -- object )
+    "Helvetica" 12 <CTFont> ;
+
+[ ] [ test-font CFRelease ] unit-test
 
 [ ] [
     [
-        kCTFontAttributeName "Helvetica" 64 <CTFont> &CFRelease 2array 1array
+        kCTFontAttributeName test-font &CFRelease 2array 1array
         <CFDictionary> &CFRelease drop
     ] with-destructors
-] unit-test
+] unit-test
+
+: test-typographic-bounds ( string -- ? )
+    [
+        test-font &CFRelease <CTLine> &CFRelease
+        line-typographic-bounds {
+            [ width>> float? ]
+            [ ascent>> float? ]
+            [ descent>> float? ]
+            [ leading>> float? ]
+        } cleave and and and
+    ] with-destructors ;
+
+[ t ] [ "Hello world" test-typographic-bounds ] unit-test
+
+[ t ] [ "日本語" test-typographic-bounds ] unit-test

basis/core-text/core-text.factor

@@ -1,9 +1,10 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.syntax kernel destructors
+USING: arrays alien alien.c-types alien.syntax kernel destructors
-parser accessors fry words
+parser accessors fry words hashtables sequences math math.functions locals
 core-foundation core-foundation.strings
-core-foundation.attributed-strings ;
+core-foundation.attributed-strings
+core-graphics core-graphics.types ;
 IN: core-text
 
 TYPEDEF: void* CTLineRef
@@ -49,3 +50,42 @@ FUNCTION: CFIndex CTLineGetStringIndexForPosition ( CTLineRef line, CGPoint posi
 FUNCTION: double CTLineGetTypographicBounds ( CTLineRef line, CGFloat* ascent, CGFloat* descent, CGFloat* leading ) ;
 
 FUNCTION: CGRect CTLineGetImageBounds ( CTLineRef line, CGContextRef context ) ;
+
+: <CTLine> ( string font -- line )
+    [
+        kCTFontAttributeName associate <CFAttributedString> &CFRelease
+        CTLineCreateWithAttributedString
+    ] with-destructors ;
+
+TUPLE: typographic-bounds width ascent descent leading ;
+
+: line-typographic-bounds ( line -- typographic-bounds )
+    0 <CGFloat> 0 <CGFloat> 0 <CGFloat>
+    [ CTLineGetTypographicBounds ] 3keep [ *CGFloat ] tri@
+    typographic-bounds boa ;
+
+TUPLE: line string font line bounds dim bitmap disposed ;
+
+: bounds>dim ( bounds -- dim )
+    [ width>> ] [ [ ascent>> ] [ descent>> ] bi + ] bi
+    [ ceiling >fixnum ]
+    bi@ 2array ;
+
+:: draw-line ( line bounds context -- )
+    context 0.0 bounds descent>> CGContextSetTextPosition
+    line context CTLineDraw ;
+
+: <line> ( string font -- line )
+    [
+        CFRetain |CFRelease
+        2dup <CTLine> |CFRelease
+        dup line-typographic-bounds
+        dup bounds>dim 3dup [ draw-line ] with-bitmap-context
+        f line boa
+    ] with-destructors ;
+
+M: line dispose*
+    [
+        [ font>> &CFRelease drop ]
+        [ line>> &CFRelease drop ] bi
+    ] with-destructors ;