;;; xcb-slides.el --- X11-only slideshow -*- 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/talks/chicken-village
;; Version: 0.0.1
;; Package-Requires: ((emacs "28.1"))
;; Keywords: multimedia

;; 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:

;; Slides data for a talk about X11 programming in elisp

;;; Code:

(require 'bindat)
(require 'seq)

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

(require 'unifont-glyphs)

(defconst slides-canvas-width 480)
(defconst slides-canvas-height 360)
(defconst slides-scale 2)
(defconst slides-window-width (* slides-canvas-width slides-scale))
(defconst slides-window-height (* slides-canvas-height slides-scale))
(defconst slides-window-title "Slides")
(defconst slides-window-class "Emacs")

(defconst slides-mouse-left 1)
(defconst slides-mouse-right 3)
(defconst slides-keysym-b #x62)
(defconst slides-keysym-n #x6e)
(defconst slides-keysym-p #x70)
(defconst slides-keysym-q #x71)
(defconst slides-keysym-escape #xff1b)
(defconst slides-keysym-up #xff52)
(defconst slides-keysym-down #xff54)
(defconst slides-keysym-space #x20)

(defvar slides-picture-list nil)
(defvar slides-glyphset-list nil)
(defvar slides-pixmap-list nil)

(defvar slides-images nil)
(defvar slides-picture-primitives nil)
(defvar slides-picture-emacsicon nil)
(defvar slides-picture-farbfeldhex nil)
(defvar slides-picture-farbfeldsize nil)
(defvar slides-picture-fontfixed nil)
(defvar slides-picture-emacsicon-glitch nil)
(defvar slides-picture-unifontdim-glitch nil)
(defvar slides-picture-unifontlsb-glitch nil)
(defvar slides-picture-uninitialized-glitch nil)
(defvar slides-picture-uninitialized2-glitch nil)
(defvar slides-picture-transparency nil)

(defvar slides-x-display nil)
(defvar slides-x-conn nil)
(defvar slides-x-screen nil)
(defvar slides-x-white-pixel nil)
(defvar slides-x-black-pixel nil)

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

(defvar slides-window-rect nil)
(defvar slides-window nil)

(defvar slides-upscale-transform nil)

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

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

(defvar slides-glyphset nil)
(defvar slides-glyphinfo nil)

(defvar slides-frame-list nil)
(defvar slides-frame-vector nil)
(defvar slides-current-frame 0)

(defvar slides-fps 50)
(defvar slides-timer nil)
(defvar slides-bounce-px 64)
(defvar slides-bounce-py 64)
(defvar slides-bounce-dx 5)
(defvar slides-bounce-dy 5)

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

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

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

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

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

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

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

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

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

(defun slides-render-glyphs (op 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 slides-x-conn
        (xcb:render:CompositeGlyphs8 :op op
                                     :src src
                                     :dst dst
                                     :mask-format mask-format
                                     :glyphset glyphset
                                     :src-x src-x
                                     :src-y src-y
                                     :glyphcmds glyphcmds))))

(defun slides-font-setup ()
  (setq slides-glyphset (slides-allocate-glyphset))
  (setq slides-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 slides-x-conn
      (xcb:render:CreateGlyphSet :gsid slides-glyphset
                                 :format slides-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 slides-x-conn
        (xcb:render:AddGlyphs :glyphset slides-glyphset
                              :glyphs-len glyphs-len
                              :glyphids glyphids
                              :glyphs (make-list glyphs-len slides-glyphinfo)
                              :data data))))

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

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

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

;; HACK: avoid name prefix
(eval-when-compile
  (defmacro tofixed (n)
    `(truncate (* ,n #x10000))))

(defun slides-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 slides-allocate-pixmap ()
  (let ((pm (xcb:generate-id slides-x-conn)))
    (push pm slides-pixmap-list)
    pm))

(defun slides-load-ff-picture (path glitchp)
  (let ((ff-size (bindat-type
                   (size uint 32))))
    (with-temp-buffer
      (set-buffer-multibyte nil)
      (insert-file-contents path)
      (goto-char (point-min))
      (when (not (looking-at "farbfeld"))
        (error "Not a farbfeld image"))
      (forward-char 8)
      (let* ((bytes (buffer-substring (point) (+ (point) 4)))
             (width (bindat-get-field (bindat-unpack ff-size bytes) 'size)))
        (forward-char 4)
        (let* ((bytes (buffer-substring (point) (+ (point) 4)))
               (height (bindat-get-field (bindat-unpack ff-size bytes) 'size)))
          (forward-char 4)
          (let ((end-of-headers (point)))
            (while (not (eobp))
              ;; HACK: discard each low byte
              (let ((r (char-after (point)))
                    (g (char-after (+ (point) 2)))
                    (b (char-after (+ (point) 4)))
                    (a (char-after (+ (point) 6))))
                (delete-region (point) (+ (point) 8))
                (if glitchp
                    (insert r g b a)
                  (insert b g r a))))
            (let ((data (buffer-substring end-of-headers (point-max)))
                  (pm (slides-allocate-pixmap))
                  (pid (slides-allocate-picture))
                  (gc (xcb:generate-id slides-x-conn)))
              (xcb:+request slides-x-conn
                  (xcb:CreatePixmap :pid pm
                                    :drawable slides-window
                                    :width width
                                    :height height
                                    :depth 32))
              (xcb:+request slides-x-conn
                  (xcb:CreateGC :cid gc :drawable pm :value-mask 0))
              (let* ((max-request-size (slot-value (xcb:get-setup slides-x-conn)
                                                   'maximum-request-length))
                     (metadata-size 6)
                     (max-pixels-size (- max-request-size metadata-size))
                     (pixels-size (* width height)))
                (if (<= pixels-size max-pixels-size)
                    (xcb:+request slides-x-conn
                        (xcb:PutImage :format xcb:ImageFormat:ZPixmap
                                      :drawable pm
                                      :gc gc
                                      :width width
                                      :height height
                                      :dst-x 0 :dst-y 0
                                      :left-pad 0
                                      :depth 32
                                      :data data))
                  ;; TODO: clean up the logic
                  (let ((stride (* width 4))
                        (y-offset 0)
                        (chunk-height (/ max-pixels-size width)))
                    (while (< y-offset height)
                      (let* ((chunk-beg (* y-offset stride))
                             (chunk-end (+ chunk-beg (* chunk-height stride)))
                             (chunk-end (min chunk-end (length data)))
                             (chunk (substring data chunk-beg chunk-end))
                             (chunk-height (/ (length chunk) stride)))
                        (xcb:+request slides-x-conn
                            (xcb:PutImage :format xcb:ImageFormat:ZPixmap
                                          :drawable pm
                                          :gc gc
                                          :width width
                                          :height chunk-height
                                          :dst-x 0 :dst-y y-offset
                                          :left-pad 0
                                          :depth 32
                                          :data chunk)))
                      (setq y-offset (+ y-offset chunk-height))))))
              (xcb:+request slides-x-conn (xcb:FreeGC :gc gc))
              (xcb:+request slides-x-conn
                  (xcb:render:CreatePicture :pid pid
                                            :drawable pm
                                            :format slides-xrender-format-argb32
                                            :value-mask 0))
              (list pid :width width :height height :path path))))))))

(defun slides-load-ff-image (path &optional glitchp)
  (let ((meta (slides-load-ff-picture path glitchp)))
    (push meta slides-images)
    (car meta)))

(defun slides-find-ff-image (path)
  (seq-some (lambda (meta)
              (let ((pid (car meta))
                    (props (cdr meta)))
                (when (equal (plist-get props :path) path)
                  pid)))
            slides-images))

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

  (setq slides-upscale-transform (slides-identity-transform))
  (let ((coeff (tofixed (/ 1.0 slides-scale))))
    (setf (slot-value slides-upscale-transform 'matrix11) coeff)
    (setf (slot-value slides-upscale-transform 'matrix22) coeff))
  (setq slides-picture-primitives
        (slides-load-ff-image "img/primitives.ff.bz2"))
  (setq slides-picture-emacsicon
        (slides-load-ff-image "img/emacsicon.ff.bz2"))
  (setq slides-picture-farbfeldhex
        (slides-load-ff-image "img/farbfeldhex.ff.bz2"))
  (setq slides-picture-farbfeldsize
        (slides-load-ff-image "img/farbfeldsize.ff.bz2"))
  (setq slides-picture-fontfixed
        (slides-load-ff-image "img/fontfixed.ff.bz2"))
  (setq slides-picture-emacsicon-glitch
        (slides-load-ff-image "img/emacsicon.ff.bz2" t))
  (setq slides-picture-unifontdim-glitch
        (slides-load-ff-image "img/unifontdim-glitch.ff.bz2"))
  (setq slides-picture-unifontlsb-glitch
        (slides-load-ff-image "img/unifontlsb-glitch.ff.bz2"))
  (setq slides-picture-uninitialized-glitch
        (slides-load-ff-image "img/uninitialized-glitch.ff.bz2"))
  (setq slides-picture-uninitialized2-glitch
        (slides-load-ff-image "img/uninitialized2-glitch.ff.bz2"))
  (setq slides-picture-transparency
        (slides-load-ff-image "img/transparency.ff.bz2")))

(defun slides-present ()
  (let* ((current-slide (aref slides-frame-vector slides-current-frame))
         (type (car current-slide))
         (content (cdr current-slide)))
    (cond
     ((eq type 'title-slide)
      (slides-clear-scene)
      (slides-present-title-slide content))
     ((eq type 'text-slide)
      (slides-clear-scene)
      (slides-present-text-slide content))
     (t
      (user-error "unknown slide type %s" type)))))

(defun slides-scene-render-glyphs (x y text)
  (slides-render-glyphs xcb:render:PictOp:Over
                        slides-pen-black
                        slides-scene-picture
                        0
                        slides-glyphset
                        0 0
                        x y
                        text))

(defun slides-present-title-slide (content)
  (let* ((title (plist-get content :title))
         (subtitle (plist-get content :subtitle))
         (text-height unifont-glyph-height)
         (text-y (/ (- slides-canvas-height text-height) 2)))
    (when title
      (let* ((text-width (* (length title) unifont-glyph-width))
             (text-x (/ (- slides-canvas-width text-width) 2)))
        (slides-scene-render-glyphs text-x text-y title)))
    (when subtitle
      (let* ((text-width (* (length subtitle) unifont-glyph-width))
             (text-x (/ (- slides-canvas-width text-width) 2)))
        (setq text-y (+ text-y text-height))
        (slides-scene-render-glyphs text-x text-y subtitle)))))

;; padding:  1.5 glyphs
;; headline: 1   glyph
;; padding:  0.5 glyphs
;; padding:  2.5 glyphs
;; content:  14  lines x 52 glyphs
;; padding:  0.5 glyphs
;; headline: 1   glyph
;; padding:  1.5 glyphs

(defun slides-present-text-slide (content)
  (let* ((title (plist-get content :title))
         (text (plist-get content :text))
         (picture (plist-get content :picture)))
    (when title
      (let* ((text-width (* (length title) unifont-glyph-width))
             (text-height unifont-glyph-height)
             (text-x (/ (- slides-canvas-width text-width) 2))
             (text-y (truncate (* text-height 1.5))))
        (slides-scene-render-glyphs text-x text-y title)))
    (let* ((text-x (* unifont-glyph-width 3))
           (text-y (truncate (* unifont-glyph-height 4.5))))
      (when text
        (dolist (line (split-string text "\n"))
          (slides-scene-render-glyphs text-x text-y line)
          (setq text-y (+ text-y unifont-glyph-height))))
      (when picture
        (let ((pid (funcall picture)))
          (when (not pid)
            (error "Picture not found %s" picture))
          (let* ((meta (alist-get pid slides-images))
                 (width (plist-get meta :width))
                 (height (plist-get meta :height))
                 (picture-x text-x)
                 (picture-y (+ text-y unifont-glyph-height)))
            (xcb:+request slides-x-conn
                (xcb:render:Composite :op xcb:render:PictOp:Src
                                      :src pid
                                      :mask 0
                                      :dst slides-scene-picture
                                      :src-x 0 :src-y 0
                                      :mask-x 0 :mask-y 0
                                      :dst-x picture-x :dst-y picture-y
                                      :width width
                                      :height height))))))
    (let* ((progress (format "%02d/%02d"
                             (1+ slides-current-frame)
                             (length slides-frame-vector)))
           (text-width (* (length progress) unifont-glyph-width))
           (text-x (/ (- slides-canvas-width text-width) 2))
           (text-y (* unifont-glyph-height 20)))
      (slides-scene-render-glyphs text-x text-y progress))))

(defun slides-update ()
  (let ((width 128)
        (height 128))
    (when (< slides-bounce-px 0)
      (setq slides-bounce-dx (- slides-bounce-dx)))
    (when (< slides-bounce-py 0)
      (setq slides-bounce-dy (- slides-bounce-dy)))
    (when (>= (+ slides-bounce-px width) slides-canvas-width)
      (setq slides-bounce-dx (- slides-bounce-dx)))
    (when (>= (+ slides-bounce-py height) slides-canvas-height)
      (setq slides-bounce-dy (- slides-bounce-dy)))
    (setq slides-bounce-px (+ slides-bounce-px slides-bounce-dx))
    (setq slides-bounce-py (+ slides-bounce-py slides-bounce-dy))
    (xcb:+request slides-x-conn
        (xcb:render:Composite :op xcb:render:PictOp:Over
                              :src slides-picture-emacsicon
                              :mask 0
                              :dst slides-scene-picture
                              :src-x 0 :src-y 0
                              :mask-x 0 :mask-y 0
                              :dst-x slides-bounce-px :dst-y slides-bounce-py
                              :width width
                              :height height))))

(defun slides-timer-function ()
  (slides-update)
  (slides-redraw))

(defun slides-define (definition)
  (push definition slides-frame-list))

(defun slides-backward ()
  (when (> slides-current-frame 0)
    (setq slides-current-frame (1- slides-current-frame))
    (slides-present)
    (slides-redraw)))

(defun slides-forward ()
  (when (< slides-current-frame (1- (length slides-frame-vector)))
    (setq slides-current-frame (1+ slides-current-frame))
    (slides-present)
    (slides-redraw)))

(defun slides-redraw ()
  (xcb:+request slides-x-conn
      (xcb:render:FillRectangles :op xcb:render:PictOp:Src
                                 :dst slides-backbuffer
                                 :color slides-color-white
                                 :rects (list slides-window-rect)))
  (xcb:+request slides-x-conn
      (xcb:render:SetPictureTransform :picture slides-scene-picture
                                      :transform slides-upscale-transform))
  (xcb:+request slides-x-conn
      (xcb:render:Composite :op xcb:render:PictOp:Over
                            :src slides-scene-picture
                            :mask 0
                            :dst slides-backbuffer
                            :src-x 0 :src-y 0
                            :mask-x 0 :mask-y 0
                            :dst-x 0 :dst-y 0
                            :width slides-window-width
                            :height slides-window-height))
  (xcb:flush slides-x-conn))

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

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

(defun slides-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 slides-x-conn
                                                     keycode
                                                     mod-mask))
           (keysym (car keysym-mods))
           (mods (logand (lognot (cdr keysym-mods)) mod-mask))
           (metap (slides-mod-active-p mods xcb:keysyms:meta-mask))
           (ctrlp (slides-mod-active-p mods xcb:keysyms:control-mask))
           (shiftp (slides-mod-active-p mods xcb:keysyms:shift-mask))
           (hyperp (slides-mod-active-p mods xcb:keysyms:hyper-mask))
           (superp (slides-mod-active-p mods xcb:keysyms:super-mask))
           (altp (slides-mod-active-p mods xcb:keysyms:alt-mask))
           (nomodsp (and (not metap) (not ctrlp) (not shiftp)
                         (not hyperp) (not superp) (not altp)))
           (shift-only-p (and (not metap) (not ctrlp) shiftp
                              (not hyperp) (not superp) (not altp))))
      (cond
       ((and (or (= keysym slides-keysym-escape) (= keysym slides-keysym-q))
             nomodsp)
        (throw 'slides-quit t))
       ((= keysym slides-keysym-space)
        (cond
         (shift-only-p
          (slides-backward))
         (nomodsp
          (slides-forward))))
       ((and (or (= keysym slides-keysym-p) (= keysym slides-keysym-up))
             nomodsp)
        (slides-backward))
       ((and (or (= keysym slides-keysym-n) (= keysym slides-keysym-down))
             nomodsp)
        (slides-forward))
       ((and (= keysym slides-keysym-b) nomodsp)
        (if slides-timer
            (progn
              (cancel-timer slides-timer)
              (setq slides-timer nil))
          (setq slides-timer
                (run-at-time 0 (/ 1.0 slides-fps) #'slides-timer-function))))))))

(defun slides-button-press-handler (data _synthetic)
  (let ((event (xcb:ButtonPress)))
    (xcb:unmarshal event data)
    (let ((button (slot-value event 'detail)))
      (cond
       ((= button slides-mouse-left)
        (slides-forward))
       ((= button slides-mouse-right)
        (slides-backward))))))

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

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

(defun slides-init ()
  (setq slides-frame-vector (vconcat (nreverse slides-frame-list)))
  (slides-present)
  (xcb:+request slides-x-conn (xcb:MapWindow :window slides-window))
  (xcb:flush slides-x-conn))

(defun slides-mainloop ()
  (catch 'slides-quit
    (while t
      (sit-for 60))))

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

(defun slides-start ()
  (unwind-protect
      (progn
        (slides-x-setup)
        (slides-xrender-setup)
        (slides-window-setup)
        (slides-prop-setup)
        (slides-color-setup)
        (slides-font-setup)
        (slides-assets-setup)
        (slides-event-handlers-setup)
        (require 'slides-data)
        (slides-init)
        (slides-mainloop))
    (slides-shutdown)))

(provide 'slides)

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

;;; xcb-slides.el ends here