toolkit.lisp

(in-package #:org.shirakumo.fraf.trial)

(defvar *native-array-element-types*
  (remove T (remove-duplicates
             (mapcar #'upgraded-array-element-type
                     (append '(fixnum short-float single-float double-float long-float)
                             (loop for i from 1 to 64 collect `(signed-byte ,i))
                             (loop for i from 1 to 64 collect `(unsigned-byte ,i))
                             '(base-char extended-char character)))
             :test #'equal)))

(defmacro define-global (name value)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     #+sbcl (sb-ext:defglobal ,name ,value)
     #-sbcl (defvar ,name ,value)
     (setf ,name ,value)))

(define-global +app-vendor+ "shirakumo")
(define-global +app-system+ "trial")
(define-global +main+ NIL)

(defconstant F-PI (float PI 0f0))
(defconstant F-2PI (float (* 2 PI) 0f0))
(defconstant F-PI/2 (float (* 0.5 PI) 0f0))

(defun git-repo-commit (dir)
  (flet ((file (path)
           (pathname-utils:merge-pathnames* path dir))
         (trim (string)
           (string-trim '(#\Return #\Linefeed #\Space) string)))
    (when (probe-file (file ".git/HEAD"))
      (let* ((head (trim (alexandria:read-file-into-string (file ".git/HEAD"))))
             (path (subseq head (1+ (or (position #\Space head) -1)))))
        (cond ((probe-file (file (merge-pathnames path ".git/")))
               (trim (alexandria:read-file-into-string (file (merge-pathnames path ".git/")))))
              ((probe-file (file ".git/packed-refs"))
               (with-open-file (stream (file ".git/packed-refs"))
                 (loop for line = (read-line stream NIL NIL)
                       while line
                       do (when (search path line :start2 40)
                            (return (subseq line 0 (position #\Space line))))))))))))

(defun self ()
  #-nx (first (uiop:raw-command-line-arguments))
  #+nx (make-pathname :device "rom" :name "sbcl" :directory '(:absolute)))

(defun checksum (file)
  (with-output-to-string (out)
    (loop for o across (sha3:sha3-digest-file file :output-bit-length 224)
          do (format out "~2,'0X" o))))

(defmethod version ((_ (eql :app)))
  (let ((commit #+asdf (git-repo-commit (asdf:system-source-directory +app-system+))))
    (format NIL "~a~@[-~a~]"
            #+asdf (asdf:component-version (asdf:find-system +app-system+))
            #-asdf "?"
            (when commit (subseq commit 0 7)))))

(defmethod version ((_ (eql :trial)))
  (let ((commit #+asdf (git-repo-commit (asdf:system-source-directory :trial))))
    (format NIL "~a~@[-~a~]"
            #+asdf (asdf:component-version (asdf:find-system :trial))
            #-asdf "?"
            (when commit (subseq commit 0 7)))))

(defmethod version ((_ (eql :binary)))
  (let ((self (self)))
    (if (and self (uiop:file-exists-p self) (not (uiop:featurep :nx)))
        (checksum self)
        "?")))

(let ((cache NIL))
  (defun data-root (&optional (app +app-system+))
    (if (deploy:deployed-p)
        (deploy:runtime-directory)
        (or cache #+asdf (setf cache (asdf:system-source-directory app))))))

(defgeneric coerce-object (object type &key))

(defmethod coerce-object (object type &key)
  (coerce object type))

(defmethod coerce-object :around (object type &key)
  (if (eql (type-of object) type)
      object
      (call-next-method)))

(defgeneric finalize (object))

(defmethod finalize :before ((object standard-object))
  (v:debug :trial "Finalizing ~a" object))

(defmethod finalize (object)
  object)

(defun round-to (base number)
  (* base (ceiling number base)))

(defun gl-property (name)
  (handler-case (gl:get* name)
    (error (err) (declare (ignore err))
      :unavailable)))

(defmethod apply-class-changes ((class standard-class)))

(defmethod apply-class-changes :before ((class standard-class))
  (dolist (super (c2mop:class-direct-superclasses class))
    (unless (c2mop:class-finalized-p super)
      (c2mop:finalize-inheritance super))))

(defmethod apply-class-changes :after ((class standard-class))
  (make-instances-obsolete class)
  (dolist (sub (c2mop:class-direct-subclasses class))
    (apply-class-changes sub)))

(define-global +current-time-units-per-second+ NIL)

(declaim (inline current-time))
(defun current-time ()
  (declare (optimize speed (safety 0)))
  (multiple-value-bind (s ms) (org.shirakumo.precise-time:get-monotonic-time)
    (let* ((s (logand s (1- (expt 2 62))))
           (ms (logand ms (1- (expt 2 62)))))
      (declare (type (unsigned-byte 62) s ms))
      (let ((inv (or +current-time-units-per-second+
                     (setf +current-time-units-per-second+
                           (coerce (/ org.shirakumo.precise-time:MONOTONIC-TIME-UNITS-PER-SECOND) 'double-float)))))
        (declare (type double-float inv))
        (+ s (* ms inv))))))

(defmacro undefmethod (name &rest args)
  (flet ((lambda-keyword-p (symbol)
           (find symbol lambda-list-keywords)))
    (destructuring-bind (qualifiers args) (loop for thing = (pop args)
                                                until (listp thing)
                                                collect thing into qualifiers
                                                finally (return (list qualifiers thing)))
      `(let ((method (find-method
                      #',name
                      ',qualifiers
                      (mapcar #'find-class
                              ',(loop for arg in args
                                      until (lambda-keyword-p arg)
                                      collect (if (listp arg) (second arg) T)))
                      NIL)))
         (if method
             (remove-method #',name method)
             NIL)))))

(defmacro define-unbound-reader (class method &body default)
  (destructuring-bind (method slot) (enlist method method)
    `(defmethod ,method ((,class ,class))
       (cond ((slot-boundp ,class ',slot)
              (slot-value ,class ',slot))
             (T
              ,@default)))))

(defun class-default-initargs (class-ish)
  (let ((class (etypecase class-ish
                 (symbol (find-class class-ish))
                 (standard-class class-ish))))
    (unless (c2mop:class-finalized-p class)
      (c2mop:finalize-inheritance class))
    (c2mop:class-default-initargs class)))

(defmethod copy-instance ((instance standard-object) &key deep)
  (let ((copy (allocate-instance (class-of instance))))
    (loop for slot in (c2mop:class-slots (class-of instance))
          for name = (c2mop:slot-definition-name slot)
          for value = (slot-value instance name)
          do (setf (slot-value copy name) (if deep (copy-instance value) value)))
    copy))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun kw (thing)
    (intern (string-upcase thing) "KEYWORD"))

  (defun mksym (package &rest parts)
    (let ((*print-case* (readtable-case *readtable*)))
      (intern (format NIL "~{~a~}" parts) package))))

(defun %lispify-name (name)
  (with-output-to-string (out)
    (loop with dash = T
          for char across name
          do (cond ((or #+sbcl (sb-unicode:whitespace-p char)
                        #-sbcl (find char '(#\Space #\Tab #\Linefeed #\Return))
                        (find char "-_,'`\"#;"))
                    (unless dash
                      (setf dash T)
                      (write-char #\- out)))
                   (T
                    (write-char (char-upcase char) out)
                    (setf dash NIL))))))

(defun lispify-name (name &optional (package "KEYWORD"))
  (etypecase name
    (integer name)
    (symbol name)
    (cons (cons (lispify-name (car name) package)
                (lispify-name (cdr name) package)))
    (string (intern (%lispify-name name) package))))

(defun enlist (item &rest items)
  (if (listp item) item (list* item items)))

(defun unlist (item)
  (if (listp item) (first item) item))

(defun unquote (item)
  (if (and (listp item) (eql 'quote (first item))) (second item) item))

(defun remf* (list &rest keys)
  (loop for (k v) on list by #'cddr
        for x = (member k keys)
        unless x collect k
        unless x collect v))

(defmacro popf (list key)
  (let ((value (gensym "VALUE"))
        (ksym (gensym "KEY")))
    `(let* ((,ksym ,key)
            (,value (getf ,list ,ksym)))
       (remf ,list ,ksym)
       ,value)))

(defun getf* (key list &key (test #'eql) default)
  (loop for (k v) on list by #'cddr
        do (when (funcall test key k) (return v))
        finally (return default)))

(defun remove-all (elements sequence &rest args)
  (apply #'remove-if (lambda (e) (member e elements)) sequence args))

(defun f32-vec (&rest args)
  (let ((array (make-array (length args) :element-type 'single-float)))
    (map-into array #'float args)))

(defun u32-vec (&rest args)
  (let ((array (make-array (length args) :element-type '(unsigned-byte 32))))
    (map-into array #'truncate args)))

(defun i32-vec (&rest args)
  (let ((array (make-array (length args) :element-type '(signed-byte 32))))
    (map-into array #'truncate args)))

(defmacro xor (a &rest options)
  (cond ((null options) a)
        (T
         (let ((found (gensym "FOUND")))
           `(let ((,found NIL))
              (block NIL
                ,@(loop for option in (list* a options)
                        collect `(when ,option
                                   (if ,found
                                       (return NIL)
                                       (setf ,found T))))
                ,found))))))

(defun one-of (thing &rest options)
  (find thing options))

(define-compiler-macro one-of (thing &rest options)
  (let ((thingg (gensym "THING")))
    `(let ((,thingg ,thing))
       (or ,@(loop for option in options
                   collect `(eql ,thingg ,option))))))

(defun input-source (&optional (stream *query-io*))
  (with-output-to-string (out)
    (loop for in = (read-line stream NIL NIL)
          while (and in (string/= in "EOF"))
          do (write-string in out))))

(defun input-value (&optional (stream *query-io*))
  (multiple-value-list (eval (read stream))))

(defun input-literal (&optional (stream *query-io*))
  (read stream))

(defmacro define-accessor-wrapper-methods (name &body wrappers)
  `(progn ,@(loop with value = (gensym "VALUE")
                  for (type resolution) in wrappers
                  collect `(defmethod ,name ((,type ,type))
                             (,name ,resolution))
                  collect `(defmethod (setf ,name) (,value (,type ,type))
                             (setf (,name ,resolution) ,value)))))

(defmacro define-accessor-delegate-methods (name &body wrappers)
  `(progn ,@(loop with value = (gensym "VALUE")
                  for (resolution type) in wrappers
                  collect `(defmethod ,name ((,type ,type))
                             (,resolution ,type))
                  collect `(defmethod (setf ,name) (,value (,type ,type))
                             (setf (,resolution ,type) ,value)))))

(defmacro with-retry-restart ((name report &rest report-args) &body body)
  (let ((tag (gensym "RETRY-TAG"))
        (return (gensym "RETURN"))
        (stream (gensym "STREAM")))
    `(block ,return
       (tagbody
          ,tag (restart-case
                   (return-from ,return
                     (progn ,@body))
                 (,name ()
                   :report (lambda (,stream) (format ,stream ,report ,@report-args))
                   (go ,tag)))))))

(defmacro with-new-value-restart ((place &optional (input 'input-value))
                                  (name report &rest report-args) &body body)
  (let ((tag (gensym "RETRY-TAG"))
        (return (gensym "RETURN"))
        (stream (gensym "STREAM"))
        (value (gensym "VALUE")))
    `(block ,return
       (tagbody
          ,tag (restart-case
                   (return-from ,return
                     (progn ,@body))
                 (,name (,value)
                   :report (lambda (,stream) (format ,stream ,report ,@report-args))
                   :interactive ,input
                   (setf ,place ,value)
                   (go ,tag)))))))

(defmacro with-unwind-protection (cleanup &body body)
  `(unwind-protect
        (progn ,@body)
     ,cleanup))

(defmacro with-cleanup-on-failure (cleanup-form &body body)
  (let ((success (gensym "SUCCESS")))
    `(let ((,success NIL))
       (unwind-protect
            (multiple-value-prog1
                (progn
                  ,@body)
              (setf ,success T))
         (unless ,success
           ,cleanup-form)))))

(defun constantly-restart (restart &rest values)
  (lambda (&rest args)
    (declare (ignore args))
    (apply #'invoke-restart restart values)))

(defmacro with-accessors* (accessors instance &body body)
  `(with-accessors ,(loop for accessor in accessors
                          collect (enlist accessor accessor))
       ,instance
     ,@body))

(defmacro with-accessor-values (bindings instance &body body)
  `(let ,(loop for binding in bindings
               for (var acc) = (enlist binding binding)
               collect `(,var (,acc ,instance)))
     ,@body))

(defun acquire-lock-with-starvation-test (lock &key (warn-time 10) timeout)
  (assert (or (null timeout) (< warn-time timeout)))
  (flet ((do-warn () (v:warn :trial.core "Failed to acquire ~a for ~s seconds. Possible starvation!"
                             lock warn-time)))
    #+sbcl (or (sb-thread:grab-mutex lock :timeout warn-time)
               (do-warn)
               (if timeout
                   (sb-thread:grab-mutex lock :timeout (- timeout warn-time))
                   (sb-thread:grab-mutex lock)))
    #-sbcl (loop with start = (get-universal-time)
                 for time = (- (get-universal-time) start)
                 thereis (bt:acquire-lock lock NIL)
                 do (when (and warn-time (< warn-time time))
                      (setf warn-time NIL)
                      (do-warn))
                    (when (and timeout (< timeout time))
                      (return NIL))
                    (bt:thread-yield))))

(defmacro with-trial-io-syntax ((&optional (package '*package*)) &body body)
  (let ((pkg (gensym "PACKAGE")))
    `(let ((,pkg (etypecase ,package
                   ((or string symbol) (find-package ,package))
                   (package ,package))))
       (with-standard-io-syntax
         (let ((*package* ,pkg)
               (*print-case* :downcase)
               (*print-readably* NIL))
           ,@body)))))

(defun parse-sexps (input)
  (with-trial-io-syntax ()
    (etypecase input
      (string
       (loop with i = 0
             collect (multiple-value-bind (data next) (read-from-string input NIL #1='#:EOF :start i)
                       (setf i next)
                       (if (eql data #1#)
                           (loop-finish)
                           data))))
      (stream
       (loop for value = (read input NIL #1#)
             until (eq value #1#)
             collect value)))))

(defun envvar-directory (var)
  (let ((var (uiop:getenv var)))
    (when (and var (string/= "" var))
      (pathname-utils:parse-native-namestring var :as :directory :junk-allowed T))))

(defun tempdir ()
  (or #+windows (or (envvar-directory "TEMP") #p"~/AppData/Local/Temp/")
      #+darwin (envvar-directory "TMPDIR")
      #+linux (envvar-directory "XDG_RUNTIME_DIR")
      #+nx (make-pathname :device "tmp" :directory '(:absolute))
      #p"/tmp/"))

(defun tempfile (&key (id (format NIL "trial-~a-~a" (get-universal-time) (random 1000)))
                      (type "tmp"))
  (make-pathname :name id
                 :type type
                 :defaults (tempdir)))

(defmacro with-tempfile ((path &rest args) &body body)
  `(let ((,path (tempfile ,@args)))
     (unwind-protect
          (progn ,@body)
       (when (probe-file ,path)
         (delete-file ,path)))))

(defun make-uuid (&optional (id NIL id-p))
  (let ((val (random #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF))
        (id (cond (id-p id)
                  (+main+ (sxhash (username +main+))))))
    (format NIL "~8,'0x-~4,'0x-~4,'0x-~4,'0x-~12,'0x"
            (ldb (byte 32  0) (or id val))
            (ldb (byte 16 32) val)
            (ldb (byte 16 48) val)
            (ldb (byte 16 64) val)
            (ldb (byte 48 80) val))))

(defun file-out-of-date-p (path default)
  (let ((path (probe-file path))
        (default (probe-file default)))
    (when default
      (or (null path)
          (< (file-write-date path) (file-write-date default))))))

(defun logfile ()
  (let ((log (or (uiop:getenv "TRIAL_LOGFILE") "")))
    (pathname-utils:merge-pathnames*
     (if (string= "" log)
         "trial.log"
         (pathname-utils:parse-native-namestring log))
     (or #+nx (tempdir) (uiop:argv0) (user-homedir-pathname)))))

(defun config-directory (&rest app-path)
  (apply #'pathname-utils:subdirectory
         (or (envvar-directory "TRIAL_CONFIG_HOME")
             #+windows
             (or (envvar-directory "AppData")
                 (pathname-utils:subdirectory (user-homedir-pathname) "AppData" "Roaming"))
             #+nx
             (make-pathname :device "save" :directory '(:absolute))
             (or (envvar-directory "XDG_CONFIG_HOME")
                 (pathname-utils:subdirectory (user-homedir-pathname) ".config")))
         (or app-path (list +app-vendor+ +app-system+))))

(defun standalone-logging-handler ()
  (when (deploy:deployed-p)
    (handler-case
        (when (logfile)
          (ignore-errors (delete-file (logfile)))
          (v:define-pipe ()
            (v:file-faucet :file (logfile))))
      (error (e)
        (v:error :trial "Failed to set up standalone logging handler: ~a" e)
        (setf (v:repl-level) :trace)))
    (v:info :trial "Running on ~a, ~a ~a, ~a ~a"
            (machine-instance) (machine-type) (machine-version)
            (software-type) (software-version))))

(defun make-thread (name func)
  (v:debug :trial "Spinning up thread: ~a" name)
  (bt:make-thread (lambda ()
                    (handler-bind ((error #'standalone-error-handler))
                      (funcall func)))
                  :name name
                  :initial-bindings `((*standard-output* . ,*standard-output*)
                                      (*error-output* . ,*error-output*)
                                      (*trace-output* . ,*trace-output*)
                                      (*standard-input* . ,*standard-input*)
                                      (*query-io* . ,*query-io*)
                                      (*debug-io* . ,*debug-io*)
                                      (*context* . ,*context*)
                                      (*package* . ,*package*))))

(defmacro with-thread ((name) &body body)
  `(make-thread ,name (lambda () ,@body)))

(defun wait-for-thread-exit (thread &key (timeout 1) (interval 0.1))
  (loop for i from 0
        while (bt:thread-alive-p thread)
        do (sleep interval)
           (when (= i (/ timeout interval))
             (restart-case
                 (error 'thread-did-not-exit :thread thread :timeout (* i interval))
               (continue ()
                 :report "Continue waiting.")
               (debug ()
                 :report "Try to interrupt the thread with a break."
                 (bt:interrupt-thread thread (lambda () (break))))
               (abort ()
                 :report "Kill the thread and exit, risking corrupting the image."
                 (bt:destroy-thread thread)
                 (return))))))

(defmacro with-thread-exit ((thread &key (timeout 1) (interval 0.1)) &body body)
  (let ((thread-g (gensym "THREAD")))
    `(let ((,thread-g ,thread))
       (when (and ,thread-g (bt:thread-alive-p ,thread-g))
         ,@body
         (wait-for-thread-exit ,thread-g :timeout ,timeout :interval ,interval)))))

(defmacro with-error-logging ((&optional (category :trial) (message "") &rest args) &body body)
  (let ((category-g (gensym "CATEGORY")))
    `(let ((,category-g ,category))
       (handler-bind ((error (lambda (err)
                               (v:severe ,category-g "~@[~@? ~]~a" ,message ,@args err)
                               (v:debug ,category-g err))))
         ,@body))))

(defmacro with-ignored-errors-on-release ((&optional (category :trial) (message "") &rest args) &body body)
  (declare (ignorable category message args))
  #+trial-release
  `(ignore-errors
    (with-error-logging (,category ,message ,@args)
      ,@body))
  #-trial-release
  `(with-simple-restart (continue "Ignore the error and continue.")
     ,@body))

(defmacro with-timing-report ((level category &optional (format "Operation took ~fs run-time ~fs real-time") &rest args) &body body)
  (let ((run (gensym "RUNTIME"))
        (real (gensym "REALTIME")))
    `(let ((,run (get-internal-run-time))
           (,real (get-internal-real-time)))
       (unwind-protect
            (progn ,@body)
         (v:log ,(kw level) ,category ,format ,@args
                (/ (- (get-internal-run-time) ,run) INTERNAL-TIME-UNITS-PER-SECOND)
                (/ (- (get-internal-real-time) ,real) INTERNAL-TIME-UNITS-PER-SECOND))))))

(defun format-timestring (&key (timestamp (get-universal-time)) (as :datetime))
  (multiple-value-bind (s m h dd mm yy) (decode-universal-time timestamp)
    (ecase as
      (:filename (format NIL "~4,'0d-~2,'0d-~2,'0d ~2,'0d-~2,'0d-~2,'0d" yy mm dd h m s))
      (:datetime (format NIL "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d" yy mm dd h m s))
      (:date (format NIL "~4,'0d-~2,'0d-~2,'0d" yy mm dd))
      (:time (format NIL "~2,'0d:~2,'0d:~2,'0d" h m s))
      (:clock (format NIL "~2,'0d:~2,'0d" h m)))))

(defgeneric descriptor (object))

(defmethod descriptor (object)
  (format NIL "~a@~4,'0x" (type-of object)
          #-sbcl (sxhash object)
          #+sbcl (sb-kernel:get-lisp-obj-address object)))

(defmethod descriptor ((number number))
  (format NIL "~a" number))

(defmethod descriptor ((string string))
  (format NIL "~s" string))

(defun simplify (array &optional (element-type (array-element-type array)))
  (if (and (typep array 'simple-array)
           (equal element-type (array-element-type array)))
      array
      (make-array (length array)
                  :element-type element-type
                  :initial-contents array)))

(defun ensure-instance (object type &rest initargs)
  (cond ((null object)
         (apply #'make-instance type initargs))
        ((eql (type-of object) type)
         (apply #'reinitialize-instance object initargs))
        (T
         (apply #'change-class object type initargs))))

(defun ensure-class (class-ish)
  (etypecase class-ish
    (symbol (find-class class-ish))
    (standard-class class-ish)
    (standard-object (class-of class-ish))))

(defun type-prototype (type)
  (case type
    (character #\Nul)
    (complex #c(0 0))
    (cons '(NIL . NIL))
    (float 0.0)
    (function #'identity)
    (hash-table (load-time-value (make-hash-table)))
    (integer 0)
    (null NIL)
    (package #.*package*)
    (pathname #p"")
    (random-state (load-time-value (make-random-state)))
    (readtable (load-time-value (copy-readtable)))
    (stream (load-time-value (make-broadcast-stream)))
    (string "string")
    (symbol 'symbol)
    (vector #(vector))
    (T (let ((class (find-class type)))
         (unless (c2mop:class-finalized-p class)
           (c2mop:finalize-inheritance class))
         (c2mop:class-prototype class)))))

(defun list-eql-specializers (function &rest args)
  (delete-duplicates
   (loop for method in (c2mop:generic-function-methods function)
         for spec = (loop for arg in args
                          collect (nth arg (c2mop:method-specializers method)))
         when (loop for arg in spec
                    thereis (typep arg 'c2mop:eql-specializer))
         collect (loop for arg in spec
                       collect (if (typep arg 'c2mop:eql-specializer) (c2mop:eql-specializer-object arg) arg)))))

(defun maybe-finalize-inheritance (class)
  (let ((class (etypecase class
                 (class class)
                 (symbol (find-class class)))))
    (unless (c2mop:class-finalized-p class)
      (c2mop:finalize-inheritance class))
    class))

(defun list-subclasses (class)
  (let ((sub (c2mop:class-direct-subclasses (ensure-class class))))
    (loop for class in sub
          nconc (list* class (list-subclasses class)))))

(defun list-leaf-classes (root)
  (let ((sub (c2mop:class-direct-subclasses (ensure-class root))))
    (if sub
        (remove-duplicates
         (loop for class in sub
               nconc (list-leaf-classes class)))
        (list (ensure-class root)))))

(defmacro with-slots-bound ((instance class) &body body)
  (let ((slots (loop for slot in (c2mop:class-direct-slots
                                  (let ((class (ensure-class class)))
                                    (c2mop:finalize-inheritance class)
                                    class))
                     for name = (c2mop:slot-definition-name slot)
                     collect name)))
    `(with-slots ,slots ,instance
       (declare (ignorable ,@slots))
       ,@body)))

(defmacro with-all-slots-bound ((instance class) &body body)
  (let ((slots (loop for slot in (c2mop:class-slots
                                  (let ((class (ensure-class class)))
                                    (c2mop:finalize-inheritance class)
                                    class))
                     for name = (c2mop:slot-definition-name slot)
                     collect name)))
    `(with-slots ,slots ,instance
       (declare (ignorable ,@slots))
       ,@body)))

(defmethod find-slot ((name symbol) (class class))
  (unless (c2mop:class-finalized-p class)
    (c2mop:finalize-inheritance class))
  (find name (c2mop:class-slots class)))

(defmethod find-slot (name (object standard-object))
  (find-slot name (class-of object)))

(defmethod construct-delegate-object-type (delegate base &rest args)
  (apply #'make-instance delegate args))

(defmacro define-constant-fold-function (name (arg) &body body)
  (let ((whole (gensym "WHOLE"))
        (env (gensym "ENV"))
        (thunk (mksym (symbol-package name) "%" name)))
    `(progn
       (defun ,thunk (,arg)
         ,@body)
       (setf (fdefinition ',name) #',thunk)
       (define-compiler-macro ,name (&whole ,whole &environment ,env ,arg)
         (if (constantp ,arg ,env)
             `(load-time-value (,',thunk ,,arg))
             ,whole)))))

(defgeneric clone (thing &key &allow-other-keys))
(defgeneric <- (target source)
  (:method-combination progn :most-specific-last))
(defgeneric initargs (thing)
  (:method-combination append :most-specific-last))

(defmethod initargs append (thing) ())
(defmethod clone (thing &key) thing)
(defmethod <- progn (a b))

(defmethod clone ((vec vec2) &key) (vcopy vec))
(defmethod <- progn ((target vec2) (source vec2)) (v<- target source))
(defmethod clone ((vec vec3) &key) (vcopy vec))
(defmethod <- progn ((target vec3) (source vec3)) (v<- target source))
(defmethod clone ((vec vec4) &key) (vcopy vec))
(defmethod <- progn ((target vec4) (source vec4)) (v<- target source))
(defmethod clone ((mat mat2) &key) (mcopy mat))
(defmethod <- progn ((target mat2) (source mat2)) (m<- target source))
(defmethod clone ((mat mat3) &key) (mcopy mat))
(defmethod <- progn ((target mat3) (source mat3)) (m<- target source))
(defmethod clone ((mat mat4) &key) (mcopy mat))
(defmethod <- progn ((target mat4) (source mat4)) (m<- target source))
(defmethod clone ((mat matn) &key) (mcopy mat))
(defmethod <- progn ((target matn) (source matn)) (m<- target source))
(defmethod clone ((quat quat) &key) (qcopy quat))
(defmethod <- progn ((target quat) (source quat)) (q<- target source))

(defmethod clone ((cons cons) &key)
  (cons (clone (car cons)) (clone (cdr cons))))

(defmethod clone ((array array) &key)
  (if (array-has-fill-pointer-p array)
      (make-array (array-dimensions array)
                  :element-type (array-element-type array)
                  :adjustable (adjustable-array-p array)
                  :fill-pointer (fill-pointer array)
                  :initial-contents array)
      (make-array (array-dimensions array)
                  :element-type (array-element-type array)
                  :adjustable (adjustable-array-p array)
                  :initial-contents array)))

(defmethod clone ((object standard-object) &rest initargs)
  (<- (apply #'make-instance (class-of object) initargs) object))

(defmacro define-transfer (class &body properties)
  `(defmethod <- progn ((target ,class) (source ,class))
     ,@(loop for property in properties
             collect (if (and (listp property) (eql :eval (first property)))
                         `(progn ,@(rest property))
                         (destructuring-bind (target-accessor &optional (source-accessor target-accessor) (key 'identity)) (enlist property)
                           `(setf (,target-accessor target) (,key (,source-accessor source))))))
     target))

(defmethod location ((vec vec2)) vec)

(defmethod location ((vec vec3)) vec)

(defmethod location ((mat mat3))
  (with-fast-matref (m mat)
    (vec (m 0 2) (m 1 2))))

(defmethod location ((mat mat4))
  (with-fast-matref (m mat)
    (vec (m 0 3) (m 1 3) (m 2 3))))

(defmethod orientation ((mat mat4))
  (qfrom-mat mat))

(defmethod global-location ((vec vec2) &optional (target (vec3)))
  (let ((vec (vec (vx vec) (vy vec) 0 0)))
    (declare (dynamic-extent vec))
    (n*m (model-matrix) vec)
    (vsetf target (vx vec) (vy vec) (vz vec))))

(defmethod global-location ((vec vec3) &optional (target (vec3)))
  (let ((vec (vec (vx vec) (vy vec) (vz vec) 0)))
    (declare (dynamic-extent vec))
    (n*m (model-matrix) vec)
    (vsetf target (vx vec) (vy vec) (vz vec))))

(defun initarg-slot (class initarg)
  (let ((class (etypecase class
                 (class class)
                 (symbol (find-class class)))))
    (find (list initarg) (c2mop:class-slots class)
          :key #'c2mop:slot-definition-initargs
          :test #'subsetp)))

(defun initarg-slot-value (instance initarg)
  (slot-value instance (c2mop:slot-definition-name (initarg-slot (class-of instance) initarg))))

(defun minimize (sequence test &key (key #'identity))
  (etypecase sequence
    (vector (when (< 0 (length sequence))
              (loop with minimal = (aref sequence 0)
                    for i from 1 below (length sequence)
                    for current = (aref sequence i)
                    do (when (funcall test
                                      (funcall key current)
                                      (funcall key minimal))
                         (setf minimal current))
                    finally (return minimal))))
    (list (when sequence
            (loop with minimal = (car sequence)
                  for current in (rest sequence)
                  do (when (funcall test
                                    (funcall key current)
                                    (funcall key minimal))
                       (setf minimal current))
                  finally (return minimal))))))

(defun format-with-line-numbers (text &optional out)
  (etypecase out
    (null
     (with-output-to-string (out)
       (format-with-line-numbers text out)))
    ((eql T)
     (format-with-line-numbers text *standard-output*))
    (stream
     (with-input-from-string (in text)
       (loop for i from 1
             for line = (read-line in NIL)
             while line
             do (format out "~3d " i)
                (write-line line out))))))

(defun generate-name (&optional indicator)
  (loop for name = (format NIL "~a-~d" (or indicator "ENTITY") (incf *gensym-counter*))
        while (find-symbol name *package*)
        finally (return (intern name *package*))))

(declaim (inline clamp))
(defun clamp (low mid high)
  (max low (min mid high)))

(declaim (inline deadzone))
(defun deadzone (min thing)
  (if (< (abs thing) min) 0.0 thing))

(declaim (inline lpf))
(defun lpf (factor cur target)
  (+ (* (- 1.0 factor) target) (* cur factor)))

(declaim (inline lerp))
(defun lerp (from to n)
  (etypecase from
    (real (+ (* from (- 1.0 n)) (* to n)))
    (vec (vlerp from to n))))

(declaim (inline lerp-dt))
(defun lerp-dt (from to dt rem)
  ;; REM: remaining time to get to TO.
  (declare (optimize speed))
  (let* ((l (- (/ (float rem 0f0)
                  (float (log 1/100 2) 0f0))))
         (n (- 1 (expt 2 (- (/ (float dt 0f0) l))))))
    (declare (type single-float n l))
    (lerp from to n)))

(declaim (inline deg->rad rad->deg))
(defun deg->rad (deg)
  (* deg PI 1/180))

(defun rad->deg (rad)
  (* rad 180 (/ PI)))

(defun db (db)
  (expt 10 (* 0.05 db)))

(defun angle-midpoint (a b)
  (when (< b a) (rotatef a b))
  (when (< PI (- b a)) (decf b F-2PI))
  (mod (/ (+ b a) 2) F-2PI))

(defun angle-distance (a b)
  (let ((da (mod (- b a) F-2PI)))
    (- (mod (* 2 da) F-2PI) da)))

(defun clamp-angle (min a max)
  (flet ((normalize-180 (a)
           (- (mod (+ a F-PI) F-2PI) F-PI)))
    (let* ((a (mod a F-2PI))
           (n-min (normalize-180 (- min a)))
           (n-max (normalize-180 (- max a))))
      (cond ((and (<= n-min 0) (<= 0 n-max))
             a)
            ((< (abs n-min) (abs n-max))
             min)
            (T
             max)))))

(defun lerp-angle (a b x)
  (let ((d (- b a)))
    (cond ((< (+ F-PI) d) (incf a F-2PI))
          ((< d (- F-PI)) (decf a F-2PI)))
    (+ a (* (- b a) x))))

#-3d-math-u32
(progn
  (declaim (inline uvarr2 uvarr3 uvarr4 uvec2 uvec3 uvec4))
  (defun uvarr2 (a) (ivarr2 a))
  (defun uvarr3 (a) (ivarr3 a))
  (defun uvarr4 (a) (ivarr4 a))
  (defun uvec2 (&rest args) (apply #'ivec2 args))
  (defun uvec3 (&rest args) (apply #'ivec3 args))
  (defun uvec4 (&rest args) (apply #'ivec4 args)))

(defparameter *c-chars* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_[]")

(defun symbol->c-name (symbol &optional out)
  (flet ((frob (out)
           (loop for c across (symbol-name symbol)
                 do (cond ((char= c #\-)
                           (write-char #\_ out))
                          ((find c *c-chars*)
                           (write-char (char-downcase c) out))
                          (T (write-char #\_ out))))))
    (if out
        (frob out)
        (with-output-to-string (out)
          (frob out)))))

(defun c-name->symbol (name &optional (package *package*))
  (intern
   (with-output-to-string (out)
     (loop for c across name
           do (cond ((char= c #\_)
                     (write-char #\- out))
                    (T
                     (write-char (char-upcase c) out)))))
   package))

(defun gl-vendor ()
  (let ((vendor (gl:get-string :vendor)))
    (cond ((search "Intel" vendor) :intel)
          ((search "NVIDIA" vendor) :nvidia)
          ((search "ATI" vendor) :amd)
          ((search "AMD" vendor) :amd)
          (T :unknown))))

(defun check-texture-size (width height)
  (let ((max (gl:get* :max-texture-size)))
    (when (< max (max width height))
      (error "Hardware cannot support a texture of size ~ax~a, max is ~a."
             width height max))))

(defmacro define-enum-check (name &body cases)
  (let* ((*print-case* (readtable-case *readtable*))
         (list (mksym *package* "*" name "-" '#:list "*"))
         (func (mksym *package* '#:check "-" name))
         (funcp (mksym *package* name '#:-p)))
    `(progn (defparameter ,list '(,@cases))
            (defun ,func (enum)
              (unless (member enum ,list)
                (error "~a is not a valid ~a. Needs to be one of the following:~%~a"
                       enum ',name ,list)))
            (defun ,funcp (enum)
              (member enum ,list)))))

(define-enum-check texture-target
  :texture-1d :texture-2d :texture-3d
  :texture-1d-array :texture-2d-array
  :texture-cube-map :texture-cube-map-array
  :texture-2d-multisample :texture-2d-multisample-array)

(define-enum-check texture-mag-filter
  :nearest :linear)

(define-enum-check texture-min-filter
  :nearest :linear :nearest-mipmap-nearest :nearest-mipmap-linear
  :linear-mipmap-nearest :linear-mipmap-linear)

(define-enum-check texture-wrapping
  :repeat :mirrored-repeat :clamp-to-edge :clamp-to-border)

(define-enum-check texture-internal-format
  :red :r8 :r8-snorm :r8i :r8ui
  :r16 :r16-snorm :r16f :r16i :r16ui
  :r32f :r32i :r32ui
  :rg :rg8 :rg8-snorm :rg8i :rg8ui
  :rg16 :rg16-snorm :rg16f :rg16i :rg16ui
  :rg32f :rg32i :rg32ui
  :rgb :rgb8 :rgb8-snorm :rgb8i :rgb8ui
  :r3-g3-b2 :rgb4 :rgb5 :rgb9-e5 :rgb10 :r11f-g11f-b10f :rgb12
  :rgb16-snorm :rgb16f :rgb16i :rgb16ui
  :rgb32f :rgb32i :rgb32ui
  :rgba :rgba2 :rgba4 :rgb5-a1 :rgb10-a2 :rgb10-a2ui :rgba12
  :rgba8 :rgba8-snorm :rgba8i :rgba8ui
  :rgba16 :rgba16f :rgba16i :rgba16ui
  :rgba32f :rgba32i :rgba32ui
  :srgb :srgb-alpha :srgb8 :srgb8-alpha8
  :depth-component :depth-component16 :depth-component24 :depth-component32 :depth-component32f
  :stencil-index :stencil-index1 :stencil-index4 :stencil-index8 :stencil-index16
  :depth-stencil :depth24-stencil8 :depth32f-stencil8
  :compressed-red :compressed-red-rgtc1 :compressed-signed-red-rgtc1
  :compressed-rg :compressed-rg-rgtc2 :compressed-signed-rg-rgtc2
  :compressed-rgb :compressed-rgb-bptc-signed-float :compressed-rgb-bptc-unsigned-float
  :compressed-rgba :compressed-rgba-bptc-unorm
  :compressed-srgb :compressed-srgb-alpha :compressed-srgb-alpha-bptc-unorm)

(define-enum-check texture-pixel-format
  :red :rg :rgb :bgr :rgba :bgra
  :red-integer :rg-integer :rgb-integer
  :bgr-integer :rgba-integer :bgra-integer
  :stencil-index :depth-component :depth-stencil)

(define-enum-check texture-pixel-type
  :unsigned-byte :byte
  :unsigned-short :short
  :unsigned-int :int
  :half-float :float
  :unsigned-byte-3-3-2 :unsigned-byte-2-3-3-rev
  :unsigned-short-5-6-5 :unsigned-short-5-6-5-rev
  :unsigned-short-4-4-4-4 :unsigned-short-4-4-4-4-rev
  :unsigned-short-5-5-5-1 :unsigned-short-1-5-5-5-rev
  :unsigned-int-8-8-8-8 :unsigned-int-8-8-8-8-rev
  :unsigned-int-10-10-10-2 :unsigned-int-2-10-10-10-rev
  :unsigned-int-24-8 :float-32-unsigned-int-24-8-rev
  :unsigned-int-5-9-9-9-rev)

(define-enum-check shader-type
  :compute-shader :vertex-shader
  :geometry-shader :fragment-shader
  :tess-control-shader :tess-evaluation-shader)

(define-enum-check vertex-buffer-element-type
  :byte :unsigned-byte :short :unsigned-short :int :unsigned-int
  :half-float :float :double :fixed)

(define-enum-check buffer-object-type
  :array-buffer :atomic-counter-buffer
  :copy-read-buffer :copy-write-buffer
  :dispatch-indirect-buffer :draw-indirect-buffer
  :element-array-buffer :pixel-pack-buffer
  :pixel-unpack-buffer :query-buffer
  :shader-storage-buffer :texture-buffer
  :transform-feedback-buffer :uniform-buffer)

(define-enum-check buffer-object-data-usage
  :stream-draw :stream-read :stream-copy :static-draw
  :static-read :static-copy :dynamic-draw :dynamic-read
  :dynamic-copy)

(define-enum-check framebuffer-attachment
  :color-attachment0 :color-attachment1 :color-attachment2 :color-attachment3
  :color-attachment4 :color-attachment5 :color-attachment6 :color-attachment7
  :depth-attachment :stencil-attachment :depth-stencil-attachment)

(define-enum-check sampler-type
  :sampler-1d
  :sampler-2d
  :sampler-3d
  :sampler-cube
  :sampler-1d-shadow
  :sampler-2d-shadow
  :sampler-1d-array
  :sampler-2d-array
  :sampler-1d-array-shadow
  :sampler-2d-array-shadow
  :sampler-2d-multisample
  :sampler-2d-multisample-array
  :sampler-cube-shadow
  :sampler-buffer
  :sampler-2d-rect
  :sampler-2d-rect-shadow
  :int-sampler-1d
  :int-sampler-2d
  :int-sampler-3d
  :int-sampler-cube
  :int-sampler-1d-array
  :int-sampler-2d-array
  :int-sampler-2d-multisample
  :int-sampler-2d-multisample-array
  :int-sampler-buffer
  :int-sampler-2d-rect
  :unsigned-int-sampler-1d
  :unsigned-int-sampler-2d
  :unsigned-int-sampler-3d
  :unsigned-int-sampler-cube
  :unsigned-int-sampler-1d-array
  :unsigned-int-sampler-2d-array
  :unsigned-int-sampler-2d-multisample
  :unsigned-int-sampler-2d-multisample-array
  :unsigned-int-sampler-buffer
  :unsigned-int-sampler-2d-rect
  :image-1d
  :image-2d
  :image-3d
  :image-2d-rect
  :image-cube
  :image-buffer
  :image-1d-array
  :image-2d-array
  :image-2d-multisample
  :image-2d-multisample-array
  :int-image-1d
  :int-image-2d
  :int-image-3d
  :int-image-2d-rect
  :int-image-cube
  :int-image-buffer
  :int-image-1d-array
  :int-image-2d-array
  :int-image-2d-multisample
  :int-image-2d-multisample-array
  :unsigned-int-image-1d
  :unsigned-int-image-2d
  :unsigned-int-image-3d
  :unsigned-int-image-2d-rect
  :unsigned-int-image-cube
  :unsigned-int-image-buffer
  :unsigned-int-image-1d-array
  :unsigned-int-image-2d-array
  :unsigned-int-image-2d-multisample
  :unsigned-int-image-2d-multisample-array)

(defun internal-format-components (format)
  (ecase format
    ((:red :r8 :r8-snorm :r8i :r8ui
      :r16 :r16-snorm :r16f :r16i :r16ui
      :r32f :r32i :r32ui
      :compressed-red :compressed-red-rgtc1
      :compressed-signed-red-rgtc1) 1)
    ((:rg :rg8 :rg8-snorm :rg8i :rg8ui :gr
      :rg16 :rg16-snorm :rg16f :rg16i :rg16ui
      :compressed-rg :compressed-rg-rgtc2 :compressed-signed-rg-rgtc2) 2)
    ((:rg32f :rg32i :rg32ui :bgr
      :rgb :rgb8 :rgb8-snorm :rgb8i :rgb8ui
      :r3-g3-b2 :rgb4 :rgb5 :rgb9-e5 :rgb10 :r11f-g11f-b10f :rgb12
      :rgb16-snorm :rgb16f :rgb16i :rgb16ui
      :rgb32f :rgb32i :rgb32ui :srgb8
      :compressed-rgb :compressed-rgb-bptc-signed-float
      :compressed-rgb-bptc-unsigned-float :compressed-srgb) 3)
    ((:rgba :bgra :rgba2 :rgba4 :rgb5-a1 :rgb10-a2 :rgb10-a2ui :rgba12
      :rgba8 :rgba8-snorm :rgba8i :rgba8ui
      :rgba16 :rgba16f :rgba16i :rgba16ui
      :rgba32f :rgba32i :rgba32ui :srgb8-alpha8
      :compressed-rgba :compressed-rgba-bptc-unorm
      :compressed-srgb-alpha :compressed-srgb-alpha-bptc-unorm) 4)
    ((:depth-component :depth-component16 :depth-component24 :depth-component32 :depth-component32f
      :stencil-index :stencil-index1 :stencil-index4 :stencil-index8 :stencil-index16) 1)
    ((:depth-stencil :depth24-stencil8 :depth32f-stencil8) 2)))

(defun internal-format-pixel-format (format)
  (ecase format
    ((:stencil-index :stencil-index1 :stencil-index4 :stencil-index8 :stencil-index16)
     :stencil-index)
    ((:depth-component :depth-component16 :depth-component24 :depth-component32 :depth-component32f)
     :depth-component)
    ((:depth-stencil :depth24-stencil8 :depth32f-stencil8)
     :depth-stencil)
    ((:r8i :r16i :r32i :r8ui :r16ui :r32ui)
     :red-integer)
    ((:rg8i :rg16i :rg32i :rg8ui :rg16ui :rg32ui)
     :rg-integer)
    ((:gr8i :gr16i :gr32i :gr8ui :gr16ui :gr32ui)
     :gr-integer)
    ((:rgb8i :rgb16i :rgb32i :rgb8ui :rgb16ui :rgb32ui)
     :rgb-integer)
    ((:bgr8i :bgr16i :bgr32i :bgr8ui :bgr16ui :bgr32ui)
     :bgr-integer)
    ((:rgba8i :rgba16i :rgba32i :rgba8ui :rgba16ui :rgba32ui)
     :rgba-integer)
    ((:bgra8i :bgra16i :bgra32i :bgra8ui :bgra16ui :bgra32ui)
     :bgra-integer)
    ((:red :r8 :r16 :r32 :r16f :r32f)
     :red)
    ((:rg :rg8 :rg16 :rg32 :rg16f :rg32f)
     :rg)
    ((:gr :gr8 :gr16 :gr32 :gr16f :gr32f)
     :gr)
    ((:rgb :rgb8 :rgb16 :rgb32 :rgb16f :rgb32f :rgb9-e5)
     :rgb)
    ((:bgr :bgr8 :bgr16 :bgr32 :bgr16f :bgr32f)
     :bgr)
    ((:rgba :rgba8 :rgba16 :rgba32 :rgba16f :rgba32f)
     :rgba)
    ((:bgra :bgra8 :bgra16 :bgra32 :bgra16f :bgra32f)
     :bgra)))

(defun internal-format-pixel-type (format)
  (ecase format
    ((:red :r8 :r8-norm :rg :rg8 :rg8-snorm :rgb :rgb8 :rgb8-snorm :rgba :rgba8 :rgba8-snorm
      :r8ui :rg8ui :rgb8ui :rgba8ui :depth-component :stencil-index :stencil-index1 :stencil-index
      :stencil-index8)
     :unsigned-byte)
    ((:r16 :r16-snorm :rg16 :rg16-snorm :rgb16 :rgb16-snorm :rgba16 :rgba16-snorm
      :r16ui :rg16ui :rgb16ui :rgba16ui :depth-component16 :stencil-index16)
     :unsigned-short)
    ((:r32 :r32-snorm :rg32 :rg32-snorm :rgb32 :rgb32-snorm :rgba32 :rgba32-snorm
      :r32ui :rg32ui :rgb32ui :rgba32ui :depth-component24 :depth-component32)
     :unsigned-int)
    ((:r8i :rg8i :rgb8i :rgba8i)
     :byte)
    ((:r16i :rg16i :rgb16i :rgba16i)
     :short)
    ((:r32i :rg32i :rgb32i :rgba32i)
     :int)
    ((:r16f :rg16f :rgb16f :rgba16f)
     :half-float)
    ((:r32f :rg32f :rgb32f :rgba32f :depth-component32f)
     :float)
    (:depth-stencil :depth24-stencil8
     :unsigned-int-24-8)
    (:depth32f-stencil8
     :float-32-unsigned-int-24-8-rev)
    ((:rgb9-e5)
     :unsigned-int-5-9-9-9-rev)))

(defun pixel-data-stride (pixel-type pixel-format)
  (* (ecase pixel-format
       ((:r :red :red-integer :stencil-index :depth-component :depth-stencil)
        1)
       ((:rg :gr :rg-integer)
        2)
       ((:rgb :bgr :rgb-integer :bgr-integer)
        3)
       ((:rgba :bgra :rgba-integer :bgra-integer)
        4))
     (ecase pixel-type
       ((:byte :unsigned-byte)
        1)
       ((:unsigned-byte-3-3-2 :unsigned-byte-2-3-3-rev)
        1/3)
       ((:short :unsigned-short :short-float)
        2)
       ((:unsigned-short-5-6-5 :unsigned-short-5-6-5-rev
         :unsigned-short-5-5-5-1 :unsigned-short-1-5-5-5-rev)
        2/3)
       ((:unsigned-short-4-4-4-4 :unsigned-short-4-4-4-4-rev)
        2/4)
       ((:int :unsigned-int :float 
              :unsigned-int-24-8 :unsigned-int-8-24-rev-mesa :float-32-unsigned-int-24-8-rev)
        4)
       ((:unsigned-int-5-9-9-9-rev :unsigned-int-10-10-10-2 :unsigned-int-2-10-10-10-rev)
        4/3)
       ((:unsigned-int-8-8-8-8 :unsigned-int-8-8-8-8-rev)
        4/4))))

(defun infer-internal-format (pixel-type pixel-format)
  (mksym
   "KEYWORD"
   (ecase pixel-format
     ((:r :red) :r)
     ((:rg :gr) :rg)
     ((:rgb :bgr) :rgb)
     ((:rgba :bgra) :rgba))
   (ecase pixel-type
     ((:byte :unsigned-byte) :8)
     ((:short :unsigned-short) :16)
     ((:int :unsigned-int) :32)
     ((:short-float) :16f)
     ((:float) :32f)
     (:unsigned-int-5-9-9-9-rev :9-e5))))

(defun infer-swizzle-format (pixel-format)
  (ecase pixel-format
    ((:r :red) '(:r :r :r :r))
    ((:rg :gr) '(:r :r :r :g))
    ((:rgb :bgr) '(:r :g :b 1))
    ((:rgba :bgra) '(:r :g :b :a))))

(defun infer-swizzle-channels (channels)
  (flet ((f (&rest fields)
           (loop for c in channels thereis (find c fields))))
    (let ((r (f :r :red)) (g (f :g :green)) (b (f :b :blue)) (a (f :a :alpha)))
      (cond ((and r (not g) (not b) (not a)) (list :r :r :r :r))
            ((and (not r) g (not b) (not a)) (list :g :g :g :g))
            ((and (not r) (not g) b (not a)) (list :b :b :b :b))
            ((and r (not g) (not b) a) (list :r :r :r :a))
            ((and (not r) g (not b) a) (list :g :g :g :a))
            ((and (not r) (not g) b a) (list :b :b :b :a))
            (T (list (cond (r :r) (g  1) (b  1) (a :a))
                     (cond (g :g) (b  1) (r  1) (a :a))
                     (cond (b :b) (g  1) (r  1) (a :a))
                     (cond (a :a) (T  1))))))))

(defun infer-pixel-type (depth type)
  (ecase depth
    ((1 8) (ecase type
             (:signed :byte)
             (:unsigned :unsigned-byte)))
    (16 (ecase type
          (:signed :short)
          (:unsigned :unsigned-short)
          (:float :half-float)))
    (32 (ecase type
          (:signed :int)
          (:unsigned :unsigned-int)
          (:float :float)))))

(defun pixel-type->cl-type (type)
  (case type
    (:byte '(signed-byte 8))
    (:unsigned-byte '(unsigned-byte 8))
    (:short '(signed-byte 16))
    (:unsigned-short '(unsigned-byte 16))
    (:int '(signed-byte 32))
    (:unsigned-int '(unsigned-byte 32))
    (:half-float 'short-float)
    (:float 'single-float)
    (:double 'double-float)
    (T T)))

(defun cl-type->pixel-type (type)
  (typecase type
    (cons
     (destructuring-bind (form arity) type
       (ecase form
         (signed-byte
          (ecase arity
            (8 :byte)
            (16 :short)
            (32 :int)))
         (unsigned-byte
          (ecase arity
            (8 :unsigned-byte)
            (16 :unsigned-short)
            (32 :unsigned-int))))))
    (symbol
     (ecase type
       (single-float :float)
       (double-flot :double)))))

(define-global +gl-extensions+ ())

(defmacro %cache (value)
  (let ((cache (gensym "CACHE")))
    `(let ((,cache (load-time-value (cons NIL NIL))))
       (or (car ,cache) (setf (car ,cache) ,value)))))

(defun cache-gl-extensions ()
  (let ((*package* (find-package "KEYWORD")))
    (setf +gl-extensions+
          (loop for i from 0 below (gl:get* :num-extensions)
                for name = (ignore-errors (gl:get-string-i :extensions i))
                when name
                collect (cffi:translate-name-from-foreign name *package*)))))

(defun gl-extension-p (extension)
  (find extension +gl-extensions+))

(define-compiler-macro gl-extension-p (extension)
  `(%cache (find ,extension +gl-extensions+)))

(defmacro when-gl-extension (extension &body body)
  (let ((list (enlist extension)))
    `(when (%cache (and ,@(loop for extension in list
                                collect `(find ,extension +gl-extensions+))))
       ,@body)))

(defmacro gl-extension-case (&body cases)
  `(cond ,@(loop for (extensions . body) in cases
                 collect (case extensions
                           ((T otherwise)
                            `(T ,@body))
                           (T
                            `((%cache (and ,@(loop for extension in (enlist extensions)
                                                   collect `(find ,extension +gl-extensions+))))
                              ,@body))))))

(declaim (inline dbg))
#-trial-release
(defun dbg (&rest parts)
  (let ((*print-right-margin* 10000000000))
    (format *debug-io* "~&~{~a~^ ~}~%" parts)))

#+trial-release
(defun dbg (&rest parts)
  (declare (ignore parts)))

(defun %adjust-array (array length &optional (constructor (constantly NIL)))
  (let* ((old (length array)))
    (unless (= old length)
      (setf array (adjust-array array length))
      (loop for i from old below length
            do (setf (aref array i) (funcall constructor))))
    array))

(defun find-program (program)
  (let ((programs (enlist program)))
    (loop for dir in (uiop:getenv-absolute-directories "PATH")
          thereis (when dir (loop for program in programs
                                  thereis (probe-file (pathname-utils:merge-pathnames* program dir)))))))

(defun run (program &rest args)
  (run* program args))

(defun run* (program args &key background input)
  (flet ((normalize (arg)
           (etypecase arg
             (pathname (pathname-utils:native-namestring arg))
             (real (princ-to-string arg))
             (string arg))))
    (let ((args (loop for arg in args
                      append (mapcar #'normalize (enlist arg))))
          (program (or (find-program program)
                       #+windows (find-program (format NIL "~a.exe" program))
                       (error "Can't find external program:~%  ~a"
                              program))))
      (if background
          (uiop:launch-program (list* program args) :input input :error-output *error-output*)
          (uiop:run-program (list* program args) :input input :output :string :error-output *error-output*)))))