: 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 ;
! $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:
USE: sdl-event
USE: sdl-gfx
USE: sdl-video
+USE: streams
+USE: strings
+USE: sdl-ttf
SYMBOL: surface
SYMBOL: width
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 ;
] [
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
USE: line-editor
USE: hashtables
USE: lists
+USE: sdl-ttf
#! A namespace holding console state.
SYMBOL: console
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 - ;
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 [
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
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