Created
December 31, 2009 16:33
-
-
Save joelreymont/266787 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(defun blend (pane target-file source-file mask-file) | |
(let* ((source (gp:load-image pane source-file :cache t)) | |
(target (gp:load-image pane target-file :cache t)) | |
(mask (gp:load-image pane mask-file :cache t)) | |
(source-access (gp:make-image-access pane source)) | |
(target-access (gp:make-image-access pane target)) | |
(mask-access (gp:make-image-access pane mask))) | |
(unwind-protect | |
(progn | |
(gp:image-access-transfer-from-image source-access) | |
(gp:image-access-transfer-from-image target-access) | |
(gp:image-access-transfer-from-image mask-access) | |
(dotimes (y (gp:image-access-height target-access)) | |
(dotimes (x (gp:image-access-width target-access)) | |
(let* ((scolor (color:unconvert-color | |
pane | |
(gp:image-access-pixel source-access x y))) | |
(tcolor (color:unconvert-color | |
pane | |
(gp:image-access-pixel target-access x y))) | |
(mcolor (color:unconvert-color | |
pane | |
(gp:image-access-pixel mask-access x y)))) | |
(setf (gp:image-access-pixel target-access x y) | |
(color:convert-color | |
pane | |
(color:make-rgb | |
;; red | |
(+ | |
(* (color:color-red scolor) | |
(color:color-red mcolor)) | |
(* (color:color-red tcolor) | |
(- 1 (color:color-red mcolor)))) | |
;; green | |
(+ | |
(* (color:color-green scolor) | |
(color:color-green mcolor)) | |
(* (color:color-green tcolor) | |
(- 1 (color:color-green mcolor)))) | |
;; blue | |
(+ | |
(* (color:color-blue scolor) | |
(color:color-blue mcolor)) | |
(* (color:color-blue tcolor) | |
(- 1 (color:color-blue mcolor)))) | |
)))))) | |
(gp:image-access-transfer-to-image target-access)) | |
(progn | |
(gp:free-image-access source-access) | |
(gp:free-image-access target-access) | |
(gp:free-image-access mask-access))) | |
target)) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment