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

Clean up Core Text rendering code, and factor our basis/cache and basis/opengl/texture-cache

db4
Slava Pestov 2009-02-10 02:45:43 -06:00
parent 6235e95052
commit 5be7a6777b
12 changed files with 142 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
basis/cache/authors.txt vendored Normal file
View File

@ -0,0 +1 @@
Slava Pestov

4
basis/cache/cache-tests.factor vendored 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 cache ;
IN: cache.tests

36
basis/cache/cache.factor vendored Normal file
View File

@ -0,0 +1,36 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs math accessors destructors fry ;
IN: cache
SLOT: age
GENERIC: age ( obj -- )
M: object age [ 1+ ] change-age drop ;
TUPLE: cache-assoc assoc max-age disposed ;
: <cache-assoc> ( -- cache )
H{ } clone 10 f cache-assoc boa ;
M: cache-assoc assoc-size assoc>> assoc-size ;
M: cache-assoc at* assoc>> at* [ dup [ 0 >>age ] when ] dip ;
M: cache-assoc set-at dup check-disposed assoc>> set-at ;
M: cache-assoc clear-assoc assoc>> clear-assoc ;
M: cache-assoc >alist assoc>> >alist ;
INSTANCE: cache-assoc assoc
: purge-cache ( cache -- )
dup max-age>> '[
[ nip dup age age>> _ >= ] assoc-partition
[ values dispose-each ] dip
] change-assoc drop ;
M: cache-assoc dispose*
assoc>> [ values dispose-each ] [ clear-assoc ] bi ;

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

@ -3,7 +3,7 @@
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 core-foundation
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 ;
@ -47,7 +47,7 @@ ERROR: not-a-string object ;
CTLineCreateWithAttributedString
] with-destructors ;
TUPLE: line font line metrics dim bitmap age refs disposed ;
TUPLE: line font line metrics dim bitmap age disposed ;
: compute-line-metrics ( line -- line-metrics )
0 <CGFloat> 0 <CGFloat> 0 <CGFloat>
@ -92,38 +92,16 @@ TUPLE: line font line metrics dim bitmap age refs disposed ;
[ [ line ] dip CTLineDraw ]
} cleave
] with-bitmap-context
[ open-font line metrics dim ] dip 0 0 f
[ open-font line metrics dim ] dip 0 f
]
line boa
] with-destructors ;
M: line dispose* [ font>> CFRelease ] [ line>> CFRelease ] bi ;
: ref/unref-line ( line n -- )
'[ _ + ] change-refs 0 >>age drop ;
: ref-line ( line -- ) 1 ref/unref-line ;
: unref-line ( line -- ) -1 ref/unref-line ;
SYMBOL: cached-lines
: cached-line ( font string -- line )
cached-lines get [ <line> ] 2cache ;
CONSTANT: max-line-age 10
: age ( obj -- ? )
[ 1+ ] change-age age>> max-line-age >= ;
: age-line ( line -- ? )
#! Outputs t whether the line is dead.
dup refs>> 0 = [ age ] [ drop f ] if ;
: age-assoc ( assoc quot -- assoc' )
'[ nip @ ] assoc-partition
[ values dispose-each ] dip ; inline
: age-lines ( -- )
cached-lines global [ [ age-line ] age-assoc ] change-at ;
[ H{ } clone cached-lines set-global ] "core-text" add-init-hook
[ <cache-assoc> cached-lines set-global ] "core-text" add-init-hook

1
basis/opengl/texture-cache/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

4
basis/opengl/texture-cache/texture-cache-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 opengl.texture-cache ;
IN: opengl.texture-cache.tests

56
basis/opengl/texture-cache/texture-cache.factor Normal file
View File

@ -0,0 +1,56 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs cache colors.constants destructors fry
kernel locals opengl opengl.gl ;
IN: opengl.texture-cache
TUPLE: texture texture display-list age disposed ;
: make-texture-display-list ( dim texture -- dlist )
GL_COMPILE [
GL_TEXTURE_2D [
GL_TEXTURE_BIT [
GL_TEXTURE_COORD_ARRAY [
COLOR: white gl-color
GL_TEXTURE_2D swap glBindTexture
init-texture rect-texture-coords
fill-rect-vertices (gl-fill-rect)
GL_TEXTURE_2D 0 glBindTexture
] do-enabled-client-state
] do-attribs
] do-enabled
] make-dlist ;
:: <texture> ( dim bitmap format type -- texture )
dim bitmap format type make-texture
dim over make-texture-display-list 0 f texture boa ;
M: texture dispose*
[ texture>> delete-texture ]
[ display-list>> delete-dlist ] bi ;
TUPLE: texture-cache format type renderer cache disposed ;
: <texture-cache> ( -- cache )
texture-cache new
<cache-assoc> >>cache ;
GENERIC: render-texture ( key renderer -- dim bitmap )
: get-texture ( key texture-cache -- dlist )
dup check-disposed
[ cache>> ] keep
'[
_
[ renderer>> render-texture ]
[ format>> ]
[ type>> ]
tri <texture>
] cache
display-list>> ;
M: texture-cache dispose*
cache>> values dispose-each ;
: purge-texture-cache ( texture-cache -- )
cache>> purge-cache ;

4
basis/ui/gadgets/worlds/worlds.factor
View File

@ -10,7 +10,7 @@ TUPLE: world < track
active? focused?
glass
title status
fonts handle
text-handle handle
window-loc ;
: find-world ( gadget -- world/f ) [ world? ] find-parent ;
@ -42,11 +42,11 @@ M: world request-focus-on ( child gadget -- )
vertical swap new-track
t >>root?
t >>active?
H{ } clone >>fonts
{ 0 0 } >>window-loc
swap >>status
swap >>title
swap 1 track-add
dup init-text-rendering
dup request-focus ;
: <world> ( gadget title status -- world )

69
basis/ui/text/core-text/core-text.factor
View File

@ -2,64 +2,36 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors alien core-graphics.types core-text
core-text.fonts kernel hashtables namespaces sequences
ui.gadgets.worlds ui.text ui.text.private opengl opengl.gl destructors
combinators core-foundation core-foundation.strings memoize math
math.vectors init colors colors.constants ;
ui.gadgets.worlds ui.text ui.text.private opengl opengl.gl
opengl.texture-cache destructors combinators core-foundation
core-foundation.strings math math.vectors init colors colors.constants
cache arrays ;
IN: ui.text.core-text
SINGLETON: core-text-renderer
M: core-text-renderer init-text-rendering
<texture-cache>
GL_BGRA_EXT >>format
GL_UNSIGNED_INT_8_8_8_8_REV >>type
core-text-renderer >>renderer
>>text-handle drop ;
M: core-text-renderer string-dim
[ " " string-dim { 0 1 } v* ] [ cached-line dim>> ] if-empty ;
TUPLE: rendered-line line texture display-list age disposed ;
: make-line-display-list ( line texture -- dlist )
GL_COMPILE [
GL_TEXTURE_2D [
GL_TEXTURE_BIT [
GL_TEXTURE_COORD_ARRAY [
COLOR: white gl-color
GL_TEXTURE_2D swap glBindTexture
init-texture rect-texture-coords
dim>> fill-rect-vertices (gl-fill-rect)
GL_TEXTURE_2D 0 glBindTexture
] do-enabled-client-state
] do-attribs
] do-enabled
] make-dlist ;
: make-core-graphics-texture ( dim bitmap -- texture )
GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV make-texture ;
: <rendered-line> ( line -- texture )
#! Note: we only ref-line if make-texture and make-line-display-list
#! succeed
[
dup [ dim>> ] [ bitmap>> ] bi make-core-graphics-texture
2dup make-line-display-list
0 f \ rendered-line boa
] keep ref-line ;
M: rendered-line dispose*
[ line>> unref-line ]
[ texture>> delete-texture ]
[ display-list>> delete-dlist ] tri ;
: rendered-line ( font string -- rendered-line )
world get fonts>>
[ cached-line <rendered-line> ] 2cache 0 >>age ;
: age-rendered-lines ( world -- )
[ [ age ] age-assoc ] change-fonts drop ;
M: core-text-renderer render-texture
drop first2 cached-line [ dim>> ] [ bitmap>> ] bi ;
M: core-text-renderer finish-text-rendering
age-rendered-lines age-lines ;
text-handle>> purge-texture-cache
cached-lines get purge-cache ;
: rendered-line ( font string -- display-list )
2array world get text-handle>> get-texture ;
M: core-text-renderer draw-string ( font string loc -- )
[
rendered-line display-list>> glCallList
] with-translation ;
[ rendered-line glCallList ] with-translation ;
M: core-text-renderer x>offset ( x font string -- n )
[ 2drop 0 ] [
@ -76,7 +48,4 @@ M: core-text-renderer line-metrics ( font string -- metrics )
[ cached-line metrics>> ]
if-empty ;
M: core-text-renderer free-fonts ( fonts -- )
values dispose-each ;
core-text-renderer font-renderer set-global

2
basis/ui/text/text.factor
View File

@ -8,6 +8,8 @@ IN: ui.text
SYMBOL: font-renderer
HOOK: init-text-rendering font-renderer ( world -- )
HOOK: finish-text-rendering font-renderer ( world -- )
M: object finish-text-rendering drop ;

14
basis/ui/tools/listener/listener-tests.factor
View File

@ -9,7 +9,7 @@ IN: ui.tools.listener.tests
\ <interactor> must-infer
[
[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
[ ] [ <interactor> <pane> <pane-stream> >>output "interactor" set ] unit-test
[ ] [ "interactor" get register-self ] unit-test
@ -35,7 +35,7 @@ IN: ui.tools.listener.tests
] with-interactive-vocabs
[
[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
[ ] [ <interactor> <pane> <pane-stream> >>output "interactor" set ] unit-test
[ ] [ "interactor" get register-self ] unit-test
@ -56,7 +56,7 @@ IN: ui.tools.listener.tests
] with-interactive-vocabs
! Hang
[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
[ ] [ <interactor> <pane> <pane-stream> >>output "interactor" set ] unit-test
[ ] [ [ "interactor" get stream-read-quot drop ] "A" spawn drop ] unit-test
@ -66,7 +66,7 @@ IN: ui.tools.listener.tests
[ ] [ "interactor" get interactor-eof ] unit-test
[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
[ ] [ <interactor> <pane> <pane-stream> >>output "interactor" set ] unit-test
: text "Hello world.\nThis is a test." ;
@ -91,7 +91,7 @@ IN: ui.tools.listener.tests
[ t ] [ "promise" get 2 seconds ?promise-timeout text = ] unit-test
[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
[ ] [ <interactor> <pane> <pane-stream> >>output "interactor" set ] unit-test
[ ] [ text "interactor" get set-editor-string ] unit-test
@ -115,7 +115,7 @@ IN: ui.tools.listener.tests
[ ] [ <listener-gadget> "listener" set ] unit-test
"listener" get [
<pane> <interactor> "i" set
<interactor> <pane> <pane-stream> >>output "i" set
[ t ] [ "i" get interactor? ] unit-test
@ -148,7 +148,7 @@ IN: ui.tools.listener.tests
[ ] [ "listener" get com-end ] unit-test
] with-grafted-gadget
[ ] [ \ + <pane> <interactor> vocabs>> use-if-necessary ] unit-test
[ ] [ \ + <interactor> vocabs>> use-if-necessary ] unit-test
[ ] [ <listener-gadget> "l" set ] unit-test
[ ] [ "l" get com-scroll-up ] unit-test

13
basis/ui/ui.factor
View File

@ -3,8 +3,9 @@
USING: arrays assocs io kernel math models namespaces make dlists
deques sequences threads sequences words continuations init call
combinators hashtables concurrency.flags sets accessors calendar fry
ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gadgets.tracks
ui.gestures ui.backend ui.render ui.text ui.text.private ;
destructors ui.gadgets ui.gadgets.private ui.gadgets.worlds
ui.gadgets.tracks ui.gestures ui.backend ui.render ui.text
ui.text.private ;
IN: ui
! Assoc mapping aliens to gadgets
@ -55,14 +56,12 @@ M: world graft*
: reset-world ( world -- )
#! This is used when a window is being closed, but also
#! when restoring saved worlds on image startup.
[ fonts>> clear-assoc ]
[ unfocus-world ]
[ f >>handle drop ] tri ;
f >>handle unfocus-world ;
: (ungraft-world) ( world -- )
{
[ handle>> select-gl-context ]
[ fonts>> free-fonts ]
[ text-handle>> dispose ]
[ hand-clicked close-global ]
[ hand-gadget close-global ]
} cleave ;
@ -95,7 +94,7 @@ M: world ungraft*
children>> [ restore-gadget ] each ;
: restore-world ( world -- )
dup reset-world restore-gadget ;
[ reset-world ] [ init-text-rendering ] [ restore-gadget ] tri ;
: update-hand ( world -- )
dup hand-world get-global eq?