;;; Written by R. Matthew Emerson <rme@acm.org> in August 1999,
;;; and placed in the public domain.

(defconstant spi (coerce pi 'single-float))
(defconstant *dct-scale-factors*
    (make-array 8 :element-type 'single-float
		:initial-contents (list 
				   ;; extra 2 in this first factor to compensate for
				   ;; first row of fig. 4-8 missing a factor of 2
				   (/ 2.0 (* 4.0 (sqrt 2.0)))
				   (/ (* 4.0 (cos (/ (* 1.0 spi) 16.0))))
				   (/ (* 4.0 (cos (/ (* 2.0 spi) 16.0))))
				   (/ (* 4.0 (cos (/ (* 3.0 spi) 16.0))))
				   (/ (* 4.0 (cos (/ (* 4.0 spi) 16.0))))
				   (/ (* 4.0 (cos (/ (* 5.0 spi) 16.0))))
				   (/ (* 4.0 (cos (/ (* 6.0 spi) 16.0))))
				   (/ (* 4.0 (cos (/ (* 7.0 spi) 16.0)))))))

;; defaults from jpeg spec, section K.1
(defparameter *luminance-quantization-table*
    (make-array '(8 8) :element-type '(unsigned-byte 8)
              :initial-contents '((16  11  10  16  24  40  51  61)
                                  (12  12  14  19  26  58  60  55)
                                  (14  13  16  24  40  57  69  56)
                                  (14  17  22  29  51  87  80  62)
                                  (18  22  37  56  68 109 103  77)
                                  (24  35  55  64  81 104 113  92)
                                  (49  64  78  87 103 121 120 101)
                                  (72  92  95  98 112 100 103  99))))

(defun level-shift (b)
  (dotimes (row 8)
    (dotimes (col 8)
      (decf (aref b row col) 128.0))))

(defun scale-block (b)
  (dotimes (row 8)
    (dotimes (col 8)
      (setf (aref b row col) (* (aref b row col)
                                (aref *dct-scale-factors* col)
                                (aref *dct-scale-factors* row))))))

(defun scale-and-quantize-block (b)
  (dotimes (row 8)
    (dotimes (col 8)
      (setf (aref b row col)
	(round
	 (* (aref b row col)
	    (aref *dct-scale-factors* col)
	    (aref *dct-scale-factors* row)
	    (/ (aref *luminance-quantization-table* row col))))))))