;; The contents of this demo file are made available under the CC0 1.0
;; Universal Public Domain Dedication. See LICENSE-CC0.txt or visit
;; http://creativecommons.org/publicdomain/zero/1.0/


;;; This is a demo program showing various SDL_ttf functionality. It
;;; renders a line of text 3 times, using solid, shaded, and blended
;;; render modes. The text, font, and size can be customized via the
;;; command line. Various font styles, outline, kerning, and hinting
;;; can be toggled using keyboard keys.
;;;
;;; This program demonstrates the following concepts:
;;;
;;; * Loading a font from a file
;;; * Setting a font's style and other attributes
;;; * Pre-calculating the size of rendered text
;;; * Rendering text with solid, shaded, and blended modes
;;; * Using the "args" egg to parse command line options
;;;
;;; Command line:
;;;
;;; * -h / --help : Print command line help
;;; * -f / --font : Specify font file to use.   Default: ComicNeue-Regular.otf
;;; * -s / --size : Specify font size (pt).     Default: 72
;;; * Other args  : Specify the text to render. Default: "Hello, World!"
;;;
;;; Controls:
;;;
;;; * Escape quits the program
;;; * B: Toggle bold
;;; * I: Toggle italic
;;; * U: Toggle underline
;;; * S: Toggle strikethrough
;;; * O: Toggle outline
;;; * H: Toggle hinting
;;; * K: Toggle kerning


(cond-expand
  (chicken-4
   (use (prefix sdl2 sdl2:)
        (prefix sdl2-ttf ttf:)
        (only srfi-1 filter)
        (only srfi-13 string-join)
        (only data-structures identity)
        args
        miscmacros))
  (chicken-5
   (import (chicken base)
           (chicken condition)
           (chicken format)
           (chicken port)
           (chicken process-context)
           (prefix sdl2 sdl2:)
           (prefix sdl2-ttf ttf:)
           (only (srfi 1) filter)
           (only (srfi 13) string-join)
           args
           miscmacros)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Command line argument parsing

(define *font-file* (make-parameter "ComicNeue-Regular.otf"))
(define *font-size* (make-parameter "72"))
(define *text*      (make-parameter "Hello, World!"))

(define opts
  (list
   (args:make-option
    (f font)  (required: "FILE")
    (sprintf "Font file to use [Default: ~A]" (*font-file*)))
   (args:make-option
    (s size)  (required: "SIZE")
    (sprintf "Font size (pt) [Default: ~A]" (*font-size*)))
   (args:make-option
    (h help)  #:none
    "Display this help text"
    (print-usage))))

(define (print-usage)
 (with-output-to-port (current-error-port)
   (lambda ()
     (print "Usage: " (program-name) " [OPTIONS...] [TEXT TO RENDER...]")
     (newline)
     (print (args:usage opts))
     (print "Other command line arguments are treated as text to render.")))
 (exit 1))


(receive (options operands)
    (args:parse (command-line-arguments) opts)
  (*font-file* (or (alist-ref 'font options) (*font-file*)))
  (*font-size* (or (alist-ref 'size options) (*font-size*)))
  (*text*      (if (null? operands)
                   (*text*)
                   (string-join operands))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Initialization

(sdl2:set-main-ready!)
(sdl2:init! '(video events))
(ttf:init!)

;; Automatically call sdl2:quit! when program exits normally.
(on-exit sdl2:quit!)

;; Call sdl2:quit! and then call the original exception handler if an
;; unhandled exception reaches the top level.
(current-exception-handler
 (let ((original-handler (current-exception-handler)))
   (lambda (exception)
     (sdl2:quit!)
     (original-handler exception))))



(define +font+ (ttf:open-font (*font-file*) (string->number (*font-size*))))

(printf "Font Face Family: ~A~%" (ttf:font-face-family-name +font+))
(printf "Font Face Style: ~A~%" (ttf:font-face-style-name +font+))
(printf "Number of Faces: ~A~%" (ttf:font-faces +font+))


(define +margin+ 20)
(define +fg+ (sdl2:make-color 0   0   0))
(define +bg+ (sdl2:make-color 255 255 255))

(define *bold?*      (make-parameter #f))
(define *italic?*    (make-parameter #f))
(define *underline?* (make-parameter #f))
(define *strike?*    (make-parameter #f))
(define *outline?*   (make-parameter #f))
(define *hinting?*   (make-parameter #t))
(define *kerning?*   (make-parameter #t))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; WINDOW

(define (calculate-window-size)
  (receive (w h) (ttf:size-utf8 +font+ (*text*))
    (values (+ +margin+ w +margin+)
            (+ +margin+ (* 3 h) +margin+))))


(define +window-title-base+
  "sdl2-ttf Hello World")

(define +window+
  (receive (w h)
      (calculate-window-size)
    (sdl2:create-window!
     +window-title-base+
     'centered  'centered
     w h)))

(define (window-surf)
  (sdl2:window-surface +window+))

(define (update-window-title!)
  (set! (sdl2:window-title +window+)
        (sprintf "[~A] ~A"
                 (string-append
                  (if (*bold?*)      "B" "b")
                  (if (*italic?*)    "I" "i")
                  (if (*underline?*) "U" "u")
                  (if (*strike?*)    "S" "s")
                  (if (*outline?*)   "O" "o")
                  (if (*hinting?*)   "H" "h")
                  (if (*kerning?*)   "K" "k"))
                 +window-title-base+)))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; BACKGROUND (CHECKERBOARD)

(define +lite-gray+ (sdl2:make-color 200 200 200))
(define +dark-gray+ (sdl2:make-color 180 180 180))

(define (draw-checkerboard! surf grid-size color1 color2)
  (sdl2:fill-rect! surf #f color1)
  (let ((width  (sdl2:surface-w surf))
        (height (sdl2:surface-h surf))
        (rect   (sdl2:make-rect 0 0 grid-size grid-size)))
    (do ((row 0 (add1 row)))
        ((>= (* row grid-size) width))
      (do ((column 0 (add1 column)))
          ((>= (* column grid-size) height))
        (when (or (and (odd? row) (even? column))
                  (and (even? row) (odd? column)))
          (sdl2:rect-set! rect (* row grid-size) (* column grid-size))
          (sdl2:fill-rect! surf rect color2))))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DRAW

(define (redraw!)
  (update-font-attributes!)

  (maybe-resize-window!)
  (update-window-title!)

  (draw-checkerboard! (window-surf) 10 +lite-gray+ +dark-gray+)

  (let ((h (ttf:font-height +font+)))
    (draw-text-solid!   (sdl2:make-rect +margin+ +margin+))
    (draw-text-shaded!  (sdl2:make-rect +margin+ (+ +margin+ h)))
    (draw-text-blended! (sdl2:make-rect +margin+ (+ +margin+ (* 2 h)))))

  (sdl2:update-window-surface! +window+))


;; Update the font attributes based on current parameters.
(define (update-font-attributes!)
  (set! (ttf:font-style +font+)
        (filter identity
                (list (and (*bold?*) 'bold)
                      (and (*italic?*) 'italic)
                      (and (*underline?*) 'underline)
                      (and (*strike?*) 'strikethrough))))
  (set! (ttf:font-outline +font+) (if (*outline?*) 1 0))
  (set! (ttf:font-hinting +font+) (if (*hinting?*) 'normal 'none))
  (set! (ttf:font-kerning? +font+) (*kerning?*)))


;; Increase window dimensions if necessary to fit the text with the
;; current font settings.
(define (maybe-resize-window!)
  (receive (new-w new-h) (calculate-window-size)
    (receive (old-w old-h) (sdl2:window-size +window+)
      (when (or (> new-w old-w) (> new-h old-h))
        (set! (sdl2:window-size +window+)
              (list new-w new-h))))))


;; Render the text using SOLID mode, then blit to the window.
(define (draw-text-solid! dst-rect)
  (let ((surf (ttf:render-utf8-solid +font+ (*text*) +fg+)))
    (sdl2:blit-surface! surf #f (window-surf) dst-rect)))


;; Render the text using SHADED mode, then blit to the window.
(define (draw-text-shaded! dst-rect)
 (let ((surf (ttf:render-utf8-shaded +font+ (*text*) +fg+ +bg+)))
   (sdl2:blit-surface! surf #f (window-surf) dst-rect)))


;; Render the text using BLENDED mode, then blit to the window.
(define (draw-text-blended! dst-rect)
 (let ((surf (ttf:render-utf8-blended +font+ (*text*) +fg+)))
   (sdl2:blit-surface! surf #f (window-surf) dst-rect)))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; MAIN LOOP / EVENT HANDLING

(define (main)
  (redraw!)
  ;; Create a continuation that can be called to exit the main loop.
  (let/cc exit-main-loop!
    ;; Loop forever (until exit-main-loop! is called).
    (while #t
      (handle-event (sdl2:wait-event!) exit-main-loop!))))


(define (handle-event ev exit-main-loop!)
  (case (sdl2:event-type ev)
    ;; Window exposed, resized, etc.
    ((window)
     (sdl2:update-window-surface! +window+))

    ;; User requested app quit (e.g. clicked the close button).
    ((quit)
     (exit-main-loop! #t))

    ;; Keyboard key pressed
    ((key-down)
     (case (sdl2:keyboard-event-sym ev)
       ((escape) ;; Escape quits the program
        (exit-main-loop! #t))

       ((b) ;; B toggles bold
        (set! (*bold?*) (not (*bold?*)))
        (redraw!))

       ((i) ;; I toggles italic
        (set! (*italic?*) (not (*italic?*)))
        (redraw!))

       ((u) ;; U toggles underline
        (set! (*underline?*) (not (*underline?*)))
        (redraw!))

       ((s) ;; S toggles strikethrough
        (set! (*strike?*) (not (*strike?*)))
        (redraw!))

       ((o) ;; O toggles outline
        (set! (*outline?*) (not (*outline?*)))
        (redraw!))

       ((h) ;; H toggles hinting
        (set! (*hinting?*) (not (*hinting?*)))
        (redraw!))

       ((k) ;; K toggles kerning
        (set! (*kerning?*) (not (*kerning?*)))
        (redraw!))))))

(main)