USING: tools.test core-graphics kernel images ;
IN: core-graphics.tests
-[ t ] [ { 100 200 } [ drop ] make-bitmap-image image? ] unit-test
\ No newline at end of file
+[ t ] [ { 100 200 } [ drop ] make-bitmap-image image? ] unit-test
+
+[ ] [ dummy-context drop ] unit-test
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.destructors alien.syntax accessors
+USING: alien alien.c-types alien.destructors alien.syntax accessors
destructors fry kernel math math.bitwise sequences libc colors
images core-graphics.types core-foundation.utilities ;
IN: core-graphics
: bitmap-color-space ( -- color-space )
CGColorSpaceCreateDeviceRGB &CGColorSpaceRelease ;
-: <CGBitmapContext> ( dim -- context )
- [ malloc-bitmap-data ] [ first2 8 ] [ first 4 * ] tri
+: <CGBitmapContext> ( data dim -- context )
+ [ first2 8 ] [ first 4 * ] bi
bitmap-color-space bitmap-flags CGBitmapContextCreate
[ "CGBitmapContextCreate failed" throw ] unless* ;
PRIVATE>
+: dummy-context ( -- context )
+ \ dummy-context [
+ [ 4 malloc { 1 1 } <CGBitmapContext> ] with-destructors
+ ] initialize-alien ;
+
: make-bitmap-image ( dim quot -- image )
[
- [ [ <CGBitmapContext> &CGContextRelease ] keep ] dip
+ [ [ [ malloc-bitmap-data ] keep <CGBitmapContext> &CGContextRelease ] keep ] dip
[ nip call ] [ drop [ bitmap-data ] keep <bitmap-image> ] 3bi
] with-destructors ; inline
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax kernel layouts math ;
+USING: alien.c-types alien.syntax kernel layouts
+math math.rectangles arrays ;
IN: core-graphics.types
<< cell 4 = "float" "double" ? "CGFloat" typedef >>
{ "CGPoint" "origin" }
{ "CGSize" "size" } ;
+: CGPoint>loc ( CGPoint -- loc )
+ [ CGPoint-x ] [ CGPoint-y ] bi 2array ;
+
+: CGSize>dim ( CGSize -- dim )
+ [ CGSize-w ] [ CGSize-h ] bi 2array ;
+
+: CGRect>rect ( CGRect -- rect )
+ [ CGRect-origin CGPoint>loc ]
+ [ CGRect-size CGSize>dim ]
+ bi <rect> ; inline
+
: CGRect-x ( CGRect -- x )
CGRect-origin CGPoint-x ; inline
: CGRect-y ( CGRect -- y )
! See http://factorcode.org/license.txt for BSD license.
USING: arrays alien alien.c-types alien.syntax kernel destructors
accessors fry words hashtables strings sequences memoize assocs math
-math.functions locals init namespaces combinators fonts colors cache
-core-foundation core-foundation.strings core-foundation.attributed-strings
-core-foundation.utilities core-graphics core-graphics.types
-core-text.fonts core-text.utilities ;
+math.vectors math.rectangles math.functions locals init namespaces
+combinators fonts colors cache core-foundation core-foundation.strings
+core-foundation.attributed-strings core-foundation.utilities
+core-graphics core-graphics.types core-text.fonts core-text.utilities ;
IN: core-text
TYPEDEF: void* CTLineRef
CTLineCreateWithAttributedString
] with-destructors ;
-TUPLE: line font line metrics image disposed ;
+TUPLE: line font line metrics image loc dim disposed ;
: compute-line-metrics ( open-font line -- line-metrics )
[
} spread
dup compute-height ;
-: bounds>dim ( bounds -- dim )
+: metrics>dim ( bounds -- dim )
[ width>> ] [ [ ascent>> ] [ descent>> ] bi + ] bi
[ ceiling >integer ]
bi@ 2array ;
[ f CTLineGetOffsetForStringIndex round ] bi-curry@ bi
[ drop nip 0 ] [ swap - swap second ] 3bi <CGRect> ;
-:: fill-selection-background ( context dim line string -- )
+:: fill-selection-background ( context loc dim line string -- )
string selection? [
context string color>> >rgba-components CGContextSetRGBFillColor
- context dim line string selection-rect CGContextFillRect
+ context dim line string selection-rect
+ dup CGRect-x loc first - over set-CGRect-x
+ CGContextFillRect
] when ;
-: set-text-position ( context metrics -- )
- [ 0 ] dip descent>> ceiling CGContextSetTextPosition ;
+: line-rect ( line -- rect )
+ dummy-context CTLineGetImageBounds ;
+
+: set-text-position ( context loc -- )
+ first2 [ neg ] bi@ CGContextSetTextPosition ;
+
+:: line-loc ( metrics loc dim -- loc )
+ loc first
+ metrics ascent>> ceiling dim second loc second + - 2array ;
:: <line> ( font string -- line )
[
[let* | open-font [ font cache-font CFRetain |CFRelease ]
line [ string open-font font foreground>> <CTLine> |CFRelease ]
- metrics [ open-font line compute-line-metrics ]
- dim [ metrics bounds>dim ] |
+
+ rect [ line line-rect ]
+ (loc) [ rect CGRect-origin CGPoint>loc ]
+ (dim) [ rect CGRect-size CGSize>dim ]
+ (ext) [ (loc) (dim) v+ ]
+ loc [ (loc) [ floor ] map ]
+ ext [ (loc) (dim) [ + ceiling ] 2map ]
+ dim [ ext loc [ - >integer ] 2map ]
+ metrics [ open-font line compute-line-metrics ] |
open-font line metrics
dim [
{
[ font dim fill-background ]
- [ dim line string fill-selection-background ]
- [ metrics set-text-position ]
+ [ loc dim line string fill-selection-background ]
+ [ loc set-text-position ]
[ [ line ] dip CTLineDraw ]
} cleave
] make-bitmap-image
+ metrics loc dim line-loc
+ metrics metrics>dim
]
f line boa
] with-destructors ;
: delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ;
-TUPLE: texture texture-coords texture display-list disposed ;
+TUPLE: texture loc dim texture-coords texture display-list disposed ;
<PRIVATE
GL_TEXTURE_BIT [
GL_TEXTURE_COORD_ARRAY [
COLOR: white gl-color
- [ [ GL_TEXTURE_2D ] dip texture>> glBindTexture ]
- [ init-texture texture-coords>> gl-texture-coord-pointer ] bi
- fill-rect-vertices (gl-fill-rect)
- GL_TEXTURE_2D 0 glBindTexture
+ dup loc>> [
+ [ [ GL_TEXTURE_2D ] dip texture>> glBindTexture ]
+ [ init-texture texture-coords>> gl-texture-coord-pointer ] bi
+ fill-rect-vertices (gl-fill-rect)
+ GL_TEXTURE_2D 0 glBindTexture
+ ] with-translation
] do-enabled-client-state
] do-attribs
] do-enabled ;
{ { 0 0 } { 1 0 } { 1 1 } { 0 1 } } [ v* ] with map
float-array{ } join ;
-: make-texture-display-list ( dim texture -- dlist )
- GL_COMPILE [ draw-textured-rect ] make-dlist ;
+: make-texture-display-list ( texture -- dlist )
+ GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ;
PRIVATE>
-: <texture> ( image -- texture )
- dup dim>> { 0 0 } = [ drop texture new ] [
- [ dim>> ]
- [ dim>> texture-coords ]
- [ power-of-2-image make-texture ] tri
- f f texture boa
- [ nip ] [ make-texture-display-list ] 2bi >>display-list
- ] if ;
+: <texture> ( image loc -- texture )
+ texture new swap >>loc
+ swap
+ [ dim>> >>dim ] keep
+ [ dim>> { 0 0 } = ] keep '[
+ _
+ [ dim>> texture-coords >>texture-coords ]
+ [ power-of-2-image make-texture >>texture ] bi
+ dup make-texture-display-list >>display-list
+ ] unless ;
M: texture dispose*
[ texture>> [ delete-texture ] when* ]
'[ [ _ _ ] keep _ start/end-on-line 2array ] H{ } map>assoc
] [ drop f ] if ;
-:: draw-empty-selection ( line pair editor -- )
- editor font>> :> font
- pair first font line offset>x 0 2array [
+:: draw-selection ( line pair editor -- )
+ pair [ editor font>> line offset>x ] map :> pair
+ pair first 0 2array [
editor selection-color>> gl-color
- 1 font font-metrics height>> 2array gl-fill-rect
+ pair second pair first - round 1 max
+ editor line-height 2array gl-fill-rect
] with-translation ;
: draw-unselected-line ( line editor -- )
: draw-selected-line ( line pair editor -- )
over all-equal? [
- [ nip draw-unselected-line ] [ draw-empty-selection ] 3bi
+ [ nip draw-unselected-line ] [ draw-selection ] 3bi
] [
- [ [ first2 ] [ selection-color>> ] bi* <selection> ] keep
- draw-unselected-line
+ [ draw-selection ]
+ [
+ [ [ first2 ] [ selection-color>> ] bi* <selection> ] keep
+ draw-unselected-line
+ ] 3bi
] if ;
M: editor draw-line ( line index editor -- )
] with-variable ;
M: editor pref-dim*
- [ font>> ] [ control-value ] bi text-dim ;
+ ! Add some space for the caret.
+ [ font>> ] [ control-value ] bi text-dim { 1 0 } v+ ;
M: editor baseline font>> font-metrics ascent>> ;
GENERIC: line-height ( gadget -- n )
-M: line-gadget line-height font>> font-metrics height>> ;
+M: line-gadget line-height font>> font-metrics height>> ceiling ;
: y>line ( y gadget -- n ) line-height /i ;
: apply-image-style ( style gadget -- style gadget )
image [ nip <image-name> <icon> ] apply-style ;
+: apply-background-style ( style gadget -- style gadget )
+ background [ <solid> >>interior ] apply-style ;
+
: style-label ( style gadget -- gadget )
apply-font-style
+ apply-background-style
apply-presentation-style
apply-image-style
nip ; inline
PRIVATE>
: rendered-image ( path -- texture )
- world get image-texture-cache [ cached-image <texture> ] cache ;
+ world get image-texture-cache
+ [ cached-image { 0 0 } <texture> ] cache ;
: draw-image ( image-name -- )
rendered-image draw-texture ;
M: core-text-renderer string-dim
[ " " string-dim { 0 1 } v* ]
- [ cached-line image>> dim>> ]
+ [ cached-line dim>> ]
if-empty ;
M: core-text-renderer finish-text-rendering
: rendered-line ( font string -- texture )
world get text-handle>>
- [ cached-line image>> <texture> ]
+ [ cached-line [ image>> ] [ loc>> ] bi <texture> ]
2cache ;
M: core-text-renderer draw-string ( font string -- )