;;;; ------------------------------------------------------------------------------------------
;;;;  Pixel translation
;;;;

;; This pixel translation code is from the Closure browser circa 1997. It is
;; well tested on 1-bit :static-gray, 8-bit :static-gray, 8-bit
;; :pseudo-color, 15 and 16-bit truecolor als well as 24-bit truecolor
;; display, as these happen to be the kind of displays I personally used
;; back then.

;; On strange visuals like a :direct-color, we punt and bail out with the
;; B/W ditherer.

;; Whether we dither or not is decided by the *dither-threshold* parameter.

;; This code works by compiling at run time a function, which converts
;; pixels from our internal ARGB8 format to what ever the color map and
;; visual says.

;; Our dither matrix is 8 pixels by 8 pixels.

;; Note, that what CLIM thinks of as uniform designs are no longer uniform
;; here. On those displays we resort to dither, we set up a graphics context
;; with a color to an opaque-stipple.

(defparameter *dither-threshold* 4)
(defparameter *code-optimization* '(optimize (safety 0) (space 0) (speed 3) (debug 0)))

(defconstant *dither-map*
  '#2A((0    192   48  240   12  204   60  252)
       (128   64  176  112  140   76  188  124)
       (32   224   16  208   44  236   28  220)
       (160   96  144   80  172  108  156   92) 
       (8    200   56  248    4  196   52  244) 
       (136   72  184  120  132   68  180  116)
       (40   232   24  216   36  228   20  212) 
       (168  104  152   88  164  100  148   84)))

(defun colormap-plist (colormap)
  (cdr (assoc colormap (getf (xlib:display-plist (xlib:colormap-display colormap))
                             'colormap-plist)
              :test #'xlib:colormap-equal)))

(defun (setf colormap-plist) (value colormap)
  (let ((x (assoc colormap (getf (xlib:display-plist (xlib:colormap-display colormap))
                                 'colormap-plist)
                  :test #'xlib:colormap-equal)))
    (if x 
        (setf (cdr x) value)
        (push (cons colormap value) 
              (getf (xlib:display-plist (xlib:colormap-display colormap)) 'colormap-plist)))))

;; static color is strange, since it has red/green/blue masks

(defun pixel-translator-code (colormap)
  (or (getf (colormap-plist colormap) 'pixel-translator-code)
      (setf (getf (colormap-plist colormap) 'pixel-translator-code)
            (let ((vi (xlib:colormap-visual-info colormap)))
              (case (xlib:visual-info-class vi)
                ((:static-gray)
                 (cond ((<= (xlib:visual-info-bits-per-rgb vi) *dither-threshold*)
                        (warn "Static gray dithered")
                        (static-gray-ditherer colormap))
                       (t
                        (warn "Static gray")
                        (static-gray-translator colormap))))
                ((:true-color)
                 (cond ((<= (xlib:visual-info-bits-per-rgb vi) *dither-threshold*)
                        (warn "True color dithered")
                        (true-color-ditherer colormap))
                       (t
                        (warn "True color")
                        (true-color-translator colormap))))
                ((:pseudo-color)
                 (warn "Pseudo color")
                 (rgb-cube-ditherer colormap 6))
                (otherwise
                 (warn "Weird visual class -- falling back to black and white dithering.")
                 (fallback-b/w-ditherer colormap)) )) )))

#-NIL
(defun pixel-translator-code (colormap)
  (fallback-b/w-ditherer colormap))

(defun pixel-translator (colormap)
  (or (getf (colormap-plist colormap) 'pixel-translator)
      (setf (getf (colormap-plist colormap) 'pixel-translator)
            (compile nil (pixel-translator-code colormap)))))

(defun component-deposition-expr (component-expr dest-byte ramp linearp
                                  &optional (shifted-p nil))
  (let ((value-map (if linearp 
                       `(lambda (x)
                          (declare (type (unsigned-byte ,(byte-size dest-byte))))
                          #+NIL
                          (dpb x (byte ,(byte-size dest-byte)
                                       ,(byte-position dest-byte))
                               0)
                          (ash x ,(byte-position dest-byte))
                          )
                       `(lambda (x) (aref (the ,(type-of ramp) ',ramp) x)))))
    (let ((n (byte-size dest-byte)))
      (assert (<= n 8))
      `(the (unsigned-byte ,(+ (byte-position dest-byte) (byte-size dest-byte)))
            (,value-map ,(if shifted-p 
                             component-expr 
                             `(the (unsigned-byte ,n) 
                                   (ldb (byte ,n ,(- 8 n)) 
                                        ,component-expr))))))))

(defun static-gray-translator (colormap)
  (let ((gray-byte (visual-info-gray-byte (xlib:colormap-visual-info colormap))))
    (multiple-value-bind (ramp linearp) (allocate-gray-ramp colormap)
      `(lambda (x y sample)
         (declare (ignore x y)
                  (type (unsigned-byte 24) sample)
                  ,*code-optimization*)
         ,(component-deposition-expr '(luminance sample) gray-byte ramp linearp)))))

(defun static-gray-ditherer (colormap)
  (let* ((gray-byte (visual-info-gray-byte (xlib:colormap-visual-info colormap)))
         (n (ash 1 (byte-size gray-byte))))
    (multiple-value-bind (ramp linearp) (allocate-gray-ramp colormap)
      `(lambda (x y sample)
         (declare (type (unsigned-byte 24) sample)
                  ,*code-optimization*)
         ,(component-deposition-expr `(the (integer 0 (,n))
                                           (,(generic-ditherer n) x y (luminance sample)))
                                     gray-byte 
                                     ramp linearp
                                     t)))))

(defun identity-mapping-p (vector)
  (dotimes (i (length vector) t)
    (unless (eql (aref vector i) i)
      (return nil))))

(defun luminance (sample)
  (declare (type (unsigned-byte 24) sample))
  (floor (the (unsigned-byte 18)
              (+ (* 307 (the (unsigned-byte 8) (ldb (byte 8 16) sample))) ;red
                 (* 599 (the (unsigned-byte 8) (ldb (byte 8 8) sample))) ;green
                 (* 118 (the (unsigned-byte 8) (ldb (byte 8 0) sample))))) ;blue
         1024))

(define-compiler-macro luminance (sample)
  `((lambda (sample)
      (the (unsigned-byte 8)
           (floor (the (unsigned-byte 18)
                       (+ (* 307 (the (unsigned-byte 8) (ldb (byte 8 16) sample))) ;red
                          (* 599 (the (unsigned-byte 8) (ldb (byte 8 8) sample))) ;green
                          (* 118 (the (unsigned-byte 8) (ldb (byte 8 0) sample))))) ;blue
                  1024)))
    ,sample))

(defun generic-ditherer (m)
  `(lambda (x y s)
     (multiple-value-bind (c0 delta)
         (floor (the (integer 0 ,(* (1- m) 255)) (* ,(1- m) s)) 255)
       (declare (type (unsigned-byte 8) delta)
                (type (integer 0 (,m)) c0))
       (if (<= (the (unsigned-byte 8) delta) 
               (the (unsigned-byte 8)
                    (aref *dither-map*
                          (logand x #x7)
                          (logand y #x7))))
           c0
           (+ c0 1)))))

(defun true-color-translator (colormap)
  (multiple-value-bind (red-ramp red-linear) (allocate-component-ramp colormap :red)
    (multiple-value-bind (green-ramp green-linear) (allocate-component-ramp colormap :green)
      (multiple-value-bind (blue-ramp blue-linear) (allocate-component-ramp colormap :blue)
        `(lambda (x y sample)
           (declare (ignore x y)
                    (type (unsigned-byte 24) sample)
                    ,*code-optimization*)
           (logior ,(component-deposition-expr
                     '(the (unsigned-byte 8) (ldb (byte 8 16) sample))
                     (mask->byte
                      (xlib:visual-info-red-mask
                       (xlib:colormap-visual-info colormap)))
                     red-ramp
                     red-linear)
                   ,(component-deposition-expr
                     '(the (unsigned-byte 8) (ldb (byte 8 8) sample))
                     (mask->byte
                      (xlib:visual-info-green-mask
                       (xlib:colormap-visual-info colormap)))
                     green-ramp
                     green-linear)
                   ,(component-deposition-expr
                     '(the (unsigned-byte 8) (ldb (byte 8 0) sample))
                     (mask->byte
                      (xlib:visual-info-blue-mask
                       (xlib:colormap-visual-info colormap)))
                     blue-ramp
                     blue-linear)))))))

(defun allocate-component-ramp (colormap component)
  (let ((byte (mask->byte
               (ecase component
                 (:red (xlib:visual-info-red-mask (xlib:colormap-visual-info colormap)))
                 (:green (xlib:visual-info-green-mask (xlib:colormap-visual-info colormap)))
                 (:blue (xlib:visual-info-blue-mask (xlib:colormap-visual-info colormap)))))))
    (let ((res (make-array (ash 1 (byte-size byte)) :element-type '(unsigned-byte 32)))
          (linearp t))
      (dotimes (i (ash 1 (byte-size byte)))
        (let ((color (xlib:make-color component (/ i (1- (ash 1 (byte-size byte))))
                                      :red 0 :green 0 :blue 0)))
          (let ((pixel (xlib:alloc-color colormap color))
                (naiv (dpb i byte 0)))
            (when (/= naiv pixel)
              (setf linearp nil))
            (setf (aref res i) pixel))))
      (values
       res
       linearp))))

(defun allocate-gray-ramp (colormap)
  (let ((byte (visual-info-gray-byte (xlib:colormap-visual-info colormap))))
    (let ((linearp t)
          (res (make-array (ash 1 (byte-size byte)) :element-type '(unsigned-byte 32))))
      (dotimes (i (ash 1 (byte-size byte)))
        (let ((color (xlib:make-color :red   (/ i (1- (ash 1 (byte-size byte))))
                                      :green (/ i (1- (ash 1 (byte-size byte))))
                                      :blue  (/ i (1- (ash 1 (byte-size byte)))) )))
          (let ((pixel (xlib:alloc-color colormap color))
                (naiv (dpb i byte 0)))
            (when (/= naiv pixel)
              (setf linearp nil))
            (setf (aref res i) pixel))))
      (values res linearp))))

(defun visual-info-gray-byte (vi)
  (let ((m (integer-length (1- (xlib:visual-info-colormap-entries vi))))
        (n (xlib:visual-info-bits-per-rgb vi)))
    (byte n (- m n))))

(defun true-color-ditherer (colormap)
  (multiple-value-bind (red-ramp red-linear) (allocate-component-ramp colormap :red)
    (multiple-value-bind (green-ramp green-linear) (allocate-component-ramp colormap :green)
      (multiple-value-bind (blue-ramp blue-linear) (allocate-component-ramp colormap :blue)
        (let ((rm (xlib:visual-info-red-mask (xlib:colormap-visual-info colormap)))
              (gm (xlib:visual-info-green-mask (xlib:colormap-visual-info colormap)))
              (bm (xlib:visual-info-blue-mask (xlib:colormap-visual-info colormap))))
          (let ((nr (ash 1 (byte-size (mask->byte rm))))
                (nb (ash 1 (byte-size (mask->byte bm))))
                (ng (ash 1 (byte-size (mask->byte gm)))))
            `(lambda (x y sample)
               (declare (type (unsigned-byte 24) sample)
                        ,*code-optimization*)
               (logior ,(component-deposition-expr 
                         `(the (integer 0 (,nr))
                               (,(generic-ditherer nr) x y (ldb (byte 8 16) sample)))
                         (mask->byte rm)
                         red-ramp
                         red-linear
                         t)
                       ,(component-deposition-expr 
                         `(the (integer 0 (,ng))
                               (,(generic-ditherer ng) x y (ldb (byte 8 8) sample)))
                         (mask->byte gm)
                         green-ramp
                         green-linear
                         t)
                       ,(component-deposition-expr 
                         `(the (integer 0 (,nb))
                               (,(generic-ditherer nb) x y (ldb (byte 8 0) sample)))
                         (mask->byte bm)
                         blue-ramp
                         blue-linear
                         t)))))))))

(defun allocate-rgb-cube (colormap n)
  "Allocates a n**3 rgb cube using the colormap 'colormap';
   Returns NIL, if not enough colors could be allocated.
   On success returns a three dimensional array of the allocated pixel values."
  ;;TODO: actually implement the allocation failure handling
  (let ((cube (make-array (list n n n) :element-type '(unsigned-byte 32) :initial-element 0))
        (allocated nil))
    (unwind-protect
         (progn
           (dotimes (red n)
             (dotimes (green n)
               (dotimes (blue n)
                 (let ((pixel (xlib:alloc-color
                               colormap
                               (xlib:make-color :red   (/ red (1- n))
                                                :green (/ green (1- n))
                                                :blue  (/ blue (1- n))))))
                   (setf (aref cube red green blue) pixel)
                   (push pixel allocated)))))
           (setf allocated nil))
      (xlib:free-colors colormap allocated) )
    cube))

(defun rgb-cube-ditherer (colormap n)
  (let ((cube (allocate-rgb-cube colormap n)))
    `(lambda (x y sample)
       (declare (type (unsigned-byte 16) x y)
                (type (unsigned-byte 24) sample)
                ,*code-optimization*)
       (aref (the ,(type-of cube) ',cube)
             (,(generic-ditherer (array-dimension cube 0)) x y (ldb (byte 8 16) sample))
             (,(generic-ditherer (array-dimension cube 1)) x y (ldb (byte 8 8) sample))
             (,(generic-ditherer (array-dimension cube 2)) x y (ldb (byte 8 0) sample))))))

(defun fallback-b/w-ditherer (colormap)
  (let ((black (xlib:alloc-color colormap (xlib:make-color :red 0 :blue 0 :green 0)))
        (white (xlib:alloc-color colormap (xlib:make-color :red 1 :blue 1 :green 1))))
    `(lambda (x y sample)
       (declare (type (unsigned-byte 24) sample)
                ,*code-optimization*)
       (if (zerop (,(generic-ditherer 2) x y (luminance sample)))
           ,black
           ,white)) ))

(defun mask->byte (mask)
  (let ((h (integer-length mask)))
    (let ((l (integer-length (logxor mask (1- (ash 1 h))))))
      (byte (- h l) l))))