diff --git a/basis/core-text/core-text.factor b/basis/core-text/core-text.factor index 50b40388f3..8db624b28f 100644 --- a/basis/core-text/core-text.factor +++ b/basis/core-text/core-text.factor @@ -114,7 +114,7 @@ TUPLE: typographic-bounds width ascent descent leading ; [ CTLineGetTypographicBounds ] 3keep [ *CGFloat ] tri@ typographic-bounds boa ; -TUPLE: line string font line bounds dim bitmap age disposed ; +TUPLE: line string font line bounds dim bitmap age refs disposed ; : bounds>dim ( bounds -- dim ) [ width>> ] [ [ ascent>> ] [ descent>> ] bi + ] bi @@ -131,31 +131,36 @@ TUPLE: line string font line bounds dim bitmap age disposed ; 2dup white |CFRelease dup line-typographic-bounds dup bounds>dim 3dup [ draw-line ] with-bitmap-context - 0 f line boa + 0 0 f line boa ] with-destructors ; -M: line dispose* - [ font>> ] [ line>> ] bi 2array dispose-each ; +M: line dispose* line>> CFRelease ; ->age drop ; -MEMO: (cached-line) ( string font -- line ) ; +: ref-line ( line -- ) 1 ref/unref-line ; +: unref-line ( line -- ) -1 ref/unref-line ; -: cached-lines ( -- assoc ) - \ (cached-line) "memoize" word-prop ; +SYMBOL: cached-lines -: set-cached-lines ( assoc -- ) - \ (cached-line) "memoize" set-word-prop ; +: cached-line ( string font -- line ) + cached-lines get [ ] 2cache ; CONSTANT: max-line-age 5 -PRIVATE> +: 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 ; : age-lines ( -- ) - cached-lines - [ nip [ 1+ ] change-age age>> max-line-age <= ] assoc-filter - set-cached-lines ; + cached-lines global [ [ age-line ] age-assoc ] change-at ; -: cached-line ( string font -- line ) (cached-line) 0 >>age ; - -[ \ (cached-line) reset-memoized ] "core-text" add-init-hook \ No newline at end of file +[ H{ } clone cached-lines set-global ] "core-text" add-init-hook \ No newline at end of file diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 732a438203..2ce5fec4f6 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs continuations kernel math models -namespaces opengl sequences io combinators fry math.vectors -ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks -math.geometry.rect ; +namespaces opengl sequences io combinators combinators.short-circuit +fry math.vectors ui.gadgets ui.gestures ui.render ui.text ui.text.private +ui.backend ui.gadgets.tracks math.geometry.rect ; IN: ui.gadgets.worlds TUPLE: world < track @@ -54,9 +54,7 @@ M: world request-focus-on ( child gadget -- ) M: world layout* dup call-next-method - dup glass>> [ - [ dup rect-dim ] dip (>>dim) - ] when* drop ; + dup glass>> dup [ swap dim>> >>dim drop ] [ 2drop ] if ; M: world focusable-child* gadget-child ; @@ -64,13 +62,13 @@ M: world children-on nip children>> ; : (draw-world) ( world -- ) dup handle>> [ - [ dup init-gl ] keep draw-gadget + [ init-gl ] [ draw-gadget ] [ finish-text-rendering ] tri ] with-gl-context ; : draw-world? ( world -- ? ) #! We don't draw deactivated worlds, or those with 0 size. #! On Windows, the latter case results in GL errors. - [ active?>> ] [ handle>> ] [ dim>> [ 0 > ] all? ] tri and and ; + { [ active?>> ] [ handle>> ] [ dim>> [ 0 > ] all? ] } 1&& ; TUPLE: world-error error world ; @@ -86,16 +84,12 @@ ui-error-hook global [ [ rethrow ] or ] change-at : draw-world ( world -- ) dup draw-world? [ dup world [ - [ - (draw-world) - ] [ + [ (draw-world) ] [ over ui-error f >>active? drop ] recover ] with-variable - ] [ - drop - ] if ; + ] [ drop ] if ; world H{ { T{ key-down f { C+ } "x" } [ T{ cut-action } send-action ] } diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor index 57d0d44272..e755f9782b 100755 --- a/basis/ui/render/render.factor +++ b/basis/ui/render/render.factor @@ -18,17 +18,19 @@ SYMBOL: viewport-translation : do-clip ( -- ) clip get flip-rect gl-set-clip ; -: init-clip ( clip-rect rect -- ) - GL_SCISSOR_TEST glEnable - [ rect-intersect ] keep - dim>> dup { 0 1 } v* viewport-translation set - { 0 0 } over gl-viewport - 0 swap first2 0 gluOrtho2D - clip set +: init-clip ( clip-rect -- ) + [ + dim>> + [ { 0 1 } v* viewport-translation set ] + [ [ { 0 0 } ] dip gl-viewport ] + [ [ 0 ] dip first2 0 gluOrtho2D ] tri + ] + [ clip set ] bi do-clip ; -: init-gl ( clip-rect rect -- ) +: init-gl ( clip-rect -- ) GL_SMOOTH glShadeModel + GL_SCISSOR_TEST glEnable GL_BLEND glEnable GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc GL_VERTEX_ARRAY glEnableClientState diff --git a/basis/ui/text/core-text/core-text.factor b/basis/ui/text/core-text/core-text.factor index 8b06793e89..2969986ff3 100644 --- a/basis/ui/text/core-text/core-text.factor +++ b/basis/ui/text/core-text/core-text.factor @@ -51,13 +51,24 @@ M: core-text-renderer string-dim TUPLE: line-texture line texture age disposed ; : ( line -- texture ) - dup [ dim>> ] [ bitmap>> ] bi GL_RGBA make-texture - 0 f \ line-texture boa ; + #! Note: we only ref-line if make-texture succeeds + [ + dup [ dim>> ] [ bitmap>> ] bi GL_RGBA make-texture + 0 f \ line-texture boa + ] keep ref-line ; -M: line-texture dispose* texture>> delete-texture ; +M: line-texture dispose* + [ line>> unref-line ] + [ texture>> delete-texture ] bi ; : line-texture ( string open-font -- texture ) - world get fonts>> [ cached-line ] 2cache ; + world get fonts>> [ cached-line ] 2cache 0 >>age ; + +: age-line-textures ( world -- ) + [ [ age ] age-assoc ] change-fonts drop ; + +M: core-text-renderer finish-text-rendering + age-line-textures age-lines ; : draw-line-texture ( line-texture -- ) GL_TEXTURE_2D [ diff --git a/basis/ui/text/text.factor b/basis/ui/text/text.factor index 1464ab2cf2..452344ef8e 100644 --- a/basis/ui/text/text.factor +++ b/basis/ui/text/text.factor @@ -11,6 +11,10 @@ TUPLE: font name size bold? italic? ; SYMBOL: font-renderer +HOOK: finish-text-rendering font-renderer ( world -- ) + +M: object finish-text-rendering drop ; + HOOK: open-font font-renderer ( font -- open-font ) HOOK: string-dim font-renderer ( open-font string -- dim )