320 lines
17 KiB
Common Lisp
320 lines
17 KiB
Common Lisp
|
;;;; 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* ())
|