utils.lisp

(uiop:define-package #:slither/utils
  (:use #:cl)
  (:local-nicknames (:glfw :org.shirakumo.fraf.glfw))
  (:use-reexport #:org.shirakumo.fraf.math.matrices
                 #:org.shirakumo.fraf.math.vectors)
  (:import-from :alexandria
                :assoc-value
                :when-let
                :when-let*
                :if-let)
  (:import-from :serapeum
                :eval-always
                :->
                :octet
                :octet-vector
                :make-octet-vector
                :octet-vector-p
                :octet-vector=
                :do-hash-table
                :do-each)
  (:export
   ;; Alexandria
   :assoc-value
   :when-let
   :when-let*
   :if-let
   ;; Serapeum
   :eval-always
   :->
   :octet
   :octet-vector
   :make-octet-vector
   :octet-vector-p
   :octet-vector=
   :do-hash-table
   :do-each
   ;; Local
   :copy-value
   :continuable
   :symbol->camel-case
   :function-symbol->global-variable-symbol
   :defmemo
   :random-color
   :degrees->radians
   :rotation->vec2
   :random-float
   :random-element
   :clamp
   :smoothstep
   :ensure-non-keyword-symbol
   :lambda-list-bindings
   :vec2->rotation
   :mat2->mat3
   :safe-vscale
   :lerp
   :rotation-lerp
   :anchor
   :position-apply-anchor
   :radians->degrees
   :in-main-thread
   :vtan))

(in-package #:slither/utils)

(defun copy-value (value)
  (typecase value
    (vec (vcopy value))
    (sequence (copy-seq value))
    (t value)))

(defun safe-vscale (a s)
  (if (or (= 0 s)
          (= 0 (vx a))
          (= 0 (vy a)))
      (vec2)
      (let ((sum (+ (vx a) (vy a))))
        (if (< -1.0e-22 sum 1.0e-22)
            a
            (vscale a s)))))

(defmacro defmemo (name &body body)
  (let ((memo (gensym "MEMO")))
    `(let (,memo)
       (defun ,name ()
         (unless ,memo
           (setf ,memo
                 (progn ,@body)))
         ,memo))))

(defun clamp (value min max)
  (cond
    ((< value min) min)
    ((> value max) max)
    (t value)))

(defun smoothstep (value edge0 edge1)
  (let ((value (clamp (/ (- value edge0) (- edge1 edge0)) 0 1)))
    (* value value (- 3.0 (* 2.0 value)))))

(defun lerp (start end step)
  (+ (* (- end start) (clamp step 0 1))
     start))

(defun rotation-lerp (start end step)
  (let ((diff (- (mod (+ (- end start) 540) 360) 180)))
    (mod (+ start
            (* diff step)
            360)
         360)))

(defun symbol->camel-case (symbol)
   (loop for character across (string symbol)
         with should-capitalize = nil
         when (char= character #\-)
         do (setf should-capitalize t)
         else
         collect (if should-capitalize
                     (char-upcase character)
                     (char-downcase character))
         into result
         and do (setf should-capitalize nil)
         finally (return (coerce result 'string))))

(defmacro continuable (&body body)
  `(restart-case
       (progn ,@body)
     (continue () :report "Continue")))

(defun degrees->radians (degrees)
  (float (* degrees (/ pi 180)) 0.0))

(defun rotation->vec2 (degrees)
  (let ((radians (degrees->radians degrees)))
    (vec2 (cos radians)
          (sin radians))))

(defun random-float (&optional (range 1) (precision 10))
  (float (* (/ (random precision) precision) range)))

(defun mat2->mat3 (mat2)
  (let ((mat3 (meye 3)))
    (mtransfer mat3 mat2 :w 2 :h 2)
    mat3))

(defun randomly-negate (number)
  (case (random 2)
    (0 (- number))
    (1 number)))

(defun radians->degrees (radians)
  (* radians (/ 180 pi)))

(defun vec2->rotation (vec)
  (radians->degrees (atan (vx vec)
                          (vy vec))))

(defmethod angle-towards ((from vec2) (to vec2))
  (vec2->rotation (vscale (v- to from) 1)))

(defun random-element (list)
  (nth (random (length list)) list))

(defun random-color ()
  (vec4 (random-float) (random-float) (random-float) (random-float)))

(defun lambda-list-bindings (lambda-list)
  "Gets the binding symbols from a lambda list"
  (let (bindings parsing-keys)
    (loop for argument in lambda-list
          do (let ((binding (cond ((eq argument '&key) (setf parsing-keys t) nil)
                                  ((member argument lambda-list-keywords) nil)
                                  ((symbolp argument) argument)
                                  ((consp argument) (car argument))
                                  (t nil))))
               (when binding
                 (when parsing-keys
                   (push (intern (symbol-name binding) :keyword) bindings))
                 (push binding bindings))))
    (nreverse bindings)))

(defun ensure-non-keyword-symbol (symbol)
  (etypecase symbol
    (keyword (intern (symbol-name symbol)))
    (symbol symbol)
    (string (intern symbol))))

(deftype anchor ()
  '(member :center :top :right :left :bottom
    :top-left :top-right :bottom-left :bottom-right))

(-> position-apply-anchor (vec2 &key (:size vec2) (:anchor anchor) (:rotation number)) vec2)
(defun position-apply-anchor (position &key size anchor (rotation 0.0))
  (let ((offset
          (ecase anchor
            (:center (vec2 0 0))
            (:top (vec2 0 (vy size)))
            (:bottom (vec2 0 (- (vy size))))
            (:left (vec2 (- (vx size)) 0))
            (:right (vec2 (vx size) 0))
            (:top-left (vec2 (- (vx size)) (vy size)))
            (:top-right (vec2 (vx size) (vy size)))
            (:bottom-left (vec2 (- (vx size)) (- (vy size))))
            (:bottom-right (vec2 (vx size) (- (vy size)))))))
    (v- position
        (vrot2 offset (degrees->radians rotation)))))

(defmacro in-main-thread (&body body)
  `(if (sb-thread:main-thread-p)
       (progn ,@body)
       (sb-thread:interrupt-thread (sb-thread:main-thread)
                                   (lambda ()
                                     ,@body))))

(-> vtan (vec2) vec2)
(defun vtan (v)
  "Return the tangent vector to v"
  (vec2 (- (vy v))
        (vx v)))