diff --git a/fonts/VeraMoBI.ttf b/fonts/VeraMoBI.ttf new file mode 100644 index 0000000000..8624542ed2 Binary files /dev/null and b/fonts/VeraMoBI.ttf differ diff --git a/fonts/VeraMoBd.ttf b/fonts/VeraMoBd.ttf new file mode 100644 index 0000000000..9be6547ed6 Binary files /dev/null and b/fonts/VeraMoBd.ttf differ diff --git a/fonts/VeraMoIt.ttf b/fonts/VeraMoIt.ttf new file mode 100644 index 0000000000..2404924856 Binary files /dev/null and b/fonts/VeraMoIt.ttf differ diff --git a/fonts/VeraMono.ttf b/fonts/VeraMono.ttf new file mode 100644 index 0000000000..139f0b4311 Binary files /dev/null and b/fonts/VeraMono.ttf differ diff --git a/library/sdl/sdl-ttf.factor b/library/sdl/sdl-ttf.factor index a84417bb81..693fae82dd 100644 --- a/library/sdl/sdl-ttf.factor +++ b/library/sdl/sdl-ttf.factor @@ -78,6 +78,13 @@ USE: alien : TTF_FontFaceStyleName ( font -- n ) "char*" "sdl-ttf" "TTF_FontFaceStyleName" [ "void*" ] alien-invoke ; +BEGIN-STRUCT: int-box + FIELD: int i +END-STRUCT + +: TTF_SizeText ( font text w h -- ? ) + "bool" "sdl-ttf" "TTF_SizeText" [ "void*" "char*" "int-box*" "int-box*" ] alien-invoke ; + : TTF_RenderText_Solid ( font text fg -- surface ) "surface*" "sdl-ttf" "TTF_RenderText_Solid" [ "void*" "char*" "int" ] alien-invoke ; diff --git a/library/sdl/sdl-utils.factor b/library/sdl/sdl-utils.factor index 2e7f1b406c..0f3b252445 100644 --- a/library/sdl/sdl-utils.factor +++ b/library/sdl/sdl-utils.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2004 Slava Pestov. +! Copyright (C) 2004, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -39,6 +39,9 @@ USE: prettyprint USE: sdl-event USE: sdl-gfx USE: sdl-video +USE: streams +USE: strings +USE: sdl-ttf SYMBOL: surface SYMBOL: width @@ -60,6 +63,14 @@ SYMBOL: surface swap 16 shift bitor swap 24 shift bitor ; +: make-color ( r g b -- color ) + #! Make an SDL_Color struct. This will go away soon in favor + #! of pass-by-value support in the FFI. + 255 24 shift + swap 16 shift bitor + swap 8 shift bitor + swap bitor ; + : black 0 0 0 ; : white 255 255 255 ; : red 255 0 0 ; @@ -98,3 +109,55 @@ SYMBOL: surface ] [ drop ] ifte ; + +SYMBOL: fonts + +: null? ( alien -- ? ) + dup [ alien-address 0 = ] when ; + +: ( name ptsize -- font ) + >r resource-path swap cat2 r> TTF_OpenFont ; + +: font ( name ptsize -- font ) + fonts get [ + 2dup cons get [ + 2nip + ] [ + 2dup cons >r dup r> set + ] ifte* + ] bind ; + +: make-rect ( x y w h -- rect ) + + [ set-rect-h ] keep + [ set-rect-w ] keep + [ set-rect-y ] keep + [ set-rect-x ] keep ; + +: surface-rect ( x y surface -- rect ) + dup surface-w swap surface-h make-rect ; + +: draw-surface ( x y surface -- ) + [ + [ surface-rect ] keep swap surface get 0 0 + ] keep surface-rect swap rot SDL_UpperBlit drop ; + +: draw-string ( x y font text fg bg -- width ) + pick str-length 0 = [ + 2drop 2drop 2drop 0 + ] [ + TTF_RenderText_Shaded + [ draw-surface ] keep + [ surface-w ] keep + SDL_FreeSurface + ] ifte ; + +: size-string ( font text -- w h ) + dup str-length 0 = [ + drop TTF_FontHeight 0 swap + ] [ + [ TTF_SizeText drop ] 2keep + swap int-box-i swap int-box-i + ] ifte ; + +global [ fonts set ] bind diff --git a/library/ui/console.factor b/library/ui/console.factor index 2c2ff83c1f..9418826963 100644 --- a/library/ui/console.factor +++ b/library/ui/console.factor @@ -63,6 +63,7 @@ USE: errors USE: line-editor USE: hashtables USE: lists +USE: sdl-ttf #! A namespace holding console state. SYMBOL: console @@ -78,13 +79,16 @@ SYMBOL: y SYMBOL: output-line #! A line editor object. SYMBOL: input-line +#! A TTF_Font* value. +SYMBOL: console-font +#! Font height. +SYMBOL: line-height #! The font size is hardcoded here. -: line-height 8 ; : char-width 8 ; ! Scrolling -: visible-lines ( -- n ) height get line-height /i ; +: visible-lines ( -- n ) height get line-height get /i ; : total-lines ( -- n ) lines get vector-length ; : available-lines ( -- ) total-lines first-line get - ; @@ -105,19 +109,20 @@ SYMBOL: input-line total-lines fix-first-line first-line set ; ! Rendering -: background white rgb ; -: foreground black rgb ; -: cursor red rgb ; +: background white ; +: foreground black ; +: cursor red ; : next-line ( -- ) - 0 x set line-height y [ + ] change ; + 0 x set line-height get y [ + ] change ; : draw-line ( str -- ) - [ surface get x get y get ] keep foreground stringColor - str-length char-width * x [ + ] change ; + >r x get y get console-font get r> + foreground make-color background make-color draw-string + x [ + ] change ; : clear-display ( -- ) - surface get 0 0 width get height get background boxColor ; + surface get 0 0 width get height get background rgb boxColor ; : draw-lines ( -- ) visible-lines available-lines min [ @@ -133,14 +138,17 @@ SYMBOL: input-line swap y get over 1 + - y get line-height + - cursor boxColor ; + y get line-height get + + cursor rgb boxColor ; : draw-current ( -- ) output-line get sbuf>str draw-line ; : caret-x ( -- x ) - x get input-line get [ caret get char-width * + ] bind ; + x get input-line get [ + console-font get caret get line-text get str-head + size-string drop + + ] bind ; : draw-input ( -- ) caret-x >r @@ -341,7 +349,13 @@ M: alien handle-event ( event -- ? ) drop t ] ifte ; +: set-console-font ( font ptsize ) + font dup console-font set + TTF_FontHeight line-height set ; + : init-console ( -- ) + TTF_Init + "/fonts/VeraMono.ttf" 14 set-console-font event set 0 first-line set 80 lines set