CL-MeltySynth: Artifact [ad9e870f62]

Artifact ad9e870f62ed173bd96db3d9f4307bb1888066922d56c3bb40df286fc2becf4b:

File src/channel.lisp — part of check-in [87164cf3de] at 2022-03-25 23:22:43 on branch trunk — Initial import.
Compiles, but nothing is tested except SoundFont loading. (user: alexa size: 10951)
(in-package :cl-meltysynth)

(defclass channel ()
  ((synth
    :initarg :synthesizer
    :initform nil
    :type (or synthesizer null))

   (percussion-channel-p
    :initarg :percussion-channel?
    :initform nil
    :type boolean
    :reader chan-percussion-channel-p)

   (block-left
    :initform (new-array 0 'single-float 0.0)
    :type t/sfloat-array)

   (block-right
    :initform (new-array 0 'single-float 0.0)
    :type t/sfloat-array)

   (bank-number
    :initform 0
    :type fixnum
    :accessor chan-bank-number)

   (patch-number
    :initform 0
    :type fixnum
    :accessor chan-patch-number)

   (modulation
    :initform 0
    :type (signed-byte 16))

   (volume
    :initform 0
    :type (signed-byte 16))

   (pan
    :initform 0
    :type (signed-byte 16))

   (expression
    :initform 0
    :type (signed-byte 16))

   (hold-pedal-p
    :initform nil
    :type boolean
    :reader chan-hold-pedal-p)

   (reverb-send
    :initform 0
    :type (unsigned-byte 8))

   (chorus-send
    :initform 0
    :type (unsigned-byte 8))

   (rpn
    :initform 0
    :type (signed-byte 16))

   (pitch-bend-range
    :initform 0
    :type (signed-byte 16))

   (coarse-tune
    :initform 0
    :type (signed-byte 16))

   (fine-tune
    :initform 0
    :type (signed-byte 16))

   (pitch-bend
    :initform 0.0
    :type single-float)))

(defgeneric (setf chan-hold-pedal-p) (value object))
(defgeneric (setf chan-reverb-send) (value object))
(defgeneric (setf chan-chorus-send) (value object))

(defgeneric chan-modulation (object))
(defgeneric chan-volume (object))
(defgeneric chan-pan (object))
(defgeneric chan-expression (object))
(defgeneric chan-reverb-send (object))
(defgeneric chan-chorus-send (object))
(defgeneric chan-pitch-bend-range (object))
(defgeneric chan-tune (object))
(defgeneric chan-pitch-bend (object))

(define-typed-fn chan-reset ((chan channel))
    (null)
  (declare (optimize (speed 3) (debug 1) (safety 0)))
  (with-slots (bank-number patch-number modulation volume pan expression hold-pedal-p percussion-channel-p
               reverb-send chorus-send rpn pitch-bend-range coarse-tune fine-tune pitch-bend)
      chan
    (setf bank-number (if percussion-channel-p 128 0))
    (setf patch-number 0)
    (setf modulation 0)
    (setf volume (ash 100 7))
    (setf pan (ash 64 7))
    (setf expression (ash 127 7))
    (setf hold-pedal-p nil)
    (setf reverb-send 40)
    (setf chorus-send 0)
    (setf rpn -1)
    (setf pitch-bend-range (sdm:coerce-to-uint8 (ash 2 7)))
    (setf coarse-tune 0)
    (setf fine-tune 8192)
    (setf pitch-bend 0.0))
  nil)

(defmethod initialize-instance :after ((chan channel) &key &allow-other-keys)
  (with-slots (synth) chan
    (setf (slot-value chan 'block-left) (new-array (synth-block-size synth) 'single-float 0.0))
    (setf (slot-value chan 'block-right) (new-array (synth-block-size synth) 'single-float 0.0))
    (chan-reset chan)))

(define-typed-fn chan-reset-all-controllers ((chan channel))
    (null t)
  (declare (optimize (speed 3) (debug 1) (safety 0)))
  (with-slots (modulation expression hold-pedal-p rpn pitch-bend)
      chan
    (setf modulation 0)
    (setf expression (ash 127 7))
    (setf hold-pedal-p nil)
    (setf rpn -1)
    (setf pitch-bend 0.0))
  nil)

(defmethod (setf chan-bank-number) :after (value (chan channel))
  (declare (optimize (speed 3) (debug 1) (safety 0)))
  (with-slots (percussion-channel-p bank-number)
      chan
    (when percussion-channel-p
      (incf (the fixnum bank-number) 128))))

(define-typed-fn chan-set-modulation-coarse ((chan channel) (value fixnum))
    (null t)
  (declare (optimize (speed 3) (debug 1) (safety 0)))
  (with-slots (modulation)
      chan
    (declare (type (signed-byte 16) modulation))
    (setf modulation (sdm:coerce-to-int16 (logior (logand modulation #x7f) (the fixnum (ash value 7)))))))

(define-typed-fn chan-set-modulation-fine ((chan channel) (value fixnum))
    (null t)
  (declare (optimize (speed 3) (debug 1) (safety 0)))
  (with-slots (modulation)
      chan
    (declare (type (signed-byte 16) modulation))
    (setf modulation (sdm:coerce-to-int16 (logior (logand modulation #xFF80) value))))
  nil)

(define-typed-fn chan-set-volume-coarse ((chan channel) (value fixnum))
    (null t)
  (declare (optimize (speed 3) (debug 1) (safety 0)))
  (with-slots (volume)
      chan
    (declare (type (signed-byte 16) volume))
    (setf modulation (sdm:coerce-to-int16 (logior (logand volume #x7f) (the fixnum (ash value 7))))))
  nil)

(define-typed-fn chan-set-volume-fine ((chan channel) (value fixnum))
    (null t)
  (declare (optimize (speed 3) (debug 1) (safety 0)))
  (with-slots (volume)
      chan
    (declare (type (signed-byte 16) volume))
    (setf volume (sdm:coerce-to-int16 (logior (logand volume #xFF80) value))))
  nil)

(define-typed-fn chan-set-pan-coarse ((chan channel) (value fixnum))
    (null t)
  (declare (optimize (speed 3) (debug 1) (safety 0)))
  (with-slots (pan)
      chan
    (declare (type (signed-byte 16) pan))
    (setf pan (sdm:coerce-to-int16 (logior (logand pan #x7f) (the fixnum (ash value 7)))))))

(define-typed-fn chan-set-pan-fine ((chan channel) (value fixnum))
    (null t)
  (declare (optimize (speed 3) (debug 1) (safety 0)))
  (with-slots (pan)
      chan
    (declare (type (signed-byte 16) pan))
    (setf pan (sdm:coerce-to-int16 (logior (logand pan #xFF80) value))))
  nil)

(define-typed-fn chan-set-expression-coarse ((chan channel) (value fixnum))
    (null t)
  (declare (optimize (speed 3) (debug 1) (safety 0)))
  (with-slots (expression)
      chan
    (declare (type (signed-byte 16) expression))
    (setf expression (sdm:coerce-to-int16 (logior (logand expression #x7f) (the fixnum (ash value 7)))))))

(define-typed-fn chan-set-expression-fine ((chan channel) (value fixnum))
    (null t)
  (declare (optimize (speed 3) (debug 1) (safety 0)))
  (with-slots (expression)
      chan
    (declare (type (signed-byte 16) expression))
    (setf expression (sdm:coerce-to-int16 (logior (logand expression #xFF80) value))))
  nil)

(define-typed-fn chan-set-rpn-coarse ((chan channel) (value fixnum))
    (null t)
  (declare (optimize (speed 3) (debug 1) (safety 0)))
  (with-slots (rpn)
      chan
    (declare (type (signed-byte 16) rpn))
    (setf rpn (sdm:coerce-to-int16 (logior (logand rpn #x7f) (the fixnum (ash value 7)))))))

(define-typed-fn chan-set-rpn-fine ((chan channel) (value fixnum))
    (null t)
  (declare (optimize (speed 3) (debug 1) (safety 0)))
  (with-slots (rpn)
      chan
    (declare (type (signed-byte 16) rpn))
    (setf rpn (sdm:coerce-to-int16 (logior (logand rpn #xFF80) value))))
  nil)

(define-typed-fn chan-data-entry-coarse ((chan channel) (value fixnum))
    (null t)
  (declare (optimize (speed 3) (debug 1) (safety 0)))
  (with-slots (rpn pitch-bend-range fine-tune coarse-tune)
      chan
    (declare (type (signed-byte 16) rpn pitch-bend-range coarse-tune fine-tune))

    (case rpn
      (0 (setf pitch-bend-range
               (sdm:coerce-to-int16 (logior (logand pitch-bend-range #x7f)
                                            (the fixnum (ash value 7))))))

      (1 (setf fine-tune
               (sdm:coerce-to-int16 (logior (logand fine-tune #x7f)
                                            (the fixnum (ash value 7))))))

      (2 (setf coarse-tune (sdm:coerce-to-int16 (- value 64))))))
  nil)

(define-typed-fn chan-data-entry-fine ((chan channel) (value fixnum))
    (null t)
  (declare (optimize (speed 3) (debug 1) (safety 0)))
  (with-slots (rpn pitch-bend-range fine-tune)
      chan
    (declare (type (signed-byte 16) rpn pitch-bend-range fine-tune))

    (case rpn
      (0 (setf pitch-bend-range (sdm:coerce-to-int16 (logior (logand pitch-bend-range #xFF80) value))))
      (1 (setf fine-tune (sdm:coerce-to-int16 (logior (logand fine-tune #xFF80) value))))))
  nil)

(define-typed-fn chan-set-pitch-bend ((chan channel) (value1 fixnum) (value2 fixnum))
    (null t)
  (declare (optimize (speed 3) (debug 1) (safety 0)))
  (with-typed-slots ((pitch-bend single-float)) chan
    (setf pitch-bend (* (/ 1.0 8192.0)
                        (the fixnum (- (logior value1 (the fixnum (ash value2 7))) 8192)))))
  nil)

(defmethod (setf chan-hold-pedal-p) ((value fixnum) (chan channel))
  (declare (optimize (speed 3) (debug 1) (safety 0)))
  (with-slots (hold-pedal-p) chan
    (setf hold-pedal-p (>= value 64))))

(defmethod (setf chan-reverb-send) ((value fixnum) (chan channel))
  (declare (optimize (speed 3) (debug 1) (safety 0)))
  (with-slots (reverb-send) chan
    (setf reverb-send (sdm:coerce-to-uint8 value))))

(defmethod (setf chan-chorus-send) ((value fixnum) (chan channel))
  (declare (optimize (speed 3) (debug 1) (safety 0)))
  (with-slots (chorus-send) chan
    (setf chorus-send (sdm:coerce-to-uint8 value))))

(defmethod chan-modulation ((chan channel))
  (declare (optimize (speed 3) (debug 1) (safety 0)))
  (with-slots (modulation) chan
    (declare (type (signed-byte 16) modulation))
    (* (/ 50.0 16383.0) modulation)))

(defmethod chan-volume ((chan channel))
  (declare (optimize (speed 3) (debug 1) (safety 0)))
  (with-slots (volume) chan
    (declare (type (signed-byte 16) volume))
    (* (/ 1.0 16383.0) volume)))

(defmethod chan-pan ((chan channel))
  (declare (optimize (speed 3) (debug 1) (safety 0)))
  (with-slots (pan) chan
    (declare (type (signed-byte 16) pan))
    (- (* (/ 100.0 16383.0) pan) 50.0)))

(defmethod chan-expression ((chan channel))
  (declare (optimize (speed 3) (debug 1) (safety 0)))
  (with-slots (expression) chan
    (declare (type (signed-byte 16) expression))
    (* (/ 1.0 16383.0) expression)))

(defmethod chan-reverb-send ((chan channel))
  (declare (optimize (speed 3) (debug 1) (safety 0)))
  (with-slots (reverb-send) chan
    (declare (type (signed-byte 8) reverb-send))
    (* (/ 1.0 127.0) reverb-send)))

(defmethod chan-chorus-send ((chan channel))
  (declare (optimize (speed 3) (debug 1) (safety 0)))
  (with-slots (chorus-send) chan
    (declare (type (signed-byte 8) chorus-send))
    (* (/ 1.0 127.0) chorus-send)))

(defmethod chan-pitch-bend-range ((chan channel))
  (declare (optimize (speed 3) (debug 1) (safety 0)))
  (with-slots (pitch-bend-range) chan
    (declare (type (signed-byte 16) pitch-bend-range))
    (+ (ash pitch-bend-range -7)
       (* 0.01 (logand pitch-bend-range #x7f)))))

(defmethod chan-tune ((chan channel))
  (declare (optimize (speed 3) (debug 1) (safety 0)))
  (with-slots (coarse-tune fine-tune) chan
    (declare (type (signed-byte 16) coarse-tune fine-tune))
    (+ coarse-tune (* (/ 1.0 8192.0)
                      (- fine-tune 8192)))))

(defmethod chan-pitch-bend ((chan channel))
  (declare (optimize (speed 3) (debug 1) (safety 0)))
  (with-slots (pitch-bend-range pitch-bend) chan
    (declare (type (signed-byte 16) pitch-bend-range)
             (type single-float pitch-bend))
    (* pitch-bend-range pitch-bend)))