added bitstream vera fonts, sdl console uses sdl-ttf for text rendering

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 ;
 

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 ;
+
+: <font> ( name ptsize -- font )
+    >r resource-path swap cat2 r> TTF_OpenFont ;
+
+: font ( name ptsize -- font )
+    fonts get [
+        2dup cons get [
+            2nip
+        ] [
+            2dup cons >r <font> dup r> set
+        ] ifte*
+    ] bind ;
+
+: make-rect ( x y w h -- rect )
+    <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
+    ] [
+        <int-box> <int-box> [ TTF_SizeText drop ] 2keep
+        swap int-box-i swap int-box-i
+    ] ifte ;
+
+global [ <namespace> fonts set ] bind

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> event set
     0 first-line set
     80 <vector> lines set