;;
;; chicken-sdl2-ttf: CHICKEN Scheme bindings to SDL_ttf 2
;;
;; Copyright © 2015  John Croisant.
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;;
;; - Redistributions of source code must retain the above copyright
;;   notice, this list of conditions and the following disclaimer.
;;
;; - Redistributions in binary form must reproduce the above copyright
;;   notice, this list of conditions and the following disclaimer in
;;   the documentation and/or other materials provided with the
;;   distribution.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
;; COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
;; OF THE POSSIBILITY OF SUCH DAMAGE.


(export font-style     font-style-set!
        font-outline   font-outline-set!
        font-hinting   font-hinting-set!
        font-kerning?  font-kerning-set!

        font-height
        font-ascent
        font-descent
        font-line-skip

        font-faces
        font-face-fixed-width?
        font-face-family-name
        font-face-style-name
        )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; FONT STYLE

(define-function-binding TTF_GetFontStyle
  return: (int style)
  args: ((TTF_Font* font)))

(define-function-binding TTF_SetFontStyle
  args: ((TTF_Font* font)
         (int style)))


(: font-style
   (ttf:font -> (list-of symbol)))
(define (font-style font)
  (unpack-style (TTF_GetFontStyle font)))

(: font-style-set!
   (ttf:font (list-of symbol) -> void))
(define (font-style-set! font style)
  (let ((style-int (if (integer? style)
                       style
                       (pack-style style))))
    (TTF_SetFontStyle font style-int)))

(set! (setter font-style) font-style-set!)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; FONT OUTLINE

(define-function-binding TTF_GetFontOutline
  return: (int outline)
  args: ((TTF_Font* font)))

(define-function-binding TTF_SetFontOutline
  args: ((TTF_Font* font)
         (int outline)))


(: font-outline
   (ttf:font -> fixnum))
(define (font-outline font)
  (TTF_GetFontOutline font))

(: font-outline-set!
   (ttf:font symbol -> void))
(define (font-outline-set! font outline)
  (TTF_SetFontOutline font outline))

(set! (setter font-outline) font-outline-set!)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; FONT HINTING

(define-function-binding TTF_GetFontHinting
  return: (int hinting)
  args: ((TTF_Font* font)))

(define-function-binding TTF_SetFontHinting
  args: ((TTF_Font* font)
         (int hinting)))


(: font-hinting
   (ttf:font -> symbol))
(define (font-hinting font)
  (hinting->symbol (TTF_GetFontHinting font)))

(: font-hinting-set!
   (ttf:font symbol -> void))
(define (font-hinting-set! font hinting)
  (let ((hinting-int (if (integer? hinting)
                         hinting
                         (symbol->hinting hinting))))
    (TTF_SetFontHinting font hinting-int)))

(set! (setter font-hinting) font-hinting-set!)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; FONT KERNING

(define-function-binding TTF_GetFontKerning
  return: (bool state)
  args: ((TTF_Font* font)))

(define-function-binding TTF_SetFontKerning
  args: ((TTF_Font* font)
         (bool state)))


(: font-kerning?
   (ttf:font -> boolean))
(define (font-kerning? font)
  (TTF_GetFontKerning font))

(: font-kerning-set!
   (ttf:font boolean -> void))
(define (font-kerning-set! font kerning)
  (TTF_SetFontKerning font kerning))

(set! (setter font-kerning?) font-kerning-set!)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; FONT METRICS

(define-function-binding TTF_FontHeight
  return: (int height)
  args: ((TTF_Font* font)))

(define-function-binding TTF_FontAscent
  return: (int ascent)
  args: ((TTF_Font* font)))

(define-function-binding TTF_FontDescent
  return: (int descent)
  args: ((TTF_Font* font)))

(define-function-binding TTF_FontLineSkip
  return: (int skip)
  args: ((TTF_Font* font)))


(: font-height
   (ttf:font -> fixnum))
(define (font-height font)
  (TTF_FontHeight font))

(: font-ascent
   (ttf:font -> fixnum))
(define (font-ascent font)
  (TTF_FontAscent font))

(: font-descent
   (ttf:font -> fixnum))
(define (font-descent font)
  (TTF_FontDescent font))

(: font-line-skip
   (ttf:font -> fixnum))
(define (font-line-skip font)
  (TTF_FontLineSkip font))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; FONT FACES

(define-function-binding TTF_FontFaces
  return: (long num-faces)
  args: ((TTF_Font* font)))

(define-function-binding TTF_FontFaceIsFixedWidth
  return: (bool fixed-width?)
  args: ((TTF_Font* font)))

(define-function-binding TTF_FontFaceFamilyName
  return: (c-string family-name)
  args: ((TTF_Font* font)))

(define-function-binding TTF_FontFaceStyleName
  return: (c-string style-name)
  args: ((TTF_Font* font)))


(: font-faces
   (ttf:font -> fixnum))
(define (font-faces font)
  (TTF_FontFaces font))

(: font-face-fixed-width?
   (ttf:font -> boolean))
(define (font-face-fixed-width? font)
  (TTF_FontFaceIsFixedWidth font))

(: font-face-family-name
   (ttf:font -> string))
(define (font-face-family-name font)
  (TTF_FontFaceFamilyName font))

(: font-face-style-name
   (ttf:font -> string))
(define (font-face-style-name font)
  (TTF_FontFaceStyleName font))