;;; xcb-boomshine.el --- X11 boomshine game port -*- lexical-binding: t; -*-

;; Copyright (C) 2023 Vasilij Schneidermann <mail@vasilij.de>
;; SPDX-License-Identifier: GPL-3.0-or-later

;; Author: Vasilij Schneidermann <mail@vasilij.de>
;; URL: https://depp.brause.cc/xcb-boomshine
;; Version: 0.0.2
;; Package-Requires: ((emacs "28.1") (xelb "0.18"))
;; Keywords: games

;; This file is NOT part of GNU Emacs.

;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.

;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; TODO

;;; Code:

(require 'cl-lib)

(require 'xcb)
(require 'xcb-keysyms)
(require 'xcb-render)
(require 'xcb-renderutil)

(require 'unifont-glyphs)

(defvar boom-scale 2)
(defconst boom-canvas-width 480)
(defconst boom-canvas-height 360)
(defconst boom-window-title "Boomshine")
(defconst boom-window-class "Emacs")

(defconst boom-keysym-q #x71)
(defconst boom-keysym-escape #xff1b)
(defconst boom-keysym-space #x20)

(defconst boom-fps 30)
(defvar boom-ticks 0)
(defvar boom-redraw-timer nil)

(defvar boom-picture-list nil)
(defvar boom-glyphset-list nil)

(defvar boom-x-display nil)
(defvar boom-x-conn nil)
(defvar boom-x-screen nil)

(defvar boom-xrender-formats nil)
(defvar boom-xrender-format-a8 nil)
(defvar boom-xrender-format-rgb24 nil)
(defvar boom-xrender-format-argb32 nil)

(defvar boom-window nil)

(defvar boom-upscale-transform nil)
(defvar boom-double-transform nil)

(defvar boom-backbuffer nil)
(defvar boom-scene-picture nil)

(defvar boom-crosshair-picture nil)
(defconst boom-crosshair-width (/ boom-canvas-width 4))
(defconst boom-crosshair-height (/ boom-canvas-height 4))
(defconst boom-crosshair-left (/ (- boom-canvas-width boom-crosshair-width) 2))
(defconst boom-crosshair-top (/ (- boom-canvas-height boom-crosshair-height) 2))
(defconst boom-crosshair-right (+ boom-crosshair-left boom-crosshair-width))
(defconst boom-crosshair-bottom (+ boom-crosshair-top boom-crosshair-height))

(defvar boom-ball-pictures nil)

(defconst boom-regular-ball-size 16)
(defconst boom-regular-ball-radius (/ boom-regular-ball-size 2))
(defconst boom-expanded-ball-size (* boom-regular-ball-size 2))

(defvar boom-update-balls-composite-crosshair-request nil)
(defvar boom-update-balls-composite-ball-request nil)

(defvar boom-color-black nil)
(defvar boom-color-white nil)
(defvar boom-pen-black nil)
(defvar boom-pen-white nil)

(defvar boom-glyphset nil)
(defvar boom-glyphinfo nil)

(defvar boom-current-screen nil)
(defvar boom-current-level 0)
(defconst boom-level-goals
  [[1 5] [2 10] [4 15] [6 20] [10 25] [15 30]
   [18 35] [22 40] [30 45] [37 50] [48 55] [58 60]])
(defconst boom-last-level (1- (length boom-level-goals)))
(defvar boom-balls nil)
(defvar boom-chain-started-p nil)
(defvar boom-chain-ticks nil)
(defconst boom-chain-timeout (* 3 boom-fps))

;; NOTE: state machine: moving > expanded > contracted
(cl-defstruct boom-ball
  cx cy radius dx dy state ticks)

(defmacro boom-bench (message &rest body)
  "Print how long evaluation of BODY took using MESSAGE."
  (declare (indent 1))
  (let ((then-sym (make-symbol "then")))
    `(let ((,then-sym (float-time)))
       (message ,message)
       (prog1 (progn ,@body)
         (message (format "%s (%.2fs)" ,message (- (float-time) ,then-sym)))))))

(defun boom-x-query-extension (namespace)
  (= (slot-value (xcb:get-extension-data boom-x-conn namespace) 'present) 1))

(defun boom-x-setup ()
  (setq boom-x-display (getenv "DISPLAY"))
  (when (not boom-x-display)
    (error "X11 DISPLAY unset"))
  (setq boom-x-conn (xcb:connect boom-x-display))
  (setq boom-x-screen (car (slot-value (xcb:get-setup boom-x-conn) 'roots)))
  (xcb:keysyms:init boom-x-conn))

(defun boom-xrender-format-lookup (format)
  (xcb:renderutil:find-standard boom-xrender-formats format))

(defun boom-xrender-setup ()
  (when (not (boom-x-query-extension 'xcb:render))
    (error "RENDER extension not available"))
  (setq boom-xrender-formats (xcb:renderutil:query-formats boom-x-conn))
  (setq boom-xrender-format-a8
        (boom-xrender-format-lookup xcb:renderutil:PICT_STANDARD:A_8))
  (setq boom-xrender-format-rgb24
        (boom-xrender-format-lookup xcb:renderutil:PICT_STANDARD:RGB_24))
  (setq boom-xrender-format-argb32
        (boom-xrender-format-lookup xcb:renderutil:PICT_STANDARD:ARGB_32)))

(defun boom-window-setup ()
  (setq boom-window (xcb:generate-id boom-x-conn))
  (xcb:+request boom-x-conn
      (xcb:CreateWindow :depth xcb:WindowClass:CopyFromParent
                        :wid boom-window
                        :parent (slot-value boom-x-screen 'root)
                        :x 0
                        :y 0
                        :width (* boom-canvas-width boom-scale)
                        :height (* boom-canvas-height boom-scale)
                        :border-width 0
                        :class xcb:WindowClass:InputOutput
                        :visual (slot-value boom-x-screen 'root-visual)
                        :value-mask (logior xcb:CW:BackPixel
                                            xcb:CW:EventMask)
                        :background-pixel (slot-value boom-x-screen 'black-pixel)
                        :event-mask (logior xcb:EventMask:Exposure
                                            xcb:EventMask:KeyPress
                                            ;; propagate window destroy event
                                            xcb:EventMask:StructureNotify))))

(defun boom-prop-setup ()
  (xcb:+request boom-x-conn
      (xcb:ChangeProperty :mode xcb:PropMode:Replace
                          :window boom-window
                          :property xcb:Atom:WM_NAME
                          :type xcb:Atom:STRING
                          :format 8
                          :data-len (length boom-window-title)
                          :data boom-window-title))
  (xcb:+request boom-x-conn
      (xcb:ChangeProperty :mode xcb:PropMode:Replace
                          :window boom-window
                          :property xcb:Atom:WM_CLASS
                          :type xcb:Atom:STRING
                          :format 8
                          :data-len (length boom-window-class)
                          :data boom-window-class)))

(defun boom-create-pen (color)
  (let ((pid (xcb:generate-id boom-x-conn)))
    (xcb:+request boom-x-conn
        (xcb:render:CreateSolidFill :picture pid :color color))
    pid))

(defun boom-color-setup ()
  (setq boom-color-black
        (xcb:render:COLOR :red 0 :green 0 :blue 0 :alpha #xFFFF))
  (setq boom-color-white
        (xcb:render:COLOR :red #xFFFF :green #xFFFF :blue #xFFFF :alpha #xFFFF))
  (setq boom-pen-black (boom-create-pen boom-color-black))
  (setq boom-pen-white (boom-create-pen boom-color-white)))

(defun boom-allocate-font ()
  (let ((gsid (xcb:generate-id boom-x-conn)))
    (push gsid boom-glyphset-list)
    gsid))

(defun boom-render-glyphs (src dst mask-format glyphset
                               src-x src-y dst-x dst-y string)
  (when (> (length string) 252)
    (user-error "STRING argument exceeds limit"))
  (let* ((encoded-length (unibyte-string (length string)))
         (padding (unibyte-string 0 0 0))
         (encoded-dst-x (if xcb:lsb
                            (xcb:-pack-u2-lsb dst-x)
                          (xcb:-pack-u2 dst-x)))
         (encoded-dst-x (apply #'unibyte-string (append encoded-dst-x ())))
         (encoded-dst-y (if xcb:lsb
                            (xcb:-pack-u2-lsb dst-y)
                          (xcb:-pack-u2 dst-y)))
         (encoded-dst-y (apply #'unibyte-string (append encoded-dst-y ())))
         (glyphcmds (concat encoded-length
                            padding
                            encoded-dst-x
                            encoded-dst-y
                            string)))
    (xcb:+request boom-x-conn
        (xcb:render:CompositeGlyphs8 :op xcb:render:PictOp:Over
                                     :src src
                                     :dst dst
                                     :mask-format mask-format
                                     :glyphset glyphset
                                     :src-x src-x
                                     :src-y src-y
                                     :glyphcmds glyphcmds))))

(defun boom-font-setup ()
  (setq boom-glyphset (boom-allocate-font))
  (setq boom-glyphinfo
        (xcb:render:GLYPHINFO :width unifont-glyph-width
                              :height unifont-glyph-height
                              :x 0 :y 0
                              :x-off unifont-glyph-width :y-off 0))
  (xcb:+request boom-x-conn
      (xcb:render:CreateGlyphSet :gsid boom-glyphset
                                 :format boom-xrender-format-a8))
  (let ((glyphs-len 0)
        glyphids
        data)
    (dotimes (i #x80)
      (let ((glyph-data (aref unifont-glyphs i)))
        (when glyph-data
          (setq glyphs-len (1+ glyphs-len))
          (push i glyphids)
          (push glyph-data data))))
    (setq glyphids (nreverse glyphids))
    (setq data (mapconcat #'identity (nreverse data) ""))
    (xcb:+request boom-x-conn
        (xcb:render:AddGlyphs :glyphset boom-glyphset
                              :glyphs-len glyphs-len
                              :glyphids glyphids
                              :glyphs (make-list glyphs-len boom-glyphinfo)
                              :data data))))

(defun boom-allocate-picture ()
  (let ((pid (xcb:generate-id boom-x-conn)))
    (push pid boom-picture-list)
    pid))

(defun boom-create-picture (width height)
  (let ((pm (xcb:generate-id boom-x-conn))
        (pid (boom-allocate-picture)))
    (xcb:+request boom-x-conn
        (xcb:CreatePixmap :pid pm
                          :drawable boom-window
                          :width width
                          :height height
                          :depth 32))
    (xcb:+request boom-x-conn
        (xcb:render:CreatePicture :pid pid
                                  :drawable pm
                                  :format boom-xrender-format-argb32
                                  :value-mask 0))
    (xcb:+request boom-x-conn (xcb:FreePixmap :pixmap pm))
    pid))

(defun boom-fill-picture (pid pen x y width height)
  (xcb:+request boom-x-conn
        (xcb:render:Composite :op xcb:render:PictOp:Over
                              :src pen
                              :mask 0
                              :dst pid
                              :src-x 0 :src-y 0
                              :mask-x 0 :mask-y 0
                              :dst-x x :dst-y y
                              :width width
                              :height height)))

(defun boom-clear-picture (pid x y width height)
  (xcb:+request boom-x-conn
      (xcb:render:Composite :op xcb:render:PictOp:Clear
                            :src boom-pen-white
                            :mask 0
                            :dst pid
                            :src-x 0 :src-y 0
                            :mask-x 0 :mask-y 0
                            :dst-x x :dst-y y
                            :width width :height height)))

(defun boom-copy-picture (src dst src-x src-y dst-x dst-y width height)
  (xcb:+request boom-x-conn
      (xcb:render:Composite :op xcb:render:PictOp:Over
                            :src src
                            :mask 0
                            :dst dst
                            :src-x src-x :src-y src-y
                            :mask-x 0 :mask-y 0
                            :dst-x dst-x :dst-y dst-y
                            :width width
                            :height height)))

(defun boom-clear-scene ()
  (boom-clear-picture boom-scene-picture 0 0 boom-canvas-width boom-canvas-height))

;; HACK: avoid name prefix
(eval-when-compile
  (defmacro tofixed (n)
    `(truncate (* ,n #x10000)))
  (defmacro clamp (a x b)
    `(min (max ,a ,x) ,b)))

(defun boom-identity-transform ()
  (xcb:render:TRANSFORM
   :matrix11 (tofixed 1) :matrix12 (tofixed 0) :matrix13 (tofixed 0)
   :matrix21 (tofixed 0) :matrix22 (tofixed 1) :matrix23 (tofixed 0)
   :matrix31 (tofixed 0) :matrix32 (tofixed 0) :matrix33 (tofixed 1)))

(defun boom-scaled-transform (scale)
  (let ((transform (boom-identity-transform))
        (coeff (tofixed (/ 1.0 scale))))
    (setf (slot-value transform 'matrix11) coeff)
    (setf (slot-value transform 'matrix22) coeff)
    transform))

(defun boom-init-crosshair-picture ()
  (let ((pid boom-crosshair-picture)
        (pen boom-pen-black)
        (width boom-crosshair-width)
        (height boom-crosshair-height))
    (boom-fill-picture pid pen 0 0 width height)
    (boom-clear-picture pid 1 1 (- width 2) (- height 2))
    (boom-clear-picture pid 4 0 (- width 8) height)
    (boom-clear-picture pid 0 4 width (- height 8))

    ;; HACK: reduce GC pressure by pre-computed request
    (setq boom-update-balls-composite-crosshair-request
          (xcb:render:Composite :op xcb:render:PictOp:Over
                                :src pid
                                :mask 0
                                :dst boom-scene-picture
                                :src-x 0 :src-y 0
                                :mask-x 0 :mask-y 0
                                :dst-x boom-crosshair-left
                                :dst-y boom-crosshair-top
                                :width width
                                :height height))))

(defun boom-triangulate-solid-circle (pid pen radius steps)
  (boom-clear-picture pid 0 0 (* radius 2) (* radius 2))
  (xcb:+request boom-x-conn
      (xcb:render:ChangePicture :picture pid
                                :value-mask (logior xcb:render:CP:PolyEdge
                                                    xcb:render:CP:PolyMode)
                                :polyedge xcb:render:PolyEdge:Smooth
                                :polymode xcb:render:PolyMode:Imprecise))
  ;; NOTE: https://gist.github.com/linusthe3rd/803118
  (let* ((center radius)
         (twice-pi (* float-pi 2))
         (center-point (xcb:render:POINTFIX :x (tofixed center)
                                            :y (tofixed center)))
         (triangle-points (list center-point))
         first-point)
    (dotimes (i steps)
      (let* ((x (+ center (* (cos (/ (* i twice-pi) steps)) radius)))
             (y (+ center (* (sin (/ (* i twice-pi) steps)) radius)))
             (point (xcb:render:POINTFIX :x (tofixed x) :y (tofixed y))))
        (when (zerop i)
          (setq first-point point))
        (push point triangle-points)))
    (push first-point triangle-points)
    (setq triangle-points (nreverse triangle-points))

    (xcb:+request boom-x-conn
        (xcb:render:TriFan :op xcb:render:PictOp:Add
                           :src pen
                           :dst pid
                           :mask-format 0
                           :src-x 0 :src-y 0
                           :points triangle-points))))

(defun boom-init-ball-pictures (min max)
  (setq boom-ball-pictures (make-vector (1+ max) nil))
  (dolist (size (number-sequence min max))
    (let ((pid (boom-create-picture size size))
          (radius (/ size 2)))
      (boom-triangulate-solid-circle pid boom-pen-black radius (+ size 4))
      (aset boom-ball-pictures size pid))))

(defun boom-assets-setup ()
  (setq boom-backbuffer (boom-allocate-picture))
  (setq boom-scene-picture (boom-create-picture boom-canvas-width
                                                boom-canvas-height))
  (xcb:+request boom-x-conn
      (xcb:render:CreatePicture :pid boom-backbuffer
                                :drawable boom-window
                                :format boom-xrender-format-rgb24
                                :value-mask 0))

  (setq boom-upscale-transform (boom-scaled-transform boom-scale))
  (setq boom-double-transform (boom-scaled-transform 2))
  (xcb:+request boom-x-conn
      (xcb:render:SetPictureTransform :picture boom-scene-picture
                                      :transform boom-upscale-transform))

  (setq boom-crosshair-picture (boom-create-picture boom-crosshair-width
                                                    boom-crosshair-height))
  (boom-init-crosshair-picture)
  (boom-init-ball-pictures boom-regular-ball-size boom-expanded-ball-size)

  (setq boom-update-balls-composite-ball-request
        (xcb:render:Composite :op xcb:render:PictOp:Over
                              :mask 0
                              :dst boom-scene-picture
                              :src-x 0 :src-y 0
                              :mask-x 0 :mask-y 0)))

(defun boom-scene-render-string (x y label)
  (boom-render-glyphs boom-pen-black boom-scene-picture 0 boom-glyphset
                      0 0 x y label))

(defun boom-scene-render-centered-string (label)
  (let* ((label-width (* (length label) unifont-glyph-width))
         (label-height unifont-glyph-height)
         (x (/ (- boom-canvas-width label-width) 2))
         (y (/ (- boom-canvas-height label-height) 2)))
    (boom-scene-render-string x y label)))

(defun boom-scene-render-bottom-string (label)
  (let* ((label-width (* (length label) unifont-glyph-width))
         (label-height unifont-glyph-height)
         (x (/ (- boom-canvas-width label-width) 2))
         (y (- boom-canvas-height (* label-height 2))))
    (boom-scene-render-string x y label)))

(defun boom-scene-clear-bottom-string ()
  (let ((label-height unifont-glyph-height)
        (x 0)
        (y (- boom-canvas-height (* unifont-glyph-height 2))))
    (boom-clear-picture boom-scene-picture x y boom-canvas-width label-height)))

(defun boom-reset-game ()
  (setq boom-balls nil)
  (setq boom-chain-started-p nil)
  (setq boom-chain-ticks nil))

(defun boom-start-screen ()
  (setq boom-current-screen 'start)
  (boom-clear-scene)
  (boom-scene-render-centered-string "BOOMSHINE")
  (boom-scene-render-bottom-string "Press SPC to continue")
  (boom-redraw))

(defun boom-level-announce-screen ()
  (setq boom-current-screen 'level-announce)
  (boom-clear-scene)
  (let* ((goal (aref boom-level-goals boom-current-level))
         (label (format "Level %d: Hit %d/%d balls"
                        (1+ boom-current-level)
                        (aref goal 0)
                        (aref goal 1))))
    (boom-scene-render-centered-string label)
    (setq label "Press SPC when ready (and to trigger the chain reaction)")
    (boom-scene-render-bottom-string label))
  (boom-redraw))

(defun boom-level-play-screen ()
  (setq boom-current-screen 'level-play)
  (boom-clear-scene)
  (boom-reset-game)
  (let* ((goal (aref boom-level-goals boom-current-level))
         (ball-count (aref goal 1))
         (max-x (- boom-canvas-width boom-regular-ball-size))
         (max-y (- boom-canvas-height boom-regular-ball-size)))
    (setq boom-balls (make-vector ball-count nil))
    (dotimes (i ball-count)
      (let* ((radius boom-regular-ball-radius)
             (px (random max-x))
             (cx (+ px radius))
             (py (random max-y))
             (cy (+ py radius))
             (dx (- (random 10) 5))
             (dx (if (zerop dx) 5 dx))
             (dy (- (random 10) 5))
             (dy (if (zerop dy) 5 dx))
             (ball (make-boom-ball :radius radius :cx cx :cy cy :dx dx :dy dy
                                   :state 'moving)))
        (aset boom-balls i ball))))
  (boom-redraw))

(defun boom-game-over-screen ()
  (setq boom-current-screen 'game-over)
  (boom-clear-scene)
  (boom-scene-render-centered-string "GAME OVER")
  (boom-scene-render-bottom-string "Press SPC for a new game (or q to quit)")
  (boom-redraw))

(defun boom-game-won-screen ()
  (setq boom-current-screen 'game-won)
  (boom-clear-scene)
  (boom-scene-render-centered-string "A winner is you!")
  (boom-scene-render-bottom-string "Press SPC for a new game (or q to quit)")
  (boom-redraw))

(defun boom-update-start-screen ()
  (let ((tick (% boom-ticks (* boom-fps 2))))
    (cond
     ((= tick 0)
      (boom-scene-render-bottom-string "Press SPC to continue")
      (boom-redraw))
     ((= tick boom-fps)
      (boom-scene-clear-bottom-string)
      (boom-redraw)))))

(defun boom-update-level-play-screen ()
  (dotimes (i (length boom-balls))
    (let* ((ball (aref boom-balls i))
           (radius (boom-ball-radius ball))
           (state (boom-ball-state ball)))
      (when (< (- (boom-ball-cx ball) radius) 0)
        (setf (boom-ball-dx ball) (- (boom-ball-dx ball))))
      (when (< (- (boom-ball-cy ball) radius) 0)
        (setf (boom-ball-dy ball) (- (boom-ball-dy ball))))
      (when (>= (+ (boom-ball-cx ball) radius) boom-canvas-width)
        (setf (boom-ball-dx ball) (- (boom-ball-dx ball))))
      (when (>= (+ (boom-ball-cy ball) radius) boom-canvas-height)
        (setf (boom-ball-dy ball) (- (boom-ball-dy ball))))

      (cond
       ((eq state 'moving)
        ;; ball is still moving, maybe it collided with a stopped one?
        (let (collisionp)
          (dotimes (j (length boom-balls))
            (let ((other (aref boom-balls j)))
              (when (and (not collisionp)
                         (not (= i j))  ; don't check itself
                         (not (eq (boom-ball-state other) 'moving)))
                ;; NOTE: collision of circle against circles
                ;; https://stackoverflow.com/a/1736741
                (let* ((distance-x (- (boom-ball-cx ball) (boom-ball-cx other)))
                       (distance-y (- (boom-ball-cy ball) (boom-ball-cy other)))
                       (distance-squared (+ (expt distance-x 2)
                                            (expt distance-y 2)))
                       (radius-sum (+ (boom-ball-radius ball)
                                      (boom-ball-radius other))))
                  (when (< distance-squared (expt radius-sum 2))
                    (setq collisionp t)
                    (setf (boom-ball-state ball) 'expanded)
                    (setf (boom-ball-ticks ball) boom-ticks)
                    (setq boom-chain-ticks boom-ticks)
                    (setf (boom-ball-radius ball) (* (boom-ball-radius ball) 2)))))))
          ;; if not, move it
          (when (not collisionp)
            (setf (boom-ball-cx ball) (+ (boom-ball-cx ball) (boom-ball-dx ball)))
            (setf (boom-ball-cy ball) (+ (boom-ball-cy ball) (boom-ball-dy ball))))))
       ((eq state 'expanded)
        (when (> (- boom-ticks (boom-ball-ticks ball))
                 boom-chain-timeout)
          ;; contract it after timeout, but only once
          (setf (boom-ball-radius ball) (/ (boom-ball-radius ball) 2))
          (setf (boom-ball-state ball) 'contracted))))))

  (boom-clear-scene)
  (dotimes (i (length boom-balls))
    (let* ((ball (aref boom-balls i))
           (radius (boom-ball-radius ball))
           (diameter (* radius 2)))
      (setf (slot-value boom-update-balls-composite-ball-request 'src)
            (aref boom-ball-pictures diameter))
      (setf (slot-value boom-update-balls-composite-ball-request 'dst-x)
            (- (boom-ball-cx ball) radius))
      (setf (slot-value boom-update-balls-composite-ball-request 'dst-y)
            (- (boom-ball-cy ball) radius))
      (setf (slot-value boom-update-balls-composite-ball-request 'width)
            diameter)
      (setf (slot-value boom-update-balls-composite-ball-request 'height)
            diameter)
      (xcb:+request boom-x-conn boom-update-balls-composite-ball-request)))
  (xcb:+request boom-x-conn boom-update-balls-composite-crosshair-request)
  (boom-redraw)

  (when (and boom-chain-ticks
             (> (- boom-ticks boom-chain-ticks) boom-chain-timeout))
    (let* ((goal (aref boom-level-goals boom-current-level))
           (min-stopped (aref goal 0))
           (actual-stopped 0))
      (dotimes (i (length boom-balls))
        (let ((ball (aref boom-balls i)))
          (when (not (eq (boom-ball-state ball) 'moving))
            (setq actual-stopped (1+ actual-stopped)))))
      (cond
       ((< actual-stopped min-stopped)
        (boom-game-over-screen))
       ((< boom-current-level boom-last-level)
        (boom-reset-game)
        (setq boom-current-level (1+ boom-current-level))
        (boom-level-announce-screen))
       (t
        (boom-game-won-screen))))))

(defun boom-update-scene ()
  (setq boom-ticks (1+ boom-ticks))
  (cond
   ((eq boom-current-screen 'start)
    (boom-update-start-screen))
   ((eq boom-current-screen 'level-play)
    (boom-update-level-play-screen))))

(defun boom-crosshair-collision-detection ()
  (let (collisionp)
    (dotimes (i (length boom-balls))
      (let ((ball (aref boom-balls i)))
        (when (eq (boom-ball-state ball) 'moving)
          ;; NOTE: collision of rectangle against circles
          ;; https://stackoverflow.com/a/1879223
          (let* ((radius (boom-ball-radius ball))
                 (ball-x (boom-ball-cx ball))
                 (ball-y (boom-ball-cy ball))
                 (closest-x (clamp boom-crosshair-left
                                   ball-x
                                   boom-crosshair-right))
                 (closest-y (clamp boom-crosshair-top
                                   ball-y
                                   boom-crosshair-bottom))
                 (distance-x (- ball-x closest-x))
                 (distance-y (- ball-y closest-y))
                 (distance-squared (+ (expt distance-x 2)
                                      (expt distance-y 2))))
            (when (< distance-squared (expt radius 2))
              (setq collisionp t)
              (setf (boom-ball-state ball) 'expanded)
              (setf (boom-ball-ticks ball) boom-ticks)
              (setq boom-chain-ticks boom-ticks)
              (setf (boom-ball-radius ball) (* (boom-ball-radius ball) 2)))))))
      collisionp))

(defun boom-redraw ()
  (let ((pid boom-backbuffer)
        (width (* boom-canvas-width boom-scale))
        (height (* boom-canvas-height boom-scale)))
    (boom-fill-picture pid boom-pen-white 0 0 width height)
    (boom-copy-picture boom-scene-picture pid 0 0 0 0 width height))
  (xcb:flush boom-x-conn))

(defun boom-expose-handler (&rest _args)
  (boom-redraw))

(defun boom-mod-active-p (mods mask)
  (not (zerop (logand mods mask))))

(defun boom-key-press-handler (data _synthetic)
  (let ((event (xcb:KeyPress)))
    (xcb:unmarshal event data)
    (let* ((keycode (slot-value event 'detail))
           (mod-mask (slot-value event 'state))
           (keysym-mods (xcb:keysyms:keycode->keysym boom-x-conn
                                                     keycode
                                                     mod-mask))
           (keysym (car keysym-mods))
           (mods (logand (lognot (cdr keysym-mods)) mod-mask))
           (metap (boom-mod-active-p mods xcb:keysyms:meta-mask))
           (ctrlp (boom-mod-active-p mods xcb:keysyms:control-mask))
           (shiftp (boom-mod-active-p mods xcb:keysyms:shift-mask))
           (hyperp (boom-mod-active-p mods xcb:keysyms:hyper-mask))
           (superp (boom-mod-active-p mods xcb:keysyms:super-mask))
           (altp (boom-mod-active-p mods xcb:keysyms:alt-mask))
           (nomodsp (and (not metap) (not ctrlp) (not shiftp)
                         (not hyperp) (not superp) (not altp))))
      (cond
       ((and (or (= keysym boom-keysym-escape)
                 (= keysym boom-keysym-q))
             nomodsp)
        (throw 'boom-quit t))
       ((and (= keysym boom-keysym-space) nomodsp)
        (cond
         ((eq boom-current-screen 'start)
          (boom-level-announce-screen))
         ((eq boom-current-screen 'level-announce)
          (setq boom-current-screen 'level-play)
          (boom-level-play-screen))
         ((eq boom-current-screen 'level-play)
          (when (not boom-chain-started-p)
            (setq boom-chain-ticks boom-ticks)
            (setq boom-chain-started-p t)
            (boom-crosshair-collision-detection)))
         ((memq boom-current-screen '(game-over game-won))
          (boom-reset-game)
          (setq boom-current-level 0)
          (boom-level-announce-screen))))))))

(defun boom-destroy-notify-handler (&rest _args)
  (throw 'boom-quit t))

(defun boom-event-handlers-setup ()
  (xcb:+event boom-x-conn 'xcb:Expose #'boom-expose-handler)
  (xcb:+event boom-x-conn 'xcb:KeyPress #'boom-key-press-handler)
  (xcb:+event boom-x-conn 'xcb:DestroyNotify #'boom-destroy-notify-handler))

(defun boom-init ()
  (xcb:+request boom-x-conn (xcb:MapWindow :window boom-window))
  (boom-start-screen)
  (xcb:flush boom-x-conn))

(defun boom-mainloop ()
  (setq boom-redraw-timer (run-at-time 0 (/ 1.0 boom-fps) #'boom-update-scene))
  (catch 'boom-quit
    (while t
      (sit-for 60))))

(defun boom-shutdown ()
  (dolist (picture boom-picture-list)
    (xcb:+request boom-x-conn (xcb:render:FreePicture :picture picture)))
  (dolist (glyphset boom-glyphset-list)
    (xcb:+request boom-x-conn (xcb:render:FreeGlyphSet :glyphset glyphset)))
  (xcb:+request boom-x-conn (xcb:DestroyWindow :window boom-window))
  (xcb:disconnect boom-x-conn))

(defun boom-new-game ()
  (interactive)
  (unwind-protect
      (progn
        (boom-x-setup)
        (boom-xrender-setup)
        (boom-window-setup)
        (boom-prop-setup)
        (boom-color-setup)
        (boom-font-setup)
        (boom-assets-setup)
        (boom-event-handlers-setup)
        (boom-init)
        (boom-mainloop))
    (boom-shutdown)))

(provide 'boom)

;; Local Variables:
;; firestarter: (byte-compile-file (buffer-file-name))
;; read-symbol-shorthands: (("make-boom-" . "make-xcb-boomshine-")
;;                          ("boom" . "xcb-boomshine")
;;                          ("boom-" . "xcb-boomshine-"))
;; End:

;;; xcb-boomshine.el ends here