Merge branch 'master' of factorcode.org:/git/factor
Eduardo Cavazos
commit
993d90c767
|
|
@ -485,3 +485,5 @@ must-fail-with
|
|||
[ t ] [ "staging-problem-test-1" "parser.tests" lookup >boolean ] unit-test
|
||||
|
||||
[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
|
||||
|
||||
[ "DEFER: blah" eval ] [ error>> no-current-vocab? ] must-fail-with
|
||||
|
|
|
|||
|
|
@ -236,7 +236,7 @@ PREDICATE: unexpected-eof < unexpected
|
|||
ERROR: no-current-vocab ;
|
||||
|
||||
M: no-current-vocab summary ( obj -- )
|
||||
drop "Current vocabulary is f, use IN:" ;
|
||||
drop "Not in a vocabulary; IN: form required" ;
|
||||
|
||||
: current-vocab ( -- str )
|
||||
in get [ no-current-vocab ] unless* ;
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@ HELP: adjoin
|
|||
{ $description "Removes all elements equal to " { $snippet "elt" } ", and adds " { $snippet "elt" } " at the end of the sequence." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: namespaces prettyprint sequences ;"
|
||||
"USING: namespaces prettyprint sets ;"
|
||||
"V{ \"beans\" \"salsa\" \"cheese\" } \"v\" set"
|
||||
"\"nachos\" \"v\" get adjoin"
|
||||
"\"salsa\" \"v\" get adjoin"
|
||||
|
|
|
|||
|
|
@ -100,7 +100,7 @@ IN: bootstrap.syntax
|
|||
] define-syntax
|
||||
|
||||
"DEFER:" [
|
||||
scan in get create
|
||||
scan current-vocab create
|
||||
dup old-definitions get [ delete-at ] with each
|
||||
set-word
|
||||
] define-syntax
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
IN: html.components.tests
|
||||
USING: tools.test kernel io.streams.string
|
||||
io.streams.null accessors inspector html.streams
|
||||
html.components ;
|
||||
html.components namespaces ;
|
||||
|
||||
[ ] [ blank-values ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -203,9 +203,7 @@ TUPLE: sprite loc dim dim2 dlist texture ;
|
|||
dup sprite-loc gl-translate
|
||||
GL_TEXTURE_2D over sprite-texture glBindTexture
|
||||
init-texture
|
||||
GL_QUADS [ dup sprite-dim2 four-sides ] do-state
|
||||
dup sprite-dim { 1 0 } v*
|
||||
swap sprite-loc v- gl-translate
|
||||
GL_QUADS [ sprite-dim2 four-sides ] do-state
|
||||
GL_TEXTURE_2D 0 glBindTexture ;
|
||||
|
||||
: rect-vertices ( lower-left upper-right -- )
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: html kernel semantic-db tangle.html tools.test ;
|
||||
USING: kernel semantic-db tangle.html tools.test ;
|
||||
IN: tangle.html.tests
|
||||
|
||||
[ "test" ] [ "test" >html ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (c) 2005 Mackenzie Straight.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel tools.test trees.splay math namespaces assocs
|
||||
sequences random ;
|
||||
sequences random sets ;
|
||||
IN: trees.splay.tests
|
||||
|
||||
: randomize-numeric-splay-tree ( splay-tree -- )
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
USING: alien alien.accessors alien.c-types arrays io kernel libc
|
||||
math math.vectors namespaces opengl opengl.gl prettyprint assocs
|
||||
sequences io.files io.styles continuations freetype
|
||||
ui.gadgets.worlds ui.render ui.backend byte-arrays ;
|
||||
ui.gadgets.worlds ui.render ui.backend byte-arrays accessors
|
||||
locals ;
|
||||
|
||||
IN: ui.freetype
|
||||
|
||||
|
|
@ -41,8 +42,8 @@ M: font hashcode* drop font hashcode* ;
|
|||
] bind ;
|
||||
|
||||
M: freetype-renderer free-fonts ( world -- )
|
||||
dup world-handle select-gl-context
|
||||
world-fonts [ nip second free-sprites ] assoc-each ;
|
||||
[ handle>> select-gl-context ]
|
||||
[ fonts>> [ nip second free-sprites ] assoc-each ] bi ;
|
||||
|
||||
: ttf-name ( font style -- name )
|
||||
2array H{
|
||||
|
|
@ -67,7 +68,7 @@ M: freetype-renderer free-fonts ( world -- )
|
|||
#! We use FT_New_Memory_Face, not FT_New_Face, since
|
||||
#! FT_New_Face only takes an ASCII path name and causes
|
||||
#! problems on localized versions of Windows
|
||||
freetype -rot 0 f <void*> [
|
||||
[ freetype ] 2dip 0 f <void*> [
|
||||
FT_New_Memory_Face freetype-error
|
||||
] keep *void* ;
|
||||
|
||||
|
|
@ -85,29 +86,29 @@ SYMBOL: dpi
|
|||
: font-units>pixels ( n font -- n )
|
||||
face-size face-size-y-scale FT_MulFix ;
|
||||
|
||||
: init-ascent ( font face -- )
|
||||
dup face-y-max swap font-units>pixels swap set-font-ascent ;
|
||||
: init-ascent ( font face -- font )
|
||||
dup face-y-max swap font-units>pixels >>ascent ; inline
|
||||
|
||||
: init-descent ( font face -- )
|
||||
dup face-y-min swap font-units>pixels swap set-font-descent ;
|
||||
: init-descent ( font face -- font )
|
||||
dup face-y-min swap font-units>pixels >>descent ; inline
|
||||
|
||||
: init-font ( font -- )
|
||||
dup font-handle 2dup init-ascent dupd init-descent
|
||||
dup font-ascent over font-descent - ft-ceil
|
||||
swap set-font-height ;
|
||||
: init-font ( font -- font )
|
||||
dup handle>> init-ascent
|
||||
dup handle>> init-descent
|
||||
dup [ ascent>> ] [ descent>> ] bi - ft-ceil >>height ; inline
|
||||
|
||||
: set-char-size ( handle size -- )
|
||||
0 swap 6 shift dpi get-global dup FT_Set_Char_Size freetype-error ;
|
||||
|
||||
: <font> ( handle -- font )
|
||||
H{ } clone
|
||||
{ set-font-handle set-font-widths } font construct
|
||||
dup init-font ;
|
||||
|
||||
: (open-font) ( font -- open-font )
|
||||
first3 >r open-face dup 0 r> 6 shift
|
||||
dpi get-global dpi get-global FT_Set_Char_Size
|
||||
freetype-error <font> ;
|
||||
font new
|
||||
H{ } clone >>widths
|
||||
over first2 open-face >>handle
|
||||
dup handle>> rot third set-char-size
|
||||
init-font ;
|
||||
|
||||
M: freetype-renderer open-font ( font -- open-font )
|
||||
freetype drop open-fonts get [ (open-font) ] cache ;
|
||||
freetype drop open-fonts get [ <font> ] cache ;
|
||||
|
||||
: load-glyph ( font char -- glyph )
|
||||
>r font-handle dup r> 0 FT_Load_Char
|
||||
|
|
@ -132,30 +133,35 @@ M: freetype-renderer string-height ( open-font string -- h )
|
|||
load-glyph dup
|
||||
FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ;
|
||||
|
||||
: copy-pixel ( bit tex -- bit tex )
|
||||
255 f pick set-alien-unsigned-1 1+
|
||||
f pick alien-unsigned-1
|
||||
f pick set-alien-unsigned-1 >r 1+ r> 1+ ;
|
||||
:: copy-pixel ( i j bitmap texture -- i j )
|
||||
255 j texture set-char-nth
|
||||
i bitmap char-nth j 1 + texture set-char-nth
|
||||
i 1 + j 2 + ; inline
|
||||
|
||||
: (copy-row) ( bit tex bitend texend -- bitend texend )
|
||||
>r pick over >= [
|
||||
2nip r>
|
||||
] [
|
||||
>r copy-pixel r> r> (copy-row)
|
||||
] if ;
|
||||
:: (copy-row) ( i j bitmap texture end -- )
|
||||
i end < [
|
||||
i j bitmap texture copy-pixel
|
||||
bitmap texture end (copy-row)
|
||||
] when ; inline
|
||||
|
||||
: copy-row ( bit tex width width2 -- bitend texend width width2 )
|
||||
[ pick + >r pick + r> (copy-row) ] 2keep ;
|
||||
:: copy-row ( i j bitmap texture width width2 -- i j )
|
||||
i j bitmap texture i width + (copy-row)
|
||||
i width +
|
||||
j width2 + ; inline
|
||||
|
||||
: copy-bitmap ( glyph texture -- )
|
||||
over glyph-bitmap-rows >r
|
||||
over glyph-bitmap-width dup next-power-of-2 2 *
|
||||
>r >r >r glyph-bitmap-buffer alien-address r> r> r> r>
|
||||
[ copy-row ] times 2drop 2drop ;
|
||||
:: copy-bitmap ( glyph texture -- )
|
||||
[let* | bitmap [ glyph glyph-bitmap-buffer ]
|
||||
rows [ glyph glyph-bitmap-rows ]
|
||||
width [ glyph glyph-bitmap-width ]
|
||||
width2 [ width next-power-of-2 2 * ] |
|
||||
0 0
|
||||
rows [ bitmap texture width width2 copy-row ] times
|
||||
2drop
|
||||
] ;
|
||||
|
||||
: bitmap>texture ( glyph sprite -- id )
|
||||
tuck sprite-size2 * 2 * [
|
||||
alien-address [ copy-bitmap ] keep <alien> gray-texture
|
||||
[ copy-bitmap ] keep gray-texture
|
||||
] with-malloc ;
|
||||
|
||||
: glyph-texture-loc ( glyph font -- loc )
|
||||
|
|
@ -163,34 +169,47 @@ M: freetype-renderer string-height ( open-font string -- h )
|
|||
font-ascent swap glyph-hori-bearing-y - ft-floor 2array ;
|
||||
|
||||
: glyph-texture-size ( glyph -- dim )
|
||||
dup glyph-bitmap-width next-power-of-2
|
||||
swap glyph-bitmap-rows next-power-of-2 2array ;
|
||||
[ glyph-bitmap-width next-power-of-2 ]
|
||||
[ glyph-bitmap-rows next-power-of-2 ]
|
||||
bi 2array ;
|
||||
|
||||
: <char-sprite> ( font char -- sprite )
|
||||
: <char-sprite> ( open-font char -- sprite )
|
||||
over >r render-glyph dup r> glyph-texture-loc
|
||||
over glyph-size pick glyph-texture-size <sprite>
|
||||
[ bitmap>texture ] keep [ init-sprite ] keep ;
|
||||
|
||||
: draw-char ( open-font char sprites -- )
|
||||
[ dupd <char-sprite> ] cache nip
|
||||
sprite-dlist glCallList ;
|
||||
:: char-sprite ( open-font sprites char -- sprite )
|
||||
char sprites [ open-font swap <char-sprite> ] cache ;
|
||||
|
||||
: (draw-string) ( open-font sprites string loc -- )
|
||||
: draw-char ( open-font sprites char loc -- )
|
||||
GL_MODELVIEW [
|
||||
0 0 glTranslated
|
||||
char-sprite sprite-dlist glCallList
|
||||
] do-matrix ;
|
||||
|
||||
: char-widths ( open-font string -- widths )
|
||||
[ char-width ] with { } map-as ;
|
||||
|
||||
: scan-sums ( seq -- seq' )
|
||||
0 [ + ] accumulate nip ;
|
||||
|
||||
:: (draw-string) ( open-font sprites string loc -- )
|
||||
GL_TEXTURE_2D [
|
||||
[
|
||||
[ >r 2dup r> swap draw-char ] each 2drop
|
||||
loc [
|
||||
string open-font string char-widths scan-sums [
|
||||
[ open-font sprites ] 2dip draw-char
|
||||
] 2each
|
||||
] with-translation
|
||||
] do-enabled ;
|
||||
|
||||
: font-sprites ( open-font world -- pair )
|
||||
world-fonts [ open-font H{ } clone 2array ] cache ;
|
||||
: font-sprites ( font world -- open-font sprites )
|
||||
world-fonts [ open-font H{ } clone 2array ] cache first2 ;
|
||||
|
||||
M: freetype-renderer draw-string ( font string loc -- )
|
||||
>r >r world get font-sprites first2 r> r> (draw-string) ;
|
||||
>r >r world get font-sprites r> r> (draw-string) ;
|
||||
|
||||
: run-char-widths ( open-font string -- widths )
|
||||
[ char-width ] with { } map-as
|
||||
dup 0 [ + ] accumulate nip swap 2 v/n v+ ;
|
||||
char-widths [ scan-sums ] [ 2 v/n ] bi v+ ;
|
||||
|
||||
M: freetype-renderer x>offset ( x open-font string -- n )
|
||||
dup >r run-char-widths [ <= ] with find drop
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ IN: unicode.collation.tests
|
|||
[ execute ] 2with each ;
|
||||
|
||||
[ f f f f ] [ "hello" "hi" test-equality ] unit-test
|
||||
[ t f f f ] [ "hello" "hŽllo" test-equality ] unit-test
|
||||
[ t f f f ] [ "hello" "h\u0000e9llo" test-equality ] unit-test
|
||||
[ t t f f ] [ "hello" "HELLO" test-equality ] unit-test
|
||||
[ t t t f ] [ "hello" "h e l l o." test-equality ] unit-test
|
||||
[ t t t t ] [ "hello" "\0hello\0" test-equality ] unit-test
|
||||
|
|
|
|||
Loading…
Reference in New Issue