--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test cache ;
+IN: cache.tests
--- /dev/null
+! 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 ;
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 ;
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>
[ [ 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
\ No newline at end of file
+[ <cache-assoc> cached-lines set-global ] "core-text" add-init-hook
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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
--- /dev/null
+! 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 ;
\ No newline at end of file
active? focused?
glass
title status
-fonts handle
+text-handle handle
window-loc ;
: find-world ( gadget -- world/f ) [ world? ] find-parent ;
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 )
! 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 ] [
[ cached-line metrics>> ]
if-empty ;
-M: core-text-renderer free-fonts ( fonts -- )
- values dispose-each ;
-
core-text-renderer font-renderer set-global
\ No newline at end of file
SYMBOL: font-renderer
+HOOK: init-text-rendering font-renderer ( world -- )
+
HOOK: finish-text-rendering font-renderer ( world -- )
M: object finish-text-rendering drop ;
\ <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
] 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
] 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
[ ] [ "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." ;
[ 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
[ ] [ <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
[ ] [ "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
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
: 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 ;
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?
projects / factor.git / commitdiff