From df05f9d1494d3a62a5b301f6f2db3410f21be458 Mon Sep 17 00:00:00 2001
From: Gerry Agbobada <gagbobada@gmail.com>
Date: Sun, 24 May 2020 14:03:34 +0200
Subject: ttf: Add more bindings.

Bindings added:

* TTF_FontAscent
* TTF_FontDescent
* TTF_FontLineSkip
* TTF_SizeUTF8
* TTF_GlyphIsProvided
* TTF_GetFontStyle
* TTF_SetFontStyle
---
 sdl2/bindings/ttf.scm | 28 ++++++++++++++++++
 sdl2/ttf.scm          | 79 +++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 107 insertions(+)

(limited to 'sdl2')

diff --git a/sdl2/bindings/ttf.scm b/sdl2/bindings/ttf.scm
index fb3b717..1accf6c 100644
--- a/sdl2/bindings/ttf.scm
+++ b/sdl2/bindings/ttf.scm
@@ -42,6 +42,13 @@ RETURN-TYPE and accept arguments of ARG-TYPES."
   (define-public name
     (sdl-ttf-func return-type func-name arg-types)))
 
+;; Font style bitmask.
+;; If no bit is set in the mask, that means the style is "normal"
+(define-public SDL_TTF_STYLE_BOLD          #x01)
+(define-public SDL_TTF_STYLE_ITALIC        #x02)
+(define-public SDL_TTF_STYLE_UNDERLINE     #x04)
+(define-public SDL_TTF_STYLE_STRIKETHROUGH #x08)
+
 (define-foreign ttf-init
   int "TTF_Init" '())
 
@@ -57,9 +64,30 @@ RETURN-TYPE and accept arguments of ARG-TYPES."
 (define-foreign ttf-font-height
   int "TTF_FontHeight" '(*))
 
+(define-foreign ttf-font-ascent
+  int "TTF_FontAscent" '(*))
+
+(define-foreign ttf-font-descent
+  int "TTF_FontDescent" '(*))
+
+(define-foreign ttf-font-line-skip
+  int "TTF_FontLineSkip" '(*))
+
+(define-foreign ttf-size-utf8
+  int "TTF_SizeUTF8" '(* * * *))
+
+(define-foreign ttf-glyph-is-provided
+  int "TTF_GlyphIsProvided" (list '* uint16))
+
 (define-foreign ttf-glyph-metrics
   int "TTF_GlyphMetrics" (list '* uint16 '* '* '* '* '*))
 
+(define-foreign ttf-get-font-style
+  int "TTF_GetFontStyle" '(*))
+
+(define-foreign ttf-set-font-style
+  void "TTF_SetFontStyle" (list '* int))
+
 (define-foreign ttf-render-text-solid
   '* "TTF_RenderText_Solid" (list '* '* sdl-color))
 
diff --git a/sdl2/ttf.scm b/sdl2/ttf.scm
index a20ae69..f3161b2 100644
--- a/sdl2/ttf.scm
+++ b/sdl2/ttf.scm
@@ -25,6 +25,8 @@
 
 (define-module (sdl2 ttf)
   #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
   #:use-module (system foreign)
   #:use-module (sdl2)
   #:use-module ((sdl2 bindings ttf) #:prefix ffi:)
@@ -35,7 +37,14 @@
             load-font
             delete-font!
             font-height
+            font-ascent
+            font-descent
+            font-line-skip
+            font-size
+            font-glyph-index
             font-glyph-metrics
+            font-style
+            set-font-style!
 
             render-font-solid
             render-font-blended))
@@ -72,6 +81,35 @@ size is POINT-SIZE."
   "Return the maximum height of FONT."
   (ffi:ttf-font-height (unwrap-font font)))
 
+(define (font-ascent font)
+  "Return the maximum pixel ascent of all glyphs in FONT."
+  (ffi:ttf-font-ascent (unwrap-font font)))
+
+(define (font-descent font)
+  "Return the maximum pixel descent of all glyphs in FONT."
+  (ffi:ttf-font-descent (unwrap-font font)))
+
+(define (font-line-skip font)
+  "Return the recommended pixel height of a line in FONT."
+  (ffi:ttf-font-line-skip (unwrap-font font)))
+
+(define (font-size font text)
+  "Return a 2-element list containing the resulting surface size of
+the string TEXT using FONT in the following format: (width height)."
+  (let ((bv (make-s32vector 2)))
+    (if (zero? (ffi:ttf-size-utf8 (unwrap-font font)
+                                  (string->pointer text)
+                                  (bytevector->pointer bv)
+                                  (bytevector->pointer bv 4)))
+        (s32vector->list bv)
+        (sdl-error "size-utf8" "failed to get size utf8"))))
+
+(define (font-glyph-index font char)
+  "Return the index of the glyph for CHAR in FONT, or #f if CHAR is
+not present."
+  (let ((result (ffi:ttf-glyph-is-provided (unwrap-font font) (char->integer char))))
+    (if (eq? result 0) #f result)))
+
 (define (font-glyph-metrics font char)
   "Return a 5-element list containing the metrics of CHAR in FONT in
 the following format: (minx maxx miny maxy advance)"
@@ -86,6 +124,47 @@ the following format: (minx maxx miny maxy advance)"
         (s32vector->list bv)
         (sdl-error "font-glyph-metrics" "failed to get glyph metrics"))))
 
+(define (font-style font)
+  "Return the rendering style of FONT.  Return a list that may contain
+any of the following symbols:
+
+- bold
+- italic
+- underline
+- strikethrough
+
+The empty list returned if no there is no style applied."
+  (let ((bitmask (ffi:ttf-get-font-style (unwrap-font font))))
+    (filter-map (match-lambda
+                  ((sym . bit)
+                   (and (not (zero? (logand bitmask bit))) sym)))
+                `((bold          . ,ffi:SDL_TTF_STYLE_BOLD)
+                  (italic        . ,ffi:SDL_TTF_STYLE_ITALIC)
+                  (underline     . ,ffi:SDL_TTF_STYLE_UNDERLINE)
+                  (strikethrough . ,ffi:SDL_TTF_STYLE_STRIKETHROUGH)))))
+
+(define (set-font-style! font style)
+  "Set the rendering style of FONT to STYLE, a list that may contain
+any of the following symbols:
+
+- bold
+- italic
+- underline
+- strikethrough
+
+Use an empty list to set the normal style."
+  (let ((bitmask
+         (fold (lambda (flag prev)
+                 (logior prev
+                         (match flag
+                           ('bold          ffi:SDL_TTF_STYLE_BOLD)
+                           ('italic        ffi:SDL_TTF_STYLE_ITALIC)
+                           ('underline     ffi:SDL_TTF_STYLE_UNDERLINE)
+                           ('strikethrough ffi:SDL_TTF_STYLE_STRIKETHROUGH))))
+               0
+               style)))
+    (ffi:ttf-set-font-style (unwrap-font font) bitmask)))
+
 (define (render-font-solid font text color)
   "Render TEXT, a UTF-8 encoded string, using FONT and COLOR, the
 foreground color, and return a surface containing the results."
-- 
cgit v1.2.3