;;; 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 of procedurally generated fire, based on
;;; "How DOOM fire was done" by Fabien Sanglard.
;;; http://fabiensanglard.net/doom_fire_psx/
;;;
;;; This program demonstrates the following concepts:
;;;
;;; - Overwriting the raw pixel data of a surface
;;; - Using an 8-bit surface with a palette
;;; - Using blit-scaled! to achieve a blocky pixel art style
;;; - Measuring the framerate (FPS) of an application
;;;
;;; Controls:
;;;
;;; - Space: Toggle fire emission
;;; - P: Toggle pause
;;; - Escape, or close window: Quit


(import (only (chicken condition) current-exception-handler)
        (only (chicken fixnum) fx+ fx- fx* fxand fxmax fxmod)
        (only (chicken format) sprintf)
        (only (chicken memory) move-memory!)
        (only (chicken random) pseudo-random-real)
        miscmacros
        (prefix sdl2 sdl2:)
        srfi-4)

(cond-expand
  (csi
   (display "INFO: For best performance, compile this demo with csc -O5\n"))
  (else))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; CONFIGURATION

(define-constant +title+ "FIRE")
(define-constant +fullscreen+ #f)

;;; Fire simulation size
(define-constant +fire-width+ 128)
(define-constant +fire-height+ 128)

;;; Display scale and horizontal repetition
(define-constant +zoom+ 4)
(define-constant +repeat-x+ 2)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; INITIALIZATION

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

(on-exit sdl2:quit!)
(current-exception-handler
  (let ((original-handler (current-exception-handler)))
    (lambda (exception)
      (sdl2:quit!)
      (original-handler exception))))

(define +window+
  (sdl2:create-window!
   +title+
   'undefined
   'undefined
   (* +fire-width+ +zoom+ +repeat-x+)
   (* +fire-height+ +zoom+)
   (if +fullscreen+ '(fullscreen) '())))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; FIRE SURFACE

(define +fire-colors+
  '("#000000" "#100505" "#101010" "#101020" "#201520"
    "#201520" "#0b001b" "#110012" "#170017" "#290022"
    "#410025" "#5e0029" "#7a0033" "#8a003c" "#9b0041"
    "#ac0050" "#bc0039" "#cd001e" "#de0300" "#ee2930"
    "#ff5520" "#ff6220" "#ff6f10" "#ff7b00" "#ff8800"
    "#ff9500" "#ffbb00" "#ffa200" "#ffae00" "#ffc800"
    "#ffe100" "#ffd500" "#ffee00" "#ffee00" "#fff125"
    "#fff73e" "#fffb56" "#ffff6d" "#ffff8d" "#ffffa0"))

;;; Create sdl2:color from 6-digit hex string.
(: hex (string -> (struct sdl2:color)))
(define (hex str)
  (sdl2:make-color
   (string->number (substring str 1 3) 16)
   (string->number (substring str 3 5) 16)
   (string->number (substring str 5 7) 16)))

(define +fire-surface+
  (let ((pal (sdl2:make-palette (length +fire-colors+)))
        (surf (sdl2:make-surface +fire-width+ +fire-height+ 8)))
    (set! (sdl2:palette-colors pal)
          (list->vector (map hex +fire-colors+)))
    (set! (sdl2:surface-palette surf) pal)
    surf))

;;; Update the fire surface to reflect the current data.
(define (update-fire-surface!)
  ;; Directly overwrite +fire-surface+'s pixels from +fire-data+.
  ;; This works because +fire-surface+ has an 8-bit pixel format
  ;; and +fire-data+ is an array of 8-bit integers.
  (move-memory! +fire-data+
                (sdl2:surface-pixels-raw +fire-surface+)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; FIRE CALCULATION

;;; Fire data is stored in a u8vector, an array of unsigned bytes.
;;; Each byte represents the "heat" of one pixel, which affects both
;;; the calculation and the palette color. Array index 0 is the top
;;; left pixel; it progresses to the right and wraps downward.

;;; Bytes per row of pixels (may include padding bytes at end of row).
(define +fire-pitch+ (sdl2:surface-pitch +fire-surface+))

(define +fire-data+
  (make-u8vector (* +fire-pitch+ +fire-height+) 0))

(: fire-ref (fixnum --> fixnum))
(define (fire-ref i)
  (u8vector-ref +fire-data+ i))

(: fire-set! (fixnum fixnum -> void))
(define (fire-set! i color)
  (u8vector-set! +fire-data+ i color))

(: coords->index (fixnum fixnum --> fixnum))
(define (coords->index x y)
  (fx+ (fxmod x +fire-width+) (fx* y +fire-pitch+)))


(define (do-fire!)
  (dotimes (x +fire-width+)
    (dotimes (y +fire-height+)
      (spread-fire! x y))))

(: spread-fire! (fixnum fixnum -> void))
(define (spread-fire! x y)
  (let* ((rand (fxand 3 (inexact->exact
                         (round (* 3 (pseudo-random-real))))))
         (src (coords->index x y))
         (dst (coords->index (fx+ 1 (fx- x rand))
                             (fxmax 0 (fx- y 1)))))
    (fire-set! dst
               (fxmax 0 (fx- (fire-ref src)
                             (fxand rand 1))))))

(define *fire-on* (make-parameter #f))

(define (toggle-fire!)
  (set! (*fire-on*) (not (*fire-on*)))
  (if (*fire-on*)
      (fill-bottom-row! (sub1 (length +fire-colors+)))
      (fill-bottom-row! 0)))

;;; Fill the bottom row with the given color.
(: fill-bottom-row! (fixnum -> void))
(define (fill-bottom-row! color)
  (do ((i (* +fire-width+ (sub1 +fire-height+)) (add1 i)))
      ((= i (u8vector-length +fire-data+)))
    (fire-set! i color)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; FRAMERATE (FRAMES PER SECOND) MEASURING

;;; Very simple FPS measurement system. Call fps-tick! once per frame.
;;; Every X frames it will calculate FPS based on how much time has
;;; passed during those X frames.

;;; How many frames to wait between recalculating FPS
(define-constant +fps-sample+ 15)

(define *current-fps* (make-parameter 0))
(define *frame-countdown* (make-parameter 1))
(define *prev-counter* (make-parameter 0))
(define +perf-frequency+ (sdl2:get-performance-frequency))

(define (fps-tick!)
  (dec! (*frame-countdown*))
  (when (zero? (*frame-countdown*))
    (let* ((new-counter (sdl2:get-performance-counter))
           (diff (fx- new-counter (*prev-counter*)))
           (fps (/ +fps-sample+ (/ diff +perf-frequency+))))
      (set! (*prev-counter*) new-counter)
      (set! (*frame-countdown*) +fps-sample+)
      (set! (*current-fps*) (inexact->exact (round fps)))
      (update-window-title!))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; MAIN LOOP

(define *paused* (make-parameter #f))

(define (main-loop)
  ;; Temporary surface, same size as +fire-surface+ but has the same
  ;; format as the window. The fire surface is blitted to the temp
  ;; surface, then the temp surface is blit-scaled to the window.
  ;; This is necessary because 8-bit surfaces can't be blit-scaled.
  (define temp-surf
    (sdl2:convert-surface
     (sdl2:make-surface +fire-width+ +fire-height+ 32)
     (sdl2:surface-format (sdl2:window-surface +window+))))

  ;; Temp rect for blitting temp-surf multiple times side by side.
  (define temp-rect
    (sdl2:make-rect
     0 0
     (* +fire-width+ +zoom+)
     (* +fire-height+ +zoom+)))

  (toggle-fire!)

  (let/cc exit-main-loop!
    (while #t
      (sdl2:pump-events!)
      (while (sdl2:has-events?)
        (handle-event (sdl2:poll-event!) exit-main-loop!))

      (unless (*paused*)
        (do-fire!)
        (update-fire-surface!)
        (sdl2:blit-surface! +fire-surface+ #f temp-surf #f)
        (dotimes (i +repeat-x+)
          (set! (sdl2:rect-x temp-rect) (* i +fire-width+ +zoom+))
          (sdl2:blit-scaled!
           temp-surf #f
           (sdl2:window-surface +window+) temp-rect)))

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

(define (handle-event ev exit-main-loop!)
  (case (sdl2:event-type ev)
    ((quit)
     (exit-main-loop! #t))
    ((key-down)
     (case (sdl2:keyboard-event-sym ev)
       ((escape)
        (exit-main-loop! #t))
       ((space)
        (toggle-fire!))
       ((p)
        (set! (*paused*) (not (*paused*))))))))

(define (update-window-title!)
  (set! (sdl2:window-title +window+)
        (if (*paused*)
            (sprintf "~A [PAUSED]" +title+)
            (sprintf "~A [~A FPS]" +title+ (*current-fps*)))))


(main-loop)