;;;; pixbuf.lisp

(in-package #:iip-project)

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

(defstruct pixel-str
  (length 0 :type integer)
  (height 0 :type integer)
  (width  0 :type integer)
  (stride 0 :type integer)
  (data)) ; data is a foreign cffi pointer

(cffi:define-foreign-library libgdk-pixbuf
  (t (:default "libgdk_pixbuf-2.0")))
(cffi:use-foreign-library libgdk-pixbuf)

(cffi:defcfun ("gdk_pixbuf_get_pixels_with_length" gdk-pixbuf-get-pixels-with-length)
              :pointer (pixbuf :pointer) (len :pointer))

(defun pixbuf->pixel-str (pixbuf)
  (let* ((height (gdk-pixbuf:pixbuf-height pixbuf))
         (width (gdk-pixbuf:pixbuf-width pixbuf))
         (stride (gdk-pixbuf:pixbuf-rowstride pixbuf)))
    (cffi:with-foreign-object (len-loc :int)
      (let ((data (gdk-pixbuf-get-pixels-with-length (gobj::object-pointer pixbuf) len-loc)))
        (make-pixel-str :length (cffi:mem-aref len-loc :int) :height height :width width :stride stride :data data)))))

(cffi:defcstruct c-rgba
  (red   :unsigned-char)
  (green :unsigned-char)
  (blue  :unsigned-char)
  (alpha :unsigned-char))

(defun luminance (rgb-vec)
  (let ((r (svref rgb-vec 0))
        (g (svref rgb-vec 1))
        (b (svref rgb-vec 2)))
    (+ (* 0.2126 r) (* 0.7152 g) (* 0.0722 b))))

; h, s and l are floats [0,1]
; r, g and b are ints [0,255]
(defun hsl->rgb (hsl-vec)
  (flet ((hue->rgb (p q h)
           (when (< h 0) (incf h))
           (when (> h 1) (decf h))
           (round (* 255
                     (cond
                       ((< h 1/6) (+ p (* (- q p) 6 h)))
                       ((< h 1/2) q)
                       ((< h 2/3) (+ p (* (- q p) (- 2/3 h) 6)))
                       (h         p))))))
    (let ((h (svref hsl-vec 0))
          (s (svref hsl-vec 1))
          (l (svref hsl-vec 2)))
      (if (= s 0)
        (vector (round (* 255 l))
                (round (* 255 l))
                (round (* 255 l)))
        (let* ((q (if (< l 0.5)
                      (* l (+ s 1))
                      (+ l s (- (* l s)))))
               (p (- (* 2 l) q)))
          (vector (hue->rgb p q (+ h 1/3))
                  (hue->rgb p q h)
                  (hue->rgb p q (- h 1/3))))))))

(defun rgb->hsl (rgb-vec)
  (let* ((rgb-vec-norm (map 'simple-vector (lambda (x) (/ x 255.0)) rgb-vec))
         (r            (svref rgb-vec-norm 0))
         (g            (svref rgb-vec-norm 1))
         (b            (svref rgb-vec-norm 2))
         (vmax         (max r g b))
         (vmin         (min r g b))
         (l (/ (+ vmax vmin) 2)))
    (if (= vmax vmin) (vector 0.0 0.0 l)
        (let* ((d (- vmax vmin))
               (s (if (> l 0.5)
                      (/ d (- 2 vmax vmin))
                      (/ d (+ vmax vmin))))
               (h (/ (cond
                       ((= vmax r) (+ (/ (- g b) d)
                                      (if (< g b) 6 0)))
                       ((= vmax g) (+ (/ (- b r) d) 2))
                       ((= vmax b) (+ (/ (- r g) d) 4)))
                     6)))
          (vector h s l)))))

(defmacro image-proc-lambda (arglist &body body)
  (labels ((double-float-p (x) (typep x 'double-float))
           (real-and-3-doubles (lst) (and (eq (car lst) 'real)
                                          (= 4 (length lst))
                                          (every #'double-float-p (cdr lst))))
           (proper-arglist (lst)
             (and (listp lst) (every #'listp lst) (every (lambda (arg)
                                                           (and
                                                             (symbolp (car arg))
                                                             (listp   (cadr arg))
                                                             (eq 'real (caadr arg))
                                                             (= 3 (length (cdadr arg)))
                                                             (every #'double-float-p (cdadr arg))))
                                                         lst)))
           (argspec (arg) (cadr arg))
           (arg-min (arg) (second (argspec arg)))
           (arg-max (arg) (third (argspec arg)))
           (arg-step (arg) (fourth (argspec arg)))
           (get-argnames (arglist) (mapcar #'car arglist))
           (get-label-names (arglist) (mapcar (lambda (arg) (gensym (concatenate 'string "label-" (string (car arg))))) arglist))
           (get-widget-names (arglist) (mapcar (lambda (arg) (gensym (concatenate 'string (cond
                                                                                            ((real-and-3-doubles (argspec arg))
                                                                                             "scale-"))
                                                                                  (string (car arg))))) arglist))
           (label-def (label-name arg)
             `(,label-name     (gtk:make-label :str ,(concatenate 'string (string (car arg)) ": "))))
           (widget-def (widget-name arg)
             `(,widget-name    (,(cond
                                   ((real-and-3-doubles (argspec arg))
                                    'gtk:make-scale))
                                 :min ,(arg-min arg) :max ,(arg-max arg) :step ,(arg-step arg) :orientation gtk:+orientation-horizontal+)))
           (widget-set (widget-name arg)
             (cond
               ((real-and-3-doubles (argspec arg))
                `((setf (gtk:scale-draw-value-p ,widget-name) t)
                  (setf (gtk:scale-has-origin-p ,widget-name) t)
                  (setf (gtk:scale-digits ,widget-name)
                        ,(let ((digits (round (- (log (arg-step arg) 10)))))
                           (if (< digits 0) 0 digits)))
                  (setf (gtk:scale-value-pos ,widget-name) gtk:+position-type-left+)
                  (setf (gtk:range-value ,widget-name) ,(/ (+ (arg-min arg) (arg-max arg)) 2.0d0))
                  (setf (gtk:widget-hexpand-p ,widget-name) t)))))
           (widgets-labels-grid (widget-names label-names)
             (let ((numlist (loop for x from 0 below (length widget-names)
                                  collect x)))
               (append (apply #'append
                              (mapcar (lambda (w-name l-name num)
                                        `((gtk:grid-attach grid ,l-name 0 ,num 1 1)
                                          (gtk:grid-attach grid ,w-name 1 ,num 1 1)))
                                      widget-names
                                      label-names
                                      numlist))
                       `((gtk:grid-attach grid submit   0 ,(length widget-names) 1 1)))))
           (bind-arg (arg widget-name)
             (cond
               ((real-and-3-doubles (argspec arg))
                `(,(car arg) (gtk:range-value ,widget-name))))))
    (let ((argnames (get-argnames arglist)))
      (cond
        ((not (proper-arglist arglist)) (error "~A is not a proper argument list for macro image-proc-lambda." arglist))
        ((not (equal argnames (remove-duplicates argnames))) (error "Arglist ~A has duplicates" arglist))
        (t
         (let* ((label-names (get-label-names arglist))
                (label-defs  (mapcar #'label-def label-names arglist))
                (widget-names (get-widget-names arglist))
                (widget-defs  (mapcar #'widget-def widget-names arglist))
                (widget-settings (apply #'append (mapcar #'widget-set widget-names arglist)))
                (arg-bindings (mapcar #'bind-arg arglist widget-names)))
           `(lambda (button)
              (unless (null *pixbuf-original*)
                (let ((dialog-window (gtk:make-window))
                      (grid          (gtk:make-grid))
                      ,@ label-defs
                      ,@ widget-defs
                      (submit        (gtk:make-button :label "Submit")))
                  (setf (gtk:window-child dialog-window) grid)

                  ,@ widget-settings

                  ,@ (widgets-labels-grid widget-names label-names)

                  (gtk:connect submit "clicked"
                               (lambda (submit)
                                 (let* ((ps (pixbuf->pixel-str *pixbuf-new*))
                                        (length (pixel-str-length ps))
                                        (height (pixel-str-height ps))
                                        (width  (pixel-str-width  ps))
                                        (stride (pixel-str-stride ps))
                                        (data   (pixel-str-data   ps))
                                        ,@ arg-bindings)
                                   ,@ body
                                   (setf (gtk:image-from-pixbuf *img-new*) *pixbuf-new*))
                                 (gtk:window-destroy dialog-window)))
                  (gtk:window-present dialog-window))))))))))

(defparameter *function-alist*
  `(("rotation" .
     ,(image-proc-lambda ((degree (real -60.0d0 +60.0d0 0.1d0)))
        (let* ((angle       (* degree pi 1/180))
               (rescale     (sqrt (/ (min (* (expt height 2)
                                             (+ 1 (expt (tan (- (/ pi 2)
                                                                (abs angle)
                                                                (atan (/ height width))))
                                                        2)))
                                          (* (expt width 2)
                                             (+ 1 (expt (tan (- (/ pi 2)
                                                                (abs angle)
                                                                (atan (/ width height))))
                                                        2))))
                                     (+ (expt height 2)
                                        (expt width  2)))))
               (mod-pixbuf  (gdk-pixbuf:pixbuf-copy *pixbuf-new*))
               (m-ps        (pixbuf->pixel-str mod-pixbuf))
               (m-data      (pixel-str-data   m-ps))
               (zero-struct (cffi:convert-to-foreign '(red 0 green 0 blue 0 alpha 0)
                                                     '(:struct c-rgba))))
          (loop for x from 0 below width do
                (loop for y from 0 below height do
                      (let* ((shx     (- x (floor width  2)))
                             (shy     (- y (floor height 2)))
                             (newx    (/ (- (* (cos (- angle)) shx) (* (sin (- angle)) shy)) rescale))
                             (newy    (/ (+ (* (sin (- angle)) shx) (* (cos (- angle)) shy)) rescale))
                             (newx-cen (+ newx (floor width 2)))
                             (newy-cen (+ newy (floor height 2)))
                             (newx-nn  (round newx-cen))
                             (newy-nn  (round newy-cen)))
                        (setf (cffi:mem-aref m-data '(:struct c-rgba) (+ (* y width) x))
                              (if (or (not (< -1 newx-nn width)) (not (< -1 newy-nn height)))
                                  (cffi:mem-aref zero-struct '(:struct c-rgba))
                                  (cffi:mem-aref data '(:struct c-rgba)
                                                 (+ (* newy-nn width) newx-nn)))))))
          (setf *pixbuf-new* mod-pixbuf))))
    ("brightness" .
     ,(image-proc-lambda ((brightness (real -1.0d0 +1.0d0 0.01d0))
                          (contrast   (real -1.0d0 +1.0d0 0.01d0)))
        (loop for i from 0 below (/ length 4) do
              (loop for ch from 0 below 3 do
                    (let* ((val (cffi:mem-aref data :unsigned-char (+ (* 4 i) ch))))
                      (setf (cffi:mem-aref data :unsigned-char (+ (* 4 i) ch))
                            (let* ((brightness (/ brightness 2.0))
                                   (slant      (tan (* (+ contrast 1) (/ pi 4))))
                                   (val1 (if (< brightness 0.0)
                                             (* val (+ 1.0 brightness))
                                             (+ val (* (- 255 val) brightness))))
                                   (val2 (+ (* (- val1 127) slant) 127))
                                   (val3 (ldb (byte 8 0)
                                              (floor (clamp val2 0 255)))))
                              val3)))))))
    ("warmth" .
     ,(image-proc-lambda ((temperature (real 1000.0d0 12000.0d0 100.0d0)))
        (flet ((addv (v1 v2)
                 (map 'simple-vector (lambda (x1 x2) (+ x1 x2))
                      v1 v2))
               (mulsv (s v)
                 (map 'simple-vector (lambda (x) (* x s)) v)))
          (multiple-value-bind (quot remainder)
            (truncate temperature 100.0d0)
            (let* ((lower        (* quot 100.0d0))
                   (lower-index  (- quot 10))
                   (line-portion (/ remainder 100.0d0))
                   (low-factor   (cdr (svref +color-temp-table+ lower-index)))
                   (rgb-factor   (map 'simple-vector #'round
                                   (if (= lower temperature)
                                       low-factor
                                       (addv (mulsv (- 1 line-portion) low-factor)
                                             (mulsv line-portion       (cdr (svref +color-temp-table+
                                                                                   (1+ lower-index)))))))))
              (loop for i from 0 below (/ length 4) do
                    (loop for ch from 0 below 3 do
                          (let* ((val (cffi:mem-aref data :unsigned-char (+ (* 4 i) ch))))
                            (setf (cffi:mem-aref data :unsigned-char (+ (* 4 i) ch))
                                  (round (* val (svref rgb-factor ch) 1/255)))))))))))
    ("saturation" .
     ,(image-proc-lambda ((saturation (real 0.0d0 2.0d0 0.01d0)))
        (loop for i from 0 below (/ length 4) do
              (let* ((rgb (vector (cffi:mem-aref data :unsigned-char (+ (* 4 i) 0))
                                  (cffi:mem-aref data :unsigned-char (+ (* 4 i) 1))
                                  (cffi:mem-aref data :unsigned-char (+ (* 4 i) 2))))
                     (hsl (rgb->hsl rgb))
                     (s   (svref hsl 1)))
                (setf s (clamp (* s saturation) 0 1))
                (setf (svref hsl 1) s)
                (let ((new-rgb (hsl->rgb hsl)))
                  (setf (cffi:mem-aref data :unsigned-char (+ (* 4 i) 0)) (svref new-rgb 0))
                  (setf (cffi:mem-aref data :unsigned-char (+ (* 4 i) 1)) (svref new-rgb 1))
                  (setf (cffi:mem-aref data :unsigned-char (+ (* 4 i) 2)) (svref new-rgb 2)))))))
    ("fade" .
     ,(image-proc-lambda ((fade (real 0.0d0 1.0d0 0.01d0)))
        (loop for i from 0 below (/ length 4) do
              (let* ((rgb (vector (cffi:mem-aref data :unsigned-char (+ (* 4 i) 0))
                                  (cffi:mem-aref data :unsigned-char (+ (* 4 i) 1))
                                  (cffi:mem-aref data :unsigned-char (+ (* 4 i) 2))))
                     (hsl (rgb->hsl rgb))
                     (l   (svref hsl 2)))
                (setf l (- 1 (* (- 1 l) (- 1 fade))))
                (setf (svref hsl 2) l)
                (let ((new-rgb (hsl->rgb hsl)))
                  (setf (cffi:mem-aref data :unsigned-char (+ (* 4 i) 0)) (svref new-rgb 0))
                  (setf (cffi:mem-aref data :unsigned-char (+ (* 4 i) 1)) (svref new-rgb 1))
                  (setf (cffi:mem-aref data :unsigned-char (+ (* 4 i) 2)) (svref new-rgb 2)))))))
    ("zoom" .
     ,(image-proc-lambda ((zoom (real 1.0d0 +10.0d0 0.1d0)))
                         (let* ((mod-pixbuf  (gdk-pixbuf:pixbuf-copy *pixbuf-new*))
                                (m-ps        (pixbuf->pixel-str mod-pixbuf))
                                (m-data      (pixel-str-data   m-ps))
                                (zero-struct (cffi:convert-to-foreign '(red 0 green 0 blue 0 alpha 0)
                                                                      '(:struct c-rgba))))
                           (loop for x from 0 below width do
                                 (loop for y from 0 below height do
                                       (let* ((shx     (- x (floor width  2)))
                                              (shy     (- y (floor height 2)))
                                              (newx    (/ shx zoom))
                                              (newy    (/ shy zoom))
                                              (newx-cen (+ newx (floor width 2)))
                                              (newy-cen (+ newy (floor height 2)))
                                              (newx-nn  (round newx-cen))
                                              (newy-nn  (round newy-cen)))
                                         (setf (cffi:mem-aref m-data '(:struct c-rgba) (+ (* y width) x))
                                               (if (or (not (< -1 newx-nn width)) (not (< -1 newy-nn height)))
                                                   (cffi:mem-aref zero-struct '(:struct c-rgba))
                                                   (cffi:mem-aref data '(:struct c-rgba)
                                                                  (+ (* newy-nn width) newx-nn)))))))
                           (setf *pixbuf-new* mod-pixbuf))))))

(defparameter *pixbuf-original* ())
(defparameter *pixbuf-new* ())
; FIXME: temporary workaround
(defparameter *img-new* ())