1 ;;; ffi-wand.el --- SXEmacs interface to libWand
3 ;;{{{ Copyright (C) 2005 Sebastian Freundt
5 ;; Author: Sebastian Freundt <hroptatyr@sxemacs.org>
6 ;; Zajcev Evgeny <lg@sxemacs.org>
7 ;; Keywords: ffi, wand, ImageMagick
9 ;; This file is part of SXEmacs.
11 ;; SXEmacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; SXEmacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
26 ;;; Synched up with: Not in FSF
30 ;; To use `Wand-display' with `C-x C-f' add:
32 ;; (Wand-find-file-enable)
38 ;; - HUGE memory leaks, but it looks like SXEmacs glyph caching
39 ;; mechanism eats memory, not wand.
40 ;; Hmm it might not be an issue any more, i've got no memory
41 ;; leaks on MacOS processing huge ammount of large images.
44 ;; - When saving in some formats like "HTML" ImageMagick core dumps,
45 ;; so be careful. Need some assistance from IM developers to solve
54 (globally-declare-boundp
55 '(operations-list undo-list buffer-file-name image-wand preview-wand
56 preview-region preview-extent
57 find-file-magic-files-alist)))
61 (defvar Wand-ffio-as-image-data
63 (vector 'rawrgb :data (make-ffi-object 'pointer)
64 :pixel-width 2 :pixel-height 2) 'image))
66 ;; this is our spine, barf if it does not exist
67 ;; ImageMagick version 6.4.0 calls libWand `libMagickWand' so try the
68 ;; old name first and don't error, fall back to the new name, barf if
69 ;; that fails as well --SY.
70 (or (ffi-load-library "libWand")
71 (ffi-load "libMagickWand"))
74 ;;{{{ [+] FFI for MagickWand
77 (define-ffi-type MagickBooleanType long)
78 (define-ffi-translator-to-foreign MagickBooleanType
80 (define-ffi-translator-from-foreign MagickBooleanType
83 (define-ffi-struct MagickWand-private
85 (name (array char 4096))
88 (quantize-info pointer)
90 (active MagickBooleanType)
91 (pend MagickBooleanType)
92 (debug MagickBooleanType)
93 (signature unsigned-long))
95 (define-ffi-type MagickStatusType unsigned-int)
96 (define-ffi-struct MagickInfo
107 (magick pointer) ; IsImageFormatHandler
108 (client-date pointer)
110 (adjoin MagickBooleanType)
111 (raw MagickBooleanType)
112 (endian_support MagickBooleanType)
113 (blob_support MagickBooleanType)
114 (seekable_stream MagickBooleanType)
115 (thread-support MagickStatusType)
116 (stealth MagickBooleanType)
118 ;; deprecated, use GetMagickInfoList()
122 (signature unsigned-long))
124 (define-ffi-enum MagickExceptionType
126 (WarningException 300)
127 (ResourceLimitWarning 300)
130 (DelegateWarning 315)
131 (MissingDelegateWarning 320)
132 (CorruptImageWarning 325)
133 (FileOpenWarning 330)
145 (RegistryWarning 390)
146 (ConfigureWarning 395)
148 (ResourceLimitError 400)
152 (MissingDelegateError 420)
153 (CorruptImageError 425)
168 (FatalErrorException 700)
169 (ResourceLimitFatalError 700)
171 (OptionFatalError 710)
172 (DelegateFatalError 715)
173 (MissingDelegateFatalError 720)
174 (CorruptImageFatalError 725)
175 (FileOpenFatalError 730)
177 (StreamFatalError 740)
178 (CacheFatalError 745)
179 (CoderFatalError 750)
180 (ModuleFatalError 755)
182 (ImageFatalError 765)
184 (RandomFatalError 775)
185 (XServerFatalError 780)
186 (MonitorFatalError 785)
187 (RegistryFatalError 790)
188 (ConfigureFatalError 795))
190 (define-ffi-struct MagickExceptionInfo
191 (severity MagickExceptionType)
194 (description pointer)
196 (relinquish MagickBooleanType)
198 (signature unsigned-long))
201 (define-ffi-type MagickWand (pointer void))
202 (define-ffi-type DrawingWand (pointer void))
203 (define-ffi-type PixelWand (pointer void))
205 (define-ffi-struct PointInfo
206 (x double) (y double))
208 (define-ffi-enum MagickStorageType
217 (define-ffi-enum MagickChannelType
218 (undefined-channel #x0000)
220 (cyan-channel #x0001)
221 (gray-channel #x0001)
222 (green-channel #x0002)
223 (magenta-channel #x0002)
224 (blue-channel #x0004)
225 (yellow-channel #x0004)
226 (alpha-channel #x0008)
227 (opacity-channel #x0008)
228 (black-channel #x0020)
229 (index-channel #x0020)
230 (all-channel #x7fff))
232 (define-ffi-enum WandCompositeOperator
239 ChangeMaskCompositeOp
242 ColorDodgeCompositeOp
249 CopyMagentaCompositeOp
250 CopyOpacityCompositeOp
252 CopyYellowCompositeOp
259 DifferenceCompositeOp
267 LinearLightCompositeOp
290 (define-ffi-enum FillRule
295 (define-ffi-enum PaintMethod
303 (define-ffi-enum MagickAlphaType
304 UndefinedAlphaChannel
306 DeactivateAlphaChannel
310 (define-ffi-enum MagickNoiseType
314 MultiplicativeGaussianNoise
320 (define-ffi-enum MagickFilterType
345 (define-ffi-enum MagickColorspaceType
349 TransparentColorspace
364 Rec601YCbCrColorspace
366 Rec709YCbCrColorspace
371 ;;{{{ `-- Wand:version
373 (cffi:defcfun ("GetMagickVersion" Wand:GetMagickVersion) c-string
374 (n (pointer unsigned-long)))
376 (defun Wand:version ()
377 "Return Image Magick version string."
378 (let ((n (make-ffi-object 'unsigned-long)))
379 (Wand:GetMagickVersion (ffi-address-of n))))
382 ;;{{{ `-- Mime Type operations
384 (cffi:defcfun ("DestroyString" Wand:DestroyString) (pointer char)
387 (cffi:defcfun ("MagickToMime" Wand:MagickToMime) (pointer char)
390 (defun wand-format-mime-type (format)
391 "Return mime-type for the FORMAT."
392 (let ((mt (Wand:MagickToMime format)))
393 (unless (ffi-null-p mt)
395 (ffi-get mt :type 'c-string)
396 (Wand:DestroyString mt)))))
398 (defun Wand:image-mime-type (wand)
399 "Return mime-type for the WAND."
400 (wand-format-mime-type (Wand:image-format wand)))
403 ;;{{{ `-- MagickWand operations
405 ;; Return a newly allocated MagickWand.
406 (cffi:defcfun ("NewMagickWand" Wand:make-wand) MagickWand)
408 ;; Clear all resources associated with the WAND.
409 ;; This does not free the memory, i.e. @var{wand} can furtherly be used
410 ;; as a context, see `Wand:delete-wand'."
411 (cffi:defcfun ("ClearMagickWand" Wand:clear-wand) void
414 ;; Return a cloned copy of WAND.
415 (cffi:defcfun ("CloneMagickWand" Wand:copy-wand) MagickWand
418 ;; Gets the image at the current image index.
419 (cffi:defcfun ("MagickGetImage" Wand:get-image) MagickWand
423 ;; This frees all resources associated with the WAND.
424 ;; WARNING: Do not use WAND after calling this function!
425 (cffi:defcfun ("DestroyMagickWand" Wand:delete-wand) void
428 ;; Return non-nil if WAND is a magick wand, nil otherwise.
429 (cffi:defcfun ("IsMagickWand" Wand:wandp) MagickBooleanType
432 (defmacro Wand-with-wand (wand &rest forms)
433 "With allocated WAND do FORMS."
434 `(let ((,wand (Wand:make-wand)))
437 (Wand:delete-wand ,wand))))
438 (put 'Wand-with-wand 'lisp-indent-function 'defun)
440 (cffi:defcfun ("MagickNewImage" Wand:make-image) MagickBooleanType
441 "Adds a blank image canvas to the WAND."
442 (wand MagickWand) (cols unsigned-long) (rows unsigned-long)
445 ;; Extracts a region of the image and returns it as a a new wand.
446 (cffi:defcfun ("MagickGetImageRegion" Wand:image-region) MagickWand
447 (wand MagickWand) (dx unsigned-long) (dy unsigned-long)
448 (x unsigned-long) (y unsigned-long))
450 ;; MagickIdentifyImage() identifies an image by printing its
451 ;; attributes to the file. Attributes include the image width, height,
453 (cffi:defcfun ("MagickIdentifyImage" Wand:MagickIdentifyImage) pointer
456 (defun Wand:identify-image (wand)
457 "Return info about the image stored in WAND."
458 (let ((ii (Wand:MagickIdentifyImage wand)))
460 (ffi-get ii :type 'c-string)
461 (Wand:RelinquishMemory ii))))
463 ;; MagickResetImagePage() resets the Wand page canvas and position.
464 (cffi:defcfun ("MagickResetImagePage" Wand:MagickResetImagePage)
466 (wand MagickWand) (geom c-string))
468 (defun Wand:reset-image-page (wand &optional geometry)
469 "Reset the WAND page canvas and position to GEOMETRY.
470 If GEOMETRY is ommited then 0x0+0+0 is used."
471 (Wand:MagickResetImagePage wand (or geometry "0x0+0+0")))
474 ;;{{{ `-- Images list operations
476 (cffi:defcfun ("MagickGetNumberImages" Wand:images-num) unsigned-long
479 (cffi:defcfun ("MagickHasNextImage" Wand:has-next-image) MagickBooleanType
482 (cffi:defcfun ("MagickNextImage" Wand:next-image) MagickBooleanType
485 (cffi:defcfun ("MagickHasPreviousImage" Wand:has-prev-image) MagickBooleanType
488 (cffi:defcfun ("MagickPreviousImage" Wand:prev-image) MagickBooleanType
491 (cffi:defcfun ("MagickGetIteratorIndex" Wand:iterator-index) long
494 (cffi:defcfun ("MagickSetIteratorIndex" Wand:MagickSetIteratorIndex)
496 (wand MagickWand) (idx long))
498 (defsetf Wand:iterator-index (w) (idx)
499 `(Wand:MagickSetIteratorIndex ,w ,idx))
501 (cffi:defcfun ("MagickSetFirstIterator" Wand:set-first-iterator) void
504 (cffi:defcfun ("MagickSetLastIterator" Wand:set-last-iterator) void
508 ;;{{{ `-- Image data input/output
510 (cffi:defcfun ("MagickReadImage" Wand:MagickReadImage) MagickBooleanType
514 (defun Wand:read-image (wand file)
515 "Read FILE and associate it with WAND."
516 (let ((fname (expand-file-name file)))
517 ;; simple error catchers
518 (unless (file-readable-p fname)
519 (error "File unreadable %s" fname))
520 (unless (Wand:wandp wand)
521 (wrong-type-argument 'Wand:wandp wand))
522 (Wand:MagickReadImage wand fname)))
524 (cffi:defcfun ("MagickReadImageBlob" Wand:MagickReadImageBlob) MagickBooleanType
529 (defun Wand:read-image-blob (wand blob)
530 "Read image from BLOB and associate it with WAND."
531 (let* ((lb (length blob))
532 (fob (make-ffi-object 'pointer (1+ lb))))
533 (ffi-store fob 0 'c-string blob)
534 (Wand:MagickReadImageBlob wand fob lb)))
536 (cffi:defcfun ("MagickDisplayImage" Wand:MagickDisplayImage) MagickBooleanType
540 (defun Wand:display-image (wand)
541 "Display the image associated with WAND.
542 WARNING: this will block untill display exits, so be careful."
543 (let ((x-server (device-connection (default-x-device))))
544 (Wand:MagickDisplayImage wand x-server)))
546 (cffi:defcfun ("MagickGetImageBlob" Wand:GetImageBlob) pointer
548 (len (pointer unsigned-int)))
550 (cffi:defcfun ("MagickRelinquishMemory" Wand:RelinquishMemory) pointer
553 (defun Wand:image-blob (wand)
554 "Return WAND's direct image data according to format.
555 Use \(setf \(Wand:image-format w\) FMT\) to set format."
556 (let* ((len (make-ffi-object 'unsigned-int))
557 (data (Wand:GetImageBlob wand (ffi-address-of len))))
559 (ffi-get data :type (cons 'c-data (ffi-get len)))
560 (Wand:RelinquishMemory data))))
562 (cffi:defcfun ("MagickWriteImage" Wand:MagickWriteImage) MagickBooleanType
565 (defun Wand:write-image (wand file)
566 "Write the image associated with WAND to FILE."
567 (let ((fname (expand-file-name file)))
568 ;; simple error catchers
569 (unless (file-writable-p fname)
570 (error "File unwritable %s" fname))
571 (unless (Wand:wandp wand)
572 (wrong-type-argument 'Wand:wandp wand))
573 (Wand:MagickWriteImage wand fname)))
576 ;;{{{ `-- Image format operations
578 (cffi:defcfun ("MagickQueryFormats"
579 Wand:QueryFormats) (pointer c-string)
581 (num-formats (pointer unsigned-long)))
583 (defun Wand:query-formats (pattern)
584 "Return list of supported formats that match PATTERN.
585 Use \"*\" to query all available formats."
586 (let* ((nf (make-ffi-object 'unsigned-long))
587 (fmts (Wand:QueryFormats pattern (ffi-address-of nf))))
588 (loop for n from 0 below (ffi-get nf)
590 (ffi-get fmts :off (* n (ffi-size-of-type 'pointer)))
593 (cffi:defcfun ("MagickGetFormat" Wand:wand-format) c-string
595 (cffi:defcfun ("MagickSetFormat" Wand:MagickSetFormat) MagickBooleanType
596 (wand MagickWand) (format c-string))
598 (defsetf Wand:wand-format (w) (nfmt)
599 `(Wand:MagickSetFormat ,w ,nfmt))
601 (cffi:defcfun ("MagickGetImageFormat" Wand:GetImageFormat) c-string
604 (cffi:defcfun ("MagickSetImageFormat" Wand:SetImageFormat) MagickBooleanType
608 (defun Wand:image-format (w)
609 "Return format for the image hold by W.
610 Use \(setf \(Wand:image-format w\) FMT\) to set new one."
611 (Wand:GetImageFormat w))
613 (defsetf Wand:image-format (w) (fmt)
614 `(Wand:SetImageFormat ,w ,fmt))
616 (cffi:defcfun ("GetMagickInfo" Wand:GetMagickInfo) (pointer MagickInfo)
620 (cffi:defcfun ("GetMagickInfoList" Wand:GetMagickInfoList)
621 (pointer (pointer MagickInfo))
623 (number-of-items (pointer unsigned-long))
626 (cffi:defcfun ("GetMagickBlobSupport" Wand:GetMagickBlobSupport)
628 (mi (pointer MagickInfo)))
630 (cffi:defcfun ("MagickGetImageColorspace" Wand:GetImageColorspace)
634 (cffi:defcfun ("MagickSetImageColorspace" Wand:SetImageColorspace)
637 (cst MagickColorspaceType))
640 ;;{{{ `-- PixelWand operations
642 (cffi:defcfun ("NewPixelWand" Wand:NewPixelWand) PixelWand)
643 (cffi:defcfun ("DestroyPixelWand" Wand:DestroyPixelWand) PixelWand
646 (defmacro Wand-with-pixel-wand (pw &rest forms)
647 "With allocated pixel wand PW do FORMS."
648 `(let ((,pw (Wand:NewPixelWand)))
651 (Wand:DestroyPixelWand ,pw))))
652 (put 'Wand-with-pixel-wand 'lisp-indent-function 'defun)
654 (cffi:defcfun ("PixelGetHSL" Wand:PixelGetHSL) void
655 (pw PixelWand) (hue (pointer double)) (saturation (pointer double))
656 (lightness (pointer double)))
658 (cffi:defcfun ("PixelSetHSL" Wand:PixelSetHSL) void
659 (pw PixelWand) (hue double) (saturation double) (lightness double))
661 (defun Wand:pixel-hsl (pw)
662 "Return HSL for pixel wand PW."
663 (let ((hue (make-ffi-object 'double))
664 (sat (make-ffi-object 'double))
665 (light (make-ffi-object 'double)))
666 (Wand:PixelGetHSL pw (ffi-address-of hue) (ffi-address-of sat)
667 (ffi-address-of light))
668 (mapcar #'ffi-get (list hue sat light))))
670 (defsetf Wand:pixel-hsl (pw) (hsl)
671 `(apply #'Wand:PixelSetHSL ,pw ,hsl))
673 (cffi:defcfun ("PixelGetRed" Wand:pixel-red) double
675 (cffi:defcfun ("PixelGetGreen" Wand:pixel-green) double
677 (cffi:defcfun ("PixelGetBlue" Wand:pixel-blue) double
680 ;; PixelGetColorAsString() returns the color of the pixel wand as a
682 (cffi:defcfun ("PixelGetColorAsString" Wand:pixel-color) c-string
685 ;; PixelSetColor() sets the color of the pixel wand with a string
686 ;; (e.g. "blue", "#0000ff", "rgb(0,0,255)", "cmyk(100,100,100,10)",
688 (cffi:defcfun ("PixelSetColor" Wand:PixelSetColor) MagickBooleanType
692 (defsetf Wand:pixel-color (pw) (color)
693 `(Wand:PixelSetColor ,pw ,color))
695 ;; PixelGetAlpha() returns the normalized alpha color of the pixel
697 (cffi:defcfun ("PixelGetAlpha" Wand:pixel-alpha) double
700 ;; PixelSetAlpha() sets the normalized alpha color of the pixel wand.
701 ;; The level of transparency: 1.0 is fully opaque and 0.0 is fully
703 (cffi:defcfun ("PixelSetAlpha" Wand:PixelSetAlpha) void
707 (defsetf Wand:pixel-alpha (pw) (alpha)
708 `(Wand:PixelSetAlpha ,pw ,alpha))
711 ;;{{{ `-- Image pixels operations
713 (cffi:defcfun ("MagickGetImagePixels" Wand:MagickGetImagePixels)
718 (delta-width unsigned-long)
719 (delta-height unsigned-long)
721 (storage MagickStorageType)
722 (target (pointer int)))
724 (defun Wand:get-image-pixels-internal
725 (wand from-width from-height delta-width delta-height)
726 "Return WAND's raw string of image pixel data (RGB triples).
727 FROM-WIDTH, FROM-HEIGHT, DELTA-WIDTH, DELTA-HEIGHT specifies region to
729 (let ((target (make-ffi-object 'c-data (* delta-width delta-height 3))))
730 (when (Wand:MagickGetImagePixels
731 wand from-width from-height delta-width delta-height
732 "RGB" 'char-pixel target)
733 (if Wand-ffio-as-image-data
737 (defun Wand:get-image-pixels (wand)
738 "Return WAND's raw string of image pixel data (RGB triples)."
739 (Wand:get-image-pixels-internal
740 wand 0 0 (Wand:image-width wand) (Wand:image-height wand)))
742 (cffi:defcfun ("MagickSetImagePixels" Wand:MagickSetImagePixels)
744 (wand MagickWand) (x-offset long) (y-offset long)
745 (columns unsigned-long) (rows unsigned-long)
746 (map c-string) (storage-type MagickStorageType)
749 (defun Wand:set-image-pixels-internal (wand x y width height pixels)
750 (let ((stor (make-ffi-object 'c-data (* width height 3))))
751 (ffi-set stor pixels)
752 (Wand:MagickSetImagePixels
753 wand x y width height "RGB" 'char-pixel stor)))
755 (defun Wand:pixels-extract-colors (ss &optional n)
756 "Extract colors from SS string.
757 Return list of lists of N int elements representing RBG(A) values."
758 (let ((cls (mapcar #'char-to-int (string-to-list ss)))
761 (push (subseq cls 0 (or n 3)) rls)
762 (setq cls (nthcdr (or n 3) cls)))
765 (defun Wand:pixels-arrange-colors (cls)
766 "Create pixels string from CLS.
767 CLS is list of lists of N int elements representing RBG(A) values."
768 (mapconcat #'identity
770 (mapcar #'(lambda (els)
771 (mapcar #'char-to-string
772 (mapcar #'int-to-char els)))
776 ;; MagickConstituteImage() adds an image to the wand comprised of the
777 ;; pixel data you supply. The pixel data must be in scanline order
778 ;; top-to-bottom. The data can be char, short int, int, float, or
779 ;; double. Float and double require the pixels to be normalized
780 ;; [0..1], otherwise [0..Max], where Max is the maximum value the type
781 ;; can accomodate (e.g. 255 for char). For example, to create a
782 ;; 640x480 image from unsigned red-green-blue character data, use
783 (cffi:defcfun ("MagickConstituteImage" Wand:MagickConstituteImage)
785 (wand MagickWand) (width unsigned-long) (height unsigned-long)
786 (map c-string) (storage MagickStorageType) (pixels pointer))
789 ;;{{{ `-- Image modification functions
791 (cffi:defcfun ("MagickThumbnailImage" Wand:thumbnail-image)
793 (wand MagickWand) (width unsigned-long) (height unsigned-long))
795 (cffi:defcfun ("MagickRotateImage" Wand:RotateImage) MagickBooleanType
796 (wand MagickWand) (background-pixel PixelWand) (degrees double))
798 ;;Scale the image in WAND to the dimensions WIDTHxHEIGHT.
799 (cffi:defcfun ("MagickScaleImage" Wand:scale-image) MagickBooleanType
800 (wand MagickWand) (width unsigned-long) (height unsigned-long))
803 (cffi:defcfun ("MagickSampleImage" Wand:sample-image) MagickBooleanType
804 (wand MagickWand) (width unsigned-long) (height unsigned-long))
806 (cffi:defcfun ("MagickResizeImage" Wand:resize-image) MagickBooleanType
807 (wand MagickWand) (width unsigned-long) (height unsigned-long)
808 (filter MagickFilterType) (blur double))
810 (cffi:defcfun ("MagickLiquidRescaleImage" Wand:liquid-rescale)
812 (wand MagickWand) (width unsigned-long) (height unsigned-long)
813 (delta-x double) (rigidity double))
815 ;; Crop to the rectangle spanned at X and Y by width DX and
816 ;; height DY in the image associated with WAND."
817 (cffi:defcfun ("MagickCropImage" Wand:crop-image) MagickBooleanType
818 (wand MagickWand) (width unsigned-long) (heigth unsigned-long)
819 (x unsigned-long) (y unsigned-long))
821 ;; MagickChopImage() removes a region of an image and collapses the
822 ;; image to occupy the removed portion
823 (cffi:defcfun ("MagickChopImage" Wand:chop-image) MagickBooleanType
824 (wand MagickWand) (width unsigned-long) (heigth unsigned-long)
827 (cffi:defcfun ("MagickFlipImage" Wand:flip-image) MagickBooleanType
829 (cffi:defcfun ("MagickFlopImage" Wand:flop-image) MagickBooleanType
831 ;; Rolls (offsets) the image associated with WAND to an offset
833 (cffi:defcfun ("MagickRollImage" Wand:roll-image) MagickBooleanType
834 (wand MagickWand) (x long) (y long))
836 ;; Composite one image COMPOSITE-WAND onto another WAND at the
837 ;; specified offset X, Y, using composite operator COMPOSE.
838 (cffi:defcfun ("MagickCompositeImage" Wand:image-composite) MagickBooleanType
839 (wand MagickWand) (composite-wand MagickWand) (compose WandCompositeOperator)
842 (cffi:defcfun ("MagickCompositeImageChannel" Wand:image-composite-channel)
844 (wand MagickWand) (channel MagickChannelType) (region-wand MagickWand)
845 (compose WandCompositeOperator) (x long) (y long))
847 ;;; image improvements and basic image properties
848 (cffi:defcfun ("MagickContrastImage" Wand:MagickContrastImage)
850 (wand MagickWand) (contrast MagickBooleanType))
851 (defun Wand:increase-contrast-image (wand)
852 "Increase the contrast of the image associated with WAND."
853 (Wand:MagickContrastImage wand t))
854 (defun Wand:decrease-contrast-image (wand)
855 "Decrease the contrast of the image associated with WAND."
856 (Wand:MagickContrastImage wand nil))
858 ;; Reduce the speckle noise in the image associated with WAND.
859 (cffi:defcfun ("MagickDespeckleImage" Wand:despeckle-image) MagickBooleanType
861 ;; Enhance the image associated with WAND.
862 (cffi:defcfun ("MagickEnhanceImage" Wand:enhance-image) MagickBooleanType
864 ;; Equalise the image associated with WAND.
865 (cffi:defcfun ("MagickEqualizeImage" Wand:equalize-image) MagickBooleanType
867 ;; Normalise the image associated with WAND.
868 (cffi:defcfun ("MagickNormalizeImage" Wand:normalize-image) MagickBooleanType
873 (cffi:defcfun ("MagickColorizeImage" Wand:MagickColorizeImage)
875 (w MagickWand) (color pointer) (opacity pointer))
877 ;; Simulate a charcoal drawing of the image associated with WAND.
878 ;; The RADIUS argument is a float and measured in pixels.
879 ;; The SIGMA argument is a float and defines a derivation.
880 (cffi:defcfun ("MagickCharcoalImage" Wand:charcoal-image) MagickBooleanType
881 (wand MagickWand) (radius double) (sigma double))
883 ;; Simulate oil-painting of image associated with WAND.
884 ;; The RADIUS argument is a float and measured in pixels.
885 (cffi:defcfun ("MagickOilPaintImage" Wand:oil-paint-image) MagickBooleanType
886 (wand MagickWand) (radius double))
888 ;; MagickSepiaToneImage() applies a special effect to the image,
889 ;; similar to the effect achieved in a photo darkroom by sepia
890 ;; toning. Threshold ranges from 0 to QuantumRange and is a measure of
891 ;; the extent of the sepia toning. A threshold of 80 is a good
892 ;; starting point for a reasonable tone.
893 (cffi:defcfun ("MagickSepiaToneImage" Wand:sepia-tone-image) MagickBooleanType
894 (wand MagickWand) (threshold double))
896 ;; MagickImplodeImage() creates a new image that is a copy of an
897 ;; existing one with the image pixels "implode" by the specified
898 ;; percentage. It allocates the memory necessary for the new Image
899 ;; structure and returns a pointer to the new image.
900 (cffi:defcfun ("MagickImplodeImage" Wand:implode-image) MagickBooleanType
901 (wand MagickWand) (radius double))
903 ;; MagickVignetteImage() softens the edges of the image in vignette
905 (cffi:defcfun ("MagickVignetteImage" Wand:vignette-image)
907 (wand MagickWand) (black-point double) (white-point double)
908 (x double) (y double))
910 ;; Enhance the edges of the image associated with WAND.
911 ;; The RADIUS argument is a float and measured in pixels.
912 (cffi:defcfun ("MagickEdgeImage" Wand:edge-image) MagickBooleanType
913 (wand MagickWand) (radius double))
915 ;; Emboss the image associated with WAND (a relief effect).
916 ;; The RADIUS argument is a float and measured in pixels.
917 ;; The SIGMA argument is a float and defines a derivation.
918 (cffi:defcfun ("MagickEmbossImage" Wand:emboss-image) MagickBooleanType
919 (wand MagickWand) (radius double) (sigma double))
921 ;; MagickWaveImage() creates a "ripple" effect in the image by
922 ;; shifting the pixels vertically along a sine wave whose amplitude
923 ;; and wavelength is specified by the given parameters.
924 ;; The AMPLITUDE argument is a float and defines the how large
926 ;; The WAVELENGTH argument is a float and defines how often the
928 (cffi:defcfun ("MagickWaveImage" Wand:wave-image) MagickBooleanType
929 (wand MagickWand) (amplitude double) (wavelength double))
931 ;; Swirl the image associated with WAND by DEGREES.
932 (cffi:defcfun ("MagickSwirlImage" Wand:swirl-image) MagickBooleanType
933 (wand MagickWand) (degrees double))
935 (cffi:defcfun ("MagickPosterizeImage" Wand:MagickPosterizeImage)
937 (wand MagickWand) (levels unsigned-long) (ditherp MagickBooleanType))
938 (defun Wand:posterize-image (wand levels &optional ditherp)
939 "Posterize the image associated with WAND.
940 that is quantise the range of used colours to at most LEVELS.
941 If optional argument DITHERP is non-nil use a dithering
942 effect to wipe hard contrasts."
943 (Wand:MagickPosterizeImage wand levels ditherp))
945 ;; MagickAddNoiseImage() adds random noise to the image.
946 (cffi:defcfun ("MagickAddNoiseImage" Wand:add-noise-image) MagickBooleanType
947 (wand MagickWand) (noise-type MagickNoiseType))
949 (cffi:defcfun ("MagickAddNoiseImageChannel" Wand:add-noise-image-channel)
951 (wand MagickWand) (channel MagickChannelType) (noise-type MagickNoiseType))
953 ;; Reduce the noise in the image associated with WAND by RADIUS.
954 (cffi:defcfun ("MagickReduceNoiseImage" Wand:reduce-noise-image)
956 (wand MagickWand) (radius double))
958 ;; Perform gamma correction on the image associated with WAND.
959 ;; The argument LEVEL is a positive float, a value of 1.00 (read 100%)
961 (cffi:defcfun ("MagickGammaImage" Wand:gamma-image) MagickBooleanType
962 (wand MagickWand) (level double))
964 ;; Perform gamma correction on CHANNEL of LEVEL on the image
965 ;; associated with WAND.
966 (cffi:defcfun ("MagickGammaImageChannel" Wand:gamma-image-channel)
968 (wand MagickWand) (channel MagickChannelType) (level double))
970 ;; Perform median normalisation of the pixels in the image associated
972 (cffi:defcfun ("MagickMedianFilterImage" Wand:median-filter-image)
974 (wand MagickWand) (radius double))
976 ;; Solarise the image associated with WAND.
977 (cffi:defcfun ("MagickSolarizeImage" Wand:solarize-image) MagickBooleanType
981 ;; Tweak the image associated with WAND.
982 (cffi:defcfun ("MagickModulateImage" Wand:MagickModulateImage)
984 (wand MagickWand) (brightness double) (saturation double) (hue double))
986 (defun* Wand:modulate-image (wand &key (brightness 100.0)
989 (Wand:MagickModulateImage wand brightness saturation hue))
991 ;; Separate a two-color high contrast image.
992 (cffi:defcfun ("MagickThresholdImage" Wand:threshold-image) MagickBooleanType
993 (wand MagickWand) (threshold double))
995 ;; Separate a two-color high contrast image on CHANNEL.
996 (cffi:defcfun ("MagickThresholdImageChannel" Wand:threshold-image-channel)
998 (wand MagickWand) (channel MagickChannelType) (threshold double))
1000 (cffi:defcfun ("MagickWhiteThresholdImage" Wand:white-threshold-image)
1002 (wand MagickWand) (threshold double))
1004 (cffi:defcfun ("MagickRaiseImage" Wand:MagickRaiseImage) MagickBooleanType
1005 (wand MagickWand) (width unsigned-long) (height unsigned-long)
1006 (x long) (y long) (raise MagickBooleanType))
1008 (defun Wand:raise-image (wand &optional raise)
1010 (Wand:MagickRaiseImage
1011 wand (Wand:image-width wand) (Wand:image-height wand)
1016 ;; Blur the image associated with WAND.
1017 ;; The RADIUS argument is a float and measured in pixels.
1018 ;; The SIGMA argument is a float and defines a derivation.
1019 (cffi:defcfun ("MagickBlurImage" Wand:blur-image) MagickBooleanType
1020 (wand MagickWand) (radius double) (sigma double))
1022 ;; Blur CHANNEL in the image associated with WAND by RADIUS
1023 ;; pixels with derivation SIGMA.
1024 (cffi:defcfun ("MagickBlurImageChannel" Wand:blur-image-channel)
1026 (wand MagickWand) (channel MagickChannelType)
1027 (radius double) (sigma double))
1029 ;; Blur the image associated with WAND.
1030 ;; The RADIUS argument is a float and measured in pixels.
1031 ;; The SIGMA argument is a float and defines a derivation.
1032 (cffi:defcfun ("MagickGaussianBlurImage" Wand:gaussian-blur-image)
1034 (wand MagickWand) (radius double) (sigma double))
1036 ;; Blur CHANNEL in the image associated with WAND by RADIUS
1037 ;; pixels with derivation SIGMA.
1038 (cffi:defcfun ("MagickGaussianBlurImageChannel"
1039 Wand:gaussian-blur-image-channel) MagickBooleanType
1040 (wand MagickWand) (channel MagickChannelType)
1041 (radius double) (sigma double))
1043 ;; Blur the image associated with WAND.
1044 ;; The RADIUS argument is a float and measured in pixels.
1045 ;; The SIGMA argument is a float and defines a derivation.
1046 ;; The ANGLE argument is a float and measured in degrees.
1047 (cffi:defcfun ("MagickMotionBlurImage" Wand:motion-blur-image)
1049 (wand MagickWand) (radius double) (sigma double) (angle double))
1051 ;; Blur the image associated with WAND.
1052 ;; The ANGLE argument is a float and measured in degrees.
1053 (cffi:defcfun ("MagickRadialBlurImage" Wand:radial-blur-image)
1055 (wand MagickWand) (radius double))
1057 ;; Sharpen the image associated with WAND.
1058 ;; The RADIUS argument is a float and measured in pixels.
1059 ;; The SIGMA argument is a float and defines a derivation.
1060 (cffi:defcfun ("MagickSharpenImage" Wand:sharpen-image) MagickBooleanType
1062 (radius double) (sigma double))
1064 ;; Sharpen CHANNEL in the image associated with WAND by RADIUS
1065 ;; pixels with derivation SIGMA.
1066 (cffi:defcfun ("MagickSharpenImageChannel" Wand:sharpen-image-channel)
1068 (wand MagickWand) (channel MagickChannelType)
1069 (radius double) (sigma double))
1071 ;; Sharpen the image associated with WAND using an unsharp mask.
1072 ;; The unsharp mask is defined by RADIUS and SIGMA.
1073 ;; The strength of sharpening is controlled by AMOUNT and THRESHOLD.
1074 (cffi:defcfun ("MagickUnsharpMaskImage" Wand:unsharp-mask-image)
1076 (wand MagickWand) (radius double) (sigma double)
1077 (amount double) (threshold double))
1079 ;; Sharpen CHANNEL in the image associated with WAND with an unsharp mask
1080 ;; defined by RADIUS and SIGMA. The strength of sharpening is controlled
1081 ;; by AMOUNT and THRESHOLD.
1082 (cffi:defcfun ("MagickUnsharpMaskImageChannel"
1083 Wand:unsharp-mask-image-channel)
1085 (wand MagickWand) (channel MagickChannelType)
1086 (radius double) (sigma double) (amount double) (threshold double))
1088 (cffi:defcfun ("MagickNegateImage" Wand:MagickNegateImage) MagickBooleanType
1090 (greyp MagickBooleanType))
1091 (defun Wand:negate-image (wand &optional greyp)
1092 "Perform negation on the image associated with WAND."
1093 (Wand:MagickNegateImage wand greyp))
1095 (cffi:defcfun ("MagickNegateImageChannel"
1096 Wand:MagickNegateImageChannel)
1098 (wand MagickWand) (channel MagickChannelType) (greyp MagickBooleanType))
1099 (defun Wand:negate-image-channel (wand channel &optional greyp)
1100 "Perform negation of CHANNEL on the image associated with WAND."
1101 (Wand:MagickNegateImageChannel wand channel greyp))
1103 (cffi:defcfun ("MagickSpreadImage" Wand:spread-image) MagickBooleanType
1104 (wand MagickWand) (radius double))
1106 ;; MagickTrimImage() remove edges that are the background color from
1108 (cffi:defcfun ("MagickTrimImage" Wand:trim-image) MagickBooleanType
1109 (wand MagickWand) (fuzz double))
1112 ;;{{{ `-- Image size
1114 (cffi:defcfun ("MagickGetSize" Wand:MagickGetSize) MagickBooleanType
1115 (w MagickWand) (width (pointer unsigned-long))
1116 (height (pointer unsigned-long)))
1117 (cffi:defcfun ("MagickSetSize" Wand:MagickSetSize) MagickBooleanType
1118 (w MagickWand) (width unsigned-long) (height unsigned-long))
1120 (defun Wand:image-size (wand)
1121 "Return size of the image, associated with WAND."
1122 (let ((w (make-ffi-object 'unsigned-long))
1123 (h (make-ffi-object 'unsigned-long)))
1124 (when (Wand:MagickGetSize wand (ffi-address-of w) (ffi-address-of h))
1125 (cons (ffi-get w) (ffi-get h)))))
1126 (defsetf Wand:image-size (wand) (size)
1127 `(Wand:MagickSetSize ,wand (car ,size) (cdr ,size)))
1129 (cffi:defcfun ("MagickGetImageHeight" Wand:image-height) unsigned-long
1131 (cffi:defcfun ("MagickGetImageWidth" Wand:image-width) unsigned-long
1135 ;;{{{ `-- Image profiles
1137 (defun Wand-fetch-relinquish-strings (strs slen)
1138 "Fetch strings from strings array STRS of length SLEN."
1139 (unless (ffi-null-p strs)
1141 (mapcar #'(lambda (pr)
1142 (ffi-get pr :type 'c-string))
1143 (ffi-get strs :type (list 'array 'pointer slen)))
1144 (Wand:RelinquishMemory strs))))
1147 (cffi:defcfun ("MagickGetImageProfiles" Wand:MagickGetImageProfiles) pointer
1150 (number-profiles pointer))
1152 (defun Wand:image-profiles (wand pattern)
1153 "Get list of WAND's profiles matching PATTERN."
1154 (let* ((plen (make-ffi-object 'unsigned-long))
1155 (profs (Wand:MagickGetImageProfiles
1156 wand pattern (ffi-address-of plen))))
1157 (Wand-fetch-relinquish-strings profs (ffi-get plen))))
1159 (cffi:defcfun ("MagickGetImageProfile" Wand:MagickGetImageProfile) pointer
1164 (cffi:defcfun ("MagickSetImageProfile" Wand:MagickSetImageProfile)
1166 (w MagickWand) (pname c-string)
1167 (prof pointer) (sz unsigned-int))
1169 (defconst Wand-iptc-names-table
1170 '((120 . caption) (25 . keyword)))
1172 (defun Wand:image-profile-iptc (wand)
1173 "Fetch IPTC profile from WAND in lisp-friendly form."
1174 (let* ((plen (make-ffi-object 'unsigned-int))
1175 (prof (Wand:MagickGetImageProfile wand "iptc" (ffi-address-of plen)))
1176 (rlen (ffi-get plen)) (coff 0) (rv nil))
1177 (unless (ffi-null-p prof)
1179 (flet ((getbyte () (prog1
1180 (ffi-get prof :off coff :type 'byte)
1182 ;; 28 - must start any iptc header
1183 (while (and (< coff rlen) (= (getbyte) 28))
1184 (let* ((itype (getbyte)) (idset (getbyte))
1185 (l1 (getbyte)) (l2 (getbyte))
1186 (ln (logior (ash l1 8) l2)))
1188 ;; only string type supported
1189 (push (cons (cdr (assq idset Wand-iptc-names-table))
1190 (ffi-get prof :off coff :type `(c-data . ,ln)))
1194 (Wand:RelinquishMemory prof)))))
1196 (defun Wand:image-save-iptc-profile (w iptc)
1197 "For wand W store IPTC profile."
1198 (let ((oolen (reduce #'(lambda (e1 e2)
1199 (+ e1 5 (length (cdr e2))))
1200 iptc :initial-value 0)))
1202 (let ((prof (make-ffi-object 'pointer oolen))
1204 (flet ((savebyte (byte)
1206 (ffi-store prof coff 'byte byte)
1208 (loop for ipel in iptc do
1209 (savebyte 28) (savebyte 2)
1210 (savebyte (car (find (car ipel)
1211 Wand-iptc-names-table :key #'cdr)))
1212 (let* ((ln (length (cdr ipel)))
1213 (l1 (ash (logand ln #xff00) -8))
1214 (l2 (logand ln #x00ff)))
1215 (savebyte l1) (savebyte l2)
1216 (ffi-store prof coff 'c-string (cdr ipel))
1218 (Wand:MagickSetImageProfile w "iptc" prof oolen)))
1222 ;;{{{ `-- Image properties
1224 (cffi:defcfun ("MagickGetImageProperties" Wand:MagickGetImageProperties) pointer
1227 (number-properties pointer))
1229 (defun Wand:image-properties (w pattern)
1230 "Return list of image properties that match PATTERN."
1231 (let* ((plen (make-ffi-object 'unsigned-long))
1232 (props (Wand:MagickGetImageProperties
1233 w pattern (ffi-address-of plen))))
1234 (Wand-fetch-relinquish-strings props (ffi-get plen))))
1236 (cffi:defcfun ("MagickGetImageProperty" Wand:MagickGetImageProperty) pointer
1237 (w MagickWand) (property c-string))
1239 (cffi:defcfun ("MagickSetImageProperty" Wand:MagickSetImageProperty)
1241 (w MagickWand) (prop c-string) (val c-string))
1243 (defun Wand:image-property (w property)
1244 "Return value for PROPERTY.
1245 Use \(setf \(Wand:image-property w prop\) VAL\) to set property."
1246 (let ((pv (Wand:MagickGetImageProperty w property)))
1247 (unless (ffi-null-p pv)
1249 (ffi-get pv :type 'c-string)
1250 (Wand:RelinquishMemory pv)))))
1252 (defsetf Wand:image-property (w prop) (val)
1253 `(Wand:MagickSetImageProperty ,w ,prop ,val))
1255 (cffi:defcfun ("MagickGetQuantumRange" Wand:MagickGetQuantumRange) pointer
1256 (qr (pointer unsigned-long)))
1257 (defun Wand:quantum-range ()
1258 (let ((qr (make-ffi-object 'unsigned-long)))
1259 (Wand:MagickGetQuantumRange (ffi-address-of qr))
1262 ;; Very simple properties editor
1263 (defun Wand-mode-prop-editor ()
1264 "Run properties editor."
1266 (let* ((iw image-wand)
1267 (props (remove-if-not
1269 (string-match Wand-mode-properties-pattern prop))
1270 (Wand:image-properties iw ""))))
1271 (save-window-excursion
1274 (mapc #'(lambda (prop)
1275 (insert prop ": " (Wand:image-property iw prop) "\n"))
1277 (pop-to-buffer (current-buffer))
1279 (message "Press %s when done, or %s to cancel"
1280 (sorted-key-descriptions
1281 (where-is-internal 'exit-recursive-edit))
1282 (sorted-key-descriptions
1283 (where-is-internal 'abort-recursive-edit)))
1286 ;; User pressed C-M-c, parse buffer and store new props
1287 (goto-char (point-min))
1289 (let* ((st (buffer-substring (point-at-bol) (point-at-eol)))
1290 (pv (split-string st ": ")))
1291 (setf (Wand:image-property iw (first pv)) (second pv)))
1295 ;;{{{ `-- Image clip mask
1297 (cffi:defcfun ("MagickGetImageClipMask" Wand:clip-mask) MagickWand
1300 (cffi:defcfun ("SetImageClipMask" Wand:SetImageClipMask) MagickBooleanType
1301 (i pointer) (m pointer))
1303 (cffi:defcfun ("MagickSetImageClipMask" Wand:MagickSetImageClipMask)
1305 (w MagickWand) (cm MagickWand))
1307 (defsetf Wand:clip-mask (w) (cm)
1308 "Set wand's W clip mask to be CM.
1309 If CM is nil or null-pointer then unset clip mask."
1310 `(if (and ,cm (not (ffi-null-p ,cm)))
1311 (Wand:MagickSetImageClipMask ,w ,cm)
1312 ;; call SetImageClipMask directly to unset the clip mask
1313 (Wand:SetImageClipMask
1314 (ffi-fetch ,w (ffi-slot-offset 'MagickWand-private 'images) 'pointer)
1315 (ffi-null-pointer))))
1318 ;;{{{ `-- Misc image functions
1320 ;; MagickSetImageMatte() (un)sets the image matte channel
1321 (cffi:defcfun ("MagickSetImageMatte" Wand:MagickSetImageMatte) MagickBooleanType
1323 (matte MagickBooleanType))
1325 (cffi:defcfun ("MagickSetImageAlphaChannel" Wand:MagickSetImageAlphaChannel)
1328 (alpha MagickAlphaType))
1331 ;;{{{ `-- DrawingWand operations
1333 ;; MagickDrawImage() renders the drawing wand on the current image.
1334 (cffi:defcfun ("MagickDrawImage" Wand:MagickDrawImage) MagickBooleanType
1335 (w MagickWand) (dw DrawingWand))
1337 (cffi:defcfun ("MagickAnnotateImage" Wand:MagickAnnotateImage)
1339 (w MagickWand) (dw DrawingWand) (x double) (y double)
1340 (angle double) (text c-string))
1342 (cffi:defcfun ("ClearDrawingWand" Wand:clear-drawing-wand) void
1345 (cffi:defcfun ("CloneDrawingWand" Wand:copy-drawing-wand) DrawingWand
1348 (cffi:defcfun ("DestroyDrawingWand" Wand:delete-drawing-wand) DrawingWand
1351 (cffi:defcfun ("NewDrawingWand" Wand:make-drawing-wand) DrawingWand)
1353 (defmacro Wand-with-drawing-wand (dw &rest forms)
1354 "With allocated drawing wand DW do FORMS."
1355 `(let ((,dw (Wand:make-drawing-wand)))
1358 (Wand:delete-drawing-wand ,dw))))
1359 (put 'Wand-with-drawing-wand 'lisp-indent-function 'defun)
1361 (cffi:defcfun ("DrawAnnotation" Wand:draw-annotation) void
1362 (dw DrawingWand) (x double) (y double) (text c-string))
1364 (cffi:defcfun ("DrawArc" Wand:draw-arc) void
1365 (dw DrawingWand) (sx double) (sy double) (ex double)
1366 (ey double) (sd double) (ed double))
1368 (cffi:defcfun ("DrawCircle" Wand:draw-circle) void
1369 (dw DrawingWand) (ox double) (oy double) (px double) (py double))
1371 (cffi:defcfun ("DrawRectangle" Wand:draw-rectangle) void
1372 (dw DrawingWand) (ox double) (oy double) (ex double) (ey double))
1374 (cffi:defcfun ("DrawColor" Wand:draw-color) void
1375 (dw DrawingWand) (x double) (y double) (paint-method PaintMethod))
1377 (cffi:defcfun ("DrawPolygon" Wand:DrawPolygon) void
1379 (number-coordinates unsigned-long)
1380 (coordinates PointInfo))
1382 (cffi:defcfun ("DrawPolyline" Wand:DrawPolyline) void
1384 (number-coordinates unsigned-long)
1385 (coordinates PointInfo))
1387 (defun Wand:points-PointInfo (points)
1388 (let* ((plen (length points))
1389 (coords (make-ffi-object (list 'array 'PointInfo plen))))
1391 (let ((poi (make-ffi-object 'PointInfo))
1392 (npo (nth n points)))
1393 (setf (PointInfo->x poi) (float (car npo))
1394 (PointInfo->y poi) (float (cdr npo)))
1395 (ffi-aset coords n poi)))
1398 (defun Wand:draw-polygon (dw points)
1399 (Wand:DrawPolygon dw (length points) (Wand:points-PointInfo points)))
1401 (defun Wand:draw-lines (dw points)
1402 (Wand:DrawPolyline dw (length points) (Wand:points-PointInfo points)))
1404 ;; DrawComposite() composites an image onto the current image, using
1405 ;; the specified composition operator, specified position, and at the
1407 (cffi:defcfun ("DrawComposite" Wand:DrawComposite) MagickBooleanType
1408 (dw DrawingWand) (compose WandCompositeOperator)
1409 (x double) (y double) (width double) (height double) (wand MagickWand))
1411 ;; DrawEllipse() draws an ellipse on the image.
1412 (cffi:defcfun ("DrawEllipse" Wand:draw-ellipse) void
1413 (dw DrawingWand) (ox double) (oy double) (rx double)
1414 (ry double) (start double) (end double))
1416 (cffi:defcfun ("DrawGetFillColor" Wand:DrawGetFillColor) void
1417 (dw DrawingWand) (pixel pointer))
1419 (cffi:defcfun ("DrawSetFillColor" Wand:DrawSetFillColor) void
1420 (dw DrawingWand) (pixel pointer))
1422 (defun Wand:draw-fill-color (dw)
1423 (error "Not yet implemented"))
1425 (defsetf Wand:draw-fill-color (w) (p)
1426 `(Wand:DrawSetFillColor ,w ,p))
1428 (cffi:defcfun ("DrawGetFillOpacity" Wand:draw-fill-opacity) double
1431 (cffi:defcfun ("DrawSetFillOpacity" Wand:DrawSetFillOpacity) void
1432 (dw DrawingWand) (fo double))
1434 (defsetf Wand:draw-fill-opacity (w) (fo)
1435 `(Wand:DrawSetFillOpacity ,w ,fo))
1437 (cffi:defcfun ("DrawSetFillRule" Wand:DrawSetFillRule) void
1438 (dw DrawingWand) (fr FillRule))
1440 (cffi:defcfun ("DrawMatte" Wand:draw-matte) void
1441 (dw DrawingWand) (x double) (y double) (paint-method PaintMethod))
1443 (cffi:defcfun ("DrawGetStrokeWidth" Wand:draw-stroke-width) double
1446 (cffi:defcfun ("DrawSetStrokeWidth" Wand:DrawSetStrokeWidth) void
1447 (dw DrawingWand) (stroke-width double))
1449 (defsetf Wand:draw-stroke-width (dw) (sw)
1450 `(Wand:DrawSetStrokeWidth ,dw ,sw))
1452 (cffi:defcfun ("DrawSetStrokeColor" Wand:DrawSetStrokeColor) void
1453 (dw DrawingWand) (stroke-color pointer))
1455 (cffi:defcfun ("DrawGetStrokeOpacity" Wand:draw-stroke-opacity) double
1458 (cffi:defcfun ("DrawSetStrokeOpacity" Wand:DrawSetStrokeOpacity) void
1459 (dw DrawingWand) (stroke-opacity double))
1461 (defsetf Wand:draw-stroke-opacity (dw) (so)
1462 `(Wand:DrawSetStrokeOpacity ,dw ,so))
1467 ;; I wonder if we actually need this, Wand-API documentation says
1468 ;; yeah, but I've seen gazillions of code snippets not using it
1471 (cffi:defcfun ("MagickWandGenesis" Wand:MagickWandGenesis) void)
1472 (cffi:defcfun ("MagickWandTerminus" Wand:MagickWandTerminus) void))
1476 ;;{{{ Util glyph and size related functions
1478 (defun Wand:glyph-internal (wand x y w h)
1479 "Return glyph for the WAND."
1482 :data (Wand:get-image-pixels-internal wand x y w h)
1486 (defun Wand:glyph (wand)
1487 "Return glyph for the WAND."
1488 (Wand:glyph-internal
1489 wand 0 0 (Wand:image-width wand) (Wand:image-height wand)))
1491 (defun Wand:correct-orientation (wand)
1492 "Automatically rotate WAND image according to exif:Orientation."
1493 (let* ((orient (Wand:image-property wand "exif:Orientation"))
1494 (angle (cond ((string= orient "6") 90)
1495 ((string= orient "3") 180)
1496 ((string= orient "8") -90))))
1498 (setf (Wand:image-property wand "exif:Orientation") "1")
1499 (Wand-operation-apply 'rotate wand angle))))
1501 (defun Wand:fit-size (wand max-width max-height &optional scaler force)
1502 "Fit WAND image into MAX-WIDTH and MAX-HEIGHT.
1503 This operation keeps aspect ratio of the image.
1504 Use SCALER function to perform scaling, by default `Wand:scale-image'
1506 Return non-nil if fiting was performed."
1507 (unless scaler (setq scaler #'Wand:scale-image))
1508 (let* ((width (Wand:image-width wand))
1509 (height (Wand:image-height wand))
1510 (prop (/ (float width) (float height)))
1512 (when (or force (< max-width width))
1513 (setq width max-width
1514 height (round (/ max-width prop))
1516 (when (< max-height height)
1517 (setq width (round (* max-height prop))
1522 (funcall scaler wand width height))
1525 (defun Wand-mode-preview-glyph (wand)
1526 (let ((off-x (get wand 'offset-x))
1527 (off-y (get wand 'offset-y)))
1528 (Wand:glyph-internal
1530 (- (Wand:image-width wand) off-x)
1531 (- (Wand:image-height wand) off-y))))
1534 ;;{{{ Custom variables for Wand-mode
1536 (defgroup Wand-mode nil
1537 "Group to customize Wand mode."
1538 :prefix "Wand-mode-")
1540 (defcustom Wand-mode-redeye-threshold 1.6
1541 "*Threshold to fix red eyes."
1545 (defcustom Wand-mode-sigma 2.0
1546 "*Sigma for operations such as guassian-blur, sharpen, etc."
1550 (defcustom Wand-mode-zoom-factor 2
1551 "Default zoom in/out factor."
1555 (defcustom Wand-mode-region-outline-color "black"
1556 "*Color used to outline region when selecting."
1560 (defcustom Wand-mode-region-fill-color "white"
1561 "*Color used to fill region when selecting."
1565 (defcustom Wand-mode-region-outline-width 1.3
1566 "*Width of outline line for region when selecting."
1570 (defcustom Wand-mode-region-outline-opacity 0.7
1571 "*Opacity of the outline.
1577 (defcustom Wand-mode-region-fill-opacity 0.35
1578 "*Opacity for the region when selecting.
1584 (defcustom Wand-mode-show-fileinfo t
1585 "*Non-nil to show file info on top of display."
1589 (defcustom Wand-mode-show-iptc-info t
1590 "*Non-nil to display IPTC info if any."
1594 (defcustom Wand-mode-show-operations t
1595 "*Non-nil to show operations done on file."
1599 (defcustom Wand-mode-auto-fit t
1600 "*Non-nil to perform fiting to window size.
1601 You can always toggle fitting using `Wand-mode-toggle-fit' command
1602 \(bound to \\<Wand-mode-map>\\[Wand-mode-toggle-fit]\)."
1606 (defcustom Wand-mode-auto-rotate t
1607 "*Non-nil to perform automatic rotation according to orientation.
1608 Orientation is taken from EXIF."
1612 (defcustom Wand-mode-query-for-overwrite t
1613 "*Non-nil to ask user when overwriting existing files."
1617 (defcustom Wand-mode-properties-pattern "^exif:"
1618 "Pattern for properties editor."
1622 (defvar Wand-global-operations-list nil
1623 "Denotes global operations list")
1625 (defcustom Wand-mode-scaler #'Wand:scale-image
1626 "Function used to scale image for \"fit to size\" operation.
1627 You could use one of `Wand:scale-image', `Wand:sample-image' or create
1628 your own scaler with `Wand-make-scaler'."
1632 (defvar Wand-mode-hook nil
1633 "Hooks to call when entering `Wand-mode'.")
1638 (defvar Wand-mode-map
1639 (let ((map (make-sparse-keymap)))
1640 ;; Undo/Redo operation
1641 (define-key map [(control /)] #'Wand-mode-undo)
1642 (define-key map [(control _)] #'Wand-mode-undo)
1643 (define-key map [undo] #'Wand-mode-undo)
1644 (define-key map [(control ?x) (control ?/)] #'Wand-mode-redo)
1645 (define-key map [(control ?x) (meta ?:)] #'Wand-mode-repeat-last-operation)
1646 (define-key map [(control ?\.)] #'Wand-mode-repeat-last-operation)
1649 (define-key map [(control ?x) (control ?s)] #'Wand-mode-save-file)
1650 (define-key map [(control ?x) (control ?w)] #'Wand-mode-write-file)
1653 (define-key map [space] #'Wand-mode-next-image)
1654 (define-key map [backspace] #'Wand-mode-prev-image)
1655 (define-key map [(meta ?<)] #'Wand-mode-first-image)
1656 (define-key map [(meta >)] #'Wand-mode-last-image)
1658 (define-key map [next] #'Wand-mode-next-page)
1659 (define-key map [prior] #'Wand-mode-prev-page)
1660 (define-key map [home] #'Wand-mode-first-page)
1661 (define-key map [end] #'Wand-mode-last-page)
1662 (define-key map [?g] #'Wand-mode-goto-page)
1663 (define-key map [(meta ?g)] #'Wand-mode-goto-page)
1666 (define-key map [button1] #'Wand-mode-select-region)
1667 (define-key map [(control meta ?z)] #'Wand-mode-activate-region)
1670 (define-key map [button3] #'Wand-mode-popup-menu)
1671 (define-key map [(meta button1)] #'Wand-mode-drag-image)
1672 (define-key map [(control button1)] #'Wand-mode-drag-image)
1673 (define-key map [o] #'Wand-mode-operate)
1674 (define-key map [O] #'Wand-mode-global-operations-list)
1675 (define-key map [x] #'Wand-mode-toggle-fit)
1676 (define-key map [i] #'Wand-mode-identify)
1677 (define-key map [e] #'Wand-mode-prop-editor)
1678 (define-key map [q] #'Wand-mode-quit)
1679 (define-key map [(control ?r)] #'Wand-mode-reload)
1680 (define-key map [p] #'Wand-mode-add-iptc-tag)
1683 (define-key map [+] #'Wand-mode-zoom-in)
1684 (define-key map [-] #'Wand-mode-zoom-out)
1687 (define-key map [r] #'Wand-mode-rotate-right)
1688 (define-key map [l] #'Wand-mode-rotate-left)
1690 ;; Region operations
1691 (define-key map [c] #'Wand-mode-crop)
1692 (define-key map [\.] #'Wand-mode-redeye-remove)
1694 (define-key map [:] #'Wand-mode-eval-operation)
1696 "Keymap for Wand mode.")
1703 ["Next" Wand-mode-next-image
1704 :active (Wand-next-file buffer-file-name)]
1705 ["Previous" Wand-mode-prev-image
1706 :active (Wand-next-file buffer-file-name t)]
1707 ["First" Wand-mode-first-image]
1708 ["Last" Wand-mode-last-image]
1709 ("Page" :filter Wand-menu-page-navigations)
1711 ["Image Info" Wand-mode-identify]
1712 ["Reload" Wand-mode-reload]
1713 ["Fitting" Wand-mode-toggle-fit
1714 :style toggle :selected (get image-wand 'fitting)]
1716 ["Undo" Wand-mode-undo :active operations-list]
1717 ["Redo" Wand-mode-redo :active undo-list]
1718 ["Save Image" Wand-mode-save-file]
1719 ["Save Image As" Wand-mode-write-file]
1721 ["Zoom In" Wand-mode-zoom-in]
1722 ["Zoom Out" Wand-mode-zoom-out]
1724 ["Rotate right" Wand-mode-rotate-right]
1725 ["Rotate left" Wand-mode-rotate-left]
1727 ("Region" :filter Wand-menu-region-operations)
1728 ("Transform" :filter (lambda (not-used)
1729 (Wand-menu-generate 'transform-operation)))
1730 ("Effects" :filter (lambda (not-used)
1731 (Wand-menu-generate 'effect-operation)))
1732 ("Enhance" :filter (lambda (not-used)
1733 (Wand-menu-generate 'enhance-operation)))
1734 ("F/X" :filter (lambda (not-used)
1735 (Wand-menu-generate 'f/x-operation)))
1737 ["Quit" Wand-mode-quit])
1738 "Menu for Wand display mode.")
1740 (defun Wand-menu-page-navigations (not-used)
1741 "Generate menu for page navigation."
1742 (list ["Next Page" Wand-mode-next-page
1743 :active (Wand:has-next-image image-wand)]
1744 ["Previous Page" Wand-mode-prev-page
1745 :active (Wand:has-prev-image image-wand)]
1746 ["First Page" Wand-mode-first-page
1747 :active (/= (Wand:iterator-index image-wand) 0) ]
1748 ["Last Page" Wand-mode-last-page
1749 :active (/= (Wand:iterator-index image-wand)
1750 (1- (Wand:images-num image-wand))) ]
1752 ["Goto Page" Wand-mode-goto-page
1753 :active (/= (Wand:images-num image-wand) 1)]))
1755 (defun Wand-menu-region-operations (not-used)
1756 "Generate menu for region operations."
1757 (mapcar #'(lambda (ro)
1758 (vector (get ro 'menu-name) ro :active 'preview-region))
1759 (apropos-internal "^Wand-mode-"
1762 (get c 'region-operation)
1763 (get c 'menu-name))))))
1765 (defun Wand-mode-commands-by-tag (tag)
1766 "Return list of wand command for which TAG property is set."
1767 (apropos-internal "^Wand-mode-"
1768 #'(lambda (c) (and (commandp c) (get c tag)))))
1770 (defun Wand-menu-generate (tag)
1771 "Generate menu structure for TAG commands."
1772 (mapcar #'(lambda (to)
1773 (vector (get to 'menu-name) to))
1774 (remove-if-not #'(lambda (c) (get c tag))
1775 (Wand-mode-commands-by-tag 'menu-name))))
1777 (defun Wand-mode-popup-menu (be)
1780 (popup-menu Wand-menu be))
1783 ;;{{{ Operations definitions
1785 (defmacro define-Wand-operation (name args &rest body)
1786 "Define new operation of NAME.
1787 ARGS specifies arguments to operation, first must always be wand."
1788 (let ((fsym (intern (format "Wand-op-%S" name))))
1792 (defmacro Wand-possible-for-region (wand &rest body)
1794 (let* ((iwand ,wand)
1795 (region (Wand-mode-image-region))
1796 (wand (apply #'Wand:image-region iwand region)))
1800 (Wand:image-composite iwand wand 'CopyCompositeOp
1801 (nth 2 region) (nth 3 region)))
1802 (setq preview-region nil)
1803 (Wand:delete-wand wand)))
1805 (put 'Wand-possible-for-region 'lisp-indent-function 'defun)
1807 (define-Wand-operation flip (wand)
1809 (Wand-possible-for-region wand
1810 (Wand:flip-image wand)))
1812 (define-Wand-operation flop (wand)
1814 (Wand-possible-for-region wand
1815 (Wand:flop-image wand)))
1817 (define-Wand-operation rotate (wand degree)
1818 "Rotate image by DEGREE.
1819 This is NOT lossless rotation for jpeg-like formats."
1820 (Wand-with-pixel-wand pw
1821 (setf (Wand:pixel-color pw) "black")
1822 (Wand:RotateImage wand pw (float degree))))
1824 (define-Wand-operation contrast (wand cp)
1825 "Increase/decrease contrast of the image."
1826 (Wand-possible-for-region wand
1827 (Wand:MagickContrastImage wand cp)))
1829 (define-Wand-operation normalize (wand)
1831 (Wand-possible-for-region wand
1832 (Wand:normalize-image wand)))
1834 (define-Wand-operation despeckle (wand)
1836 (Wand-possible-for-region wand
1837 (Wand:despeckle-image wand)))
1839 (define-Wand-operation enhance (wand)
1841 (Wand-possible-for-region wand
1842 (Wand:enhance-image wand)))
1844 (define-Wand-operation equalize (wand)
1846 (Wand-possible-for-region wand
1847 (Wand:equalize-image wand)))
1849 (define-Wand-operation gauss-blur (wand radius sigma)
1851 (Wand-possible-for-region wand
1852 (Wand:gaussian-blur-image wand (float radius) (float sigma))))
1854 (define-Wand-operation sharpen (wand radius sigma)
1856 (Wand-possible-for-region wand
1857 (Wand:sharpen-image wand (float radius) (float sigma))))
1859 (define-Wand-operation radial-blur (wand angle)
1861 (Wand-possible-for-region wand
1862 (Wand:radial-blur-image wand (float angle))))
1864 (define-Wand-operation negate (wand greyp)
1866 (Wand-possible-for-region wand
1867 (Wand:negate-image wand greyp)))
1869 (define-Wand-operation modulate (wand mtype minc)
1870 "Modulate the image WAND using MTYPE by MINC."
1871 (Wand-possible-for-region wand
1872 (Wand:modulate-image wand mtype (float (+ 100 minc)))))
1874 (define-Wand-operation grayscale (wand)
1876 (Wand-possible-for-region wand
1877 (Wand:SetImageColorspace wand 'GRAYColorspace)))
1879 (define-Wand-operation solarize (wand threshold)
1880 "Solarise image by THRESHOLD."
1881 (Wand-possible-for-region wand
1882 (Wand:solarize-image wand (float threshold))))
1884 (define-Wand-operation swirl (wand degrees)
1886 (Wand-possible-for-region wand
1887 (Wand:swirl-image wand (float degrees))))
1889 (define-Wand-operation oil (wand radius)
1890 "Simulate oil-painting of image."
1891 (Wand-possible-for-region wand
1892 (Wand:oil-paint-image wand (float radius))))
1894 (define-Wand-operation charcoal (wand radius sigma)
1895 "Simulate charcoal painting of image."
1896 (Wand-possible-for-region wand
1897 (Wand:charcoal-image wand (float radius) (float sigma))))
1899 (define-Wand-operation sepia-tone (wand threshold)
1900 "Apply sepia tone to image by THRESHOLD."
1901 (Wand-possible-for-region wand
1902 (Wand:sepia-tone-image wand (float threshold))))
1904 (define-Wand-operation implode (wand radius)
1905 "Implude image by RADIUS."
1906 (Wand-possible-for-region wand
1907 (Wand:implode-image wand (float radius))))
1909 (define-Wand-operation wave (wand amplitude wave-length)
1910 "Create wave effect for image with AMPLITUDE and WAVE-LENGTH."
1911 (Wand-possible-for-region wand
1912 (Wand:wave-image wand (float amplitude) (float wave-length))))
1914 (define-Wand-operation vignette (wand white black x y)
1915 "Vignette from image."
1916 (Wand-possible-for-region wand
1917 (Wand:vignette-image wand (float white) (float black) (float x) (float y))))
1919 (define-Wand-operation edge (wand radius)
1920 "Enhance the edges of the image."
1921 (Wand-possible-for-region wand
1922 (Wand:edge-image wand (float radius))))
1924 (define-Wand-operation emboss (wand radius sigma)
1925 "Emboss the image, i.e. add relief."
1926 (Wand-possible-for-region wand
1927 (Wand:emboss-image wand (float radius) (float sigma))))
1929 (define-Wand-operation reduce-noise (wand radius)
1930 "Reduce noise in the image."
1931 (Wand-possible-for-region wand
1932 (Wand:reduce-noise-image wand (float radius))))
1934 (define-Wand-operation add-noise (wand noise-type)
1935 "Add noise to image."
1936 (Wand-possible-for-region wand
1937 (Wand:add-noise-image wand noise-type)))
1939 (define-Wand-operation spread (wand radius)
1941 (Wand-possible-for-region wand
1942 (Wand:spread-image wand (float radius))))
1944 (define-Wand-operation trim (wand fuzz)
1946 (Wand-possible-for-region wand
1947 (Wand:trim-image wand (float fuzz))))
1949 (define-Wand-operation raise (wand raise)
1951 (Wand-possible-for-region wand
1952 (Wand:raise-image wand raise)))
1954 (define-Wand-operation crop (wand region)
1955 "Crop image to REGION."
1956 (apply #'Wand:crop-image wand region)
1957 (Wand:reset-image-page wand))
1959 (define-Wand-operation chop (wand region)
1960 "Chop REGION in the image."
1961 (apply #'Wand:chop-image wand region))
1963 (defun Wand:get-image-rgb-pixels (wand x y w h)
1964 "Extract RGB pixels from WAND."
1965 (let ((target (make-ffi-object 'c-data (* w h 3))))
1966 (when (Wand:MagickGetImagePixels
1967 wand x y w h "RGB" 'char-pixel target)
1968 (Wand:pixels-extract-colors (ffi-get target) 3))))
1970 (defun Wand:get-rgb-pixel-at (wand x y)
1971 "Return WAND's RGB pixel at X, Y."
1972 (car (Wand:get-image-rgb-pixels wand x y 1 1)))
1974 (defun Wand-fix-red-pixels (pixels)
1975 "Simple red PIXELS fixator.
1976 Normalize pixel color if it is too 'red'."
1977 (let* ((rchan '(0.1 0.6 0.3))
1978 (gchan '(0.0 1.0 0.0))
1979 (bchan '(0.0 0.0 1.0))
1980 (rnorm (/ 1.0 (apply #'+ rchan)))
1981 (gnorm (/ 1.0 (apply #'+ gchan)))
1982 (bnorm (/ 1.0 (apply #'+ bchan))))
1983 (flet ((normalize (chan norm r g b)
1984 (min 255 (int (* norm (+ (* (first chan) r)
1986 (* (third chan) b)))))))
1987 (mapcar #'(lambda (pixel-value)
1988 (multiple-value-bind (r g b) pixel-value
1989 (if (>= r (* Wand-mode-redeye-threshold g))
1990 (list (normalize rchan rnorm r g b)
1991 (normalize gchan gnorm r g b)
1992 (normalize bchan bnorm r g b))
1996 (defun Wand-mode-redeye-blur-radius (w h)
1997 "Return apropriate blur radius for region of width W and height H.
1998 It should not be too large for large regions, and it should not be
1999 too small for small regions."
2000 (1- (sqrt (sqrt (sqrt (sqrt (* w h)))))))
2002 (define-Wand-operation redeye-remove (wand region)
2003 "Remove redeye in the REGION."
2004 (multiple-value-bind (w h x y) region
2006 ;; Consitute new wand with fixed red pixels
2007 (Wand:MagickConstituteImage
2008 cw w h "RGB" 'char-pixel
2009 (let ((stor (make-ffi-object 'c-data (* w h 3))))
2010 (ffi-set stor (Wand:pixels-arrange-colors
2011 (Wand-fix-red-pixels
2012 (Wand:get-image-rgb-pixels wand x y w h))))
2015 ;; Limit blur effect to ellipse at the center of REGION by
2016 ;; setting clip mask
2017 (let ((mask (Wand:copy-wand cw)))
2020 (Wand-with-drawing-wand dw
2021 (Wand-with-pixel-wand pw
2022 (setf (Wand:pixel-color pw) "white")
2023 (setf (Wand:draw-fill-color dw) pw)
2024 (Wand:draw-color dw 0.0 0.0 'ResetMethod))
2025 (Wand-with-pixel-wand pw
2026 (setf (Wand:pixel-color pw) "black")
2027 (setf (Wand:draw-fill-color dw) pw))
2029 dw (/ w 2.0) (/ h 2.0) (/ w 2.0) (/ h 2.0) 0.0 360.0)
2030 (Wand:MagickDrawImage mask dw))
2031 (setf (Wand:clip-mask cw) mask))
2032 (Wand:delete-wand mask)))
2034 (Wand:gaussian-blur-image
2035 cw 0.0 (Wand-mode-redeye-blur-radius w h))
2036 (setf (Wand:clip-mask cw) nil)
2038 ;; Finally copy blured image to WAND
2039 (Wand:image-composite wand cw 'CopyCompositeOp x y))))
2041 (define-Wand-operation zoom (wand outp factor)
2042 (let ((nw (funcall (if outp #'/ #'*)
2043 (Wand:image-width wand) (float factor)))
2044 (nh (funcall (if outp #'/ #'*)
2045 (Wand:image-height wand) (float factor))))
2046 (Wand:scale-image wand (round nw) (round nh))))
2048 (define-Wand-operation sample (wand width height)
2049 (Wand:scale-image wand width height))
2051 (defmacro Wand-make-scaler (filter-type blur)
2052 "Create resize function, suitable with `Wand:fit-resize'.
2053 FILTER-TYPE and BLUR specifies smothing applied after resize.
2054 FILTER-TYPE is one of: :PointFilter, :BoxFilter, :TriangleFilter,
2055 :HermiteFilter, :HanningFilter, :HammingFilter, :BlackmanFilter,
2056 :GaussianFilter, :QuadraticFilter, :CubicFilter, :CatromFilter,
2057 :MitchellFilter, :LanczosFilter, :BesselFilter, :SincFilter,
2058 :KaiserFilter, :WelshFilter, :ParzenFilter, :LagrangeFilter,
2059 :BohmanFilter, :BartlettFilter, :SentinelFilter.
2060 BLUR is float, 0.25 for insane pixels, > 2.0 for excessively smoth."
2062 (Wand:resize-image iw x y ,filter-type (float ,blur))))
2064 (define-Wand-operation fit-size (wand width height)
2065 (Wand:fit-size wand width height Wand-mode-scaler t))
2067 (define-Wand-operation liquid-rescale (wand width height)
2068 (Wand:liquid-rescale wand width height 0.0 0.0))
2071 ;;{{{ Operations list functions
2073 (defun Wand-operation-lookup (opname)
2074 (intern (format "Wand-op-%S" opname)))
2076 (defun Wand-operation-apply (operation wand &rest args)
2077 "Apply OPERATION to WAND using addition arguments ARGS."
2078 (setq operations-list
2079 (append operations-list (list (cons operation args))))
2080 (setq undo-list nil) ; Reset undo
2081 (apply (Wand-operation-lookup operation) wand args))
2083 (defun Wand-operation-list-apply (wand &optional operations)
2084 "Apply all operations in OPERATIONS list."
2085 (dolist (op (or operations operations-list))
2086 (apply (Wand-operation-lookup (car op))
2090 ;;{{{ Helper functions
2092 (defun Wand-mode-image-region ()
2093 "Return region in real image, according to `preview-region'."
2094 (let ((off-x (get preview-wand 'offset-x))
2095 (off-y (get preview-wand 'offset-y))
2096 (xcoeff (// (Wand:image-width image-wand)
2097 (Wand:image-width preview-wand)))
2098 (ycoeff (// (Wand:image-height image-wand)
2099 (Wand:image-height preview-wand))))
2100 (mapcar #'round (list (* (nth 0 preview-region) xcoeff)
2101 (* (nth 1 preview-region) ycoeff)
2102 (* (+ (nth 2 preview-region) off-x) xcoeff)
2103 (* (+ (nth 3 preview-region) off-y) ycoeff)))))
2105 (defun Wand-mode-file-info ()
2106 "Return info about file as a string."
2107 (declare (special off-x))
2108 (declare (special off-y))
2109 (concat "File: " (file-name-nondirectory buffer-file-name) ", "
2110 (Wand:image-format image-wand)
2111 " " (format "%dx%d" (Wand:image-width image-wand)
2112 (Wand:image-height image-wand))
2113 (if (> (Wand:images-num image-wand) 1)
2114 (format ", Page: %d/%d" (1+ (Wand:iterator-index image-wand))
2115 (Wand:images-num image-wand))
2117 ;; Print offset info
2118 (if (and preview-wand (boundp 'off-x) (boundp 'off-y)
2119 (or (positivep off-x) (positivep off-y)))
2120 (format ", Offset: +%d+%d" off-x off-y)
2122 ;; Print region info
2124 (apply #'format ", Region: %dx%d+%d+%d"
2125 (Wand-mode-image-region))
2128 (defun Wand-mode-iptc-split-keywords (tag-value)
2129 (mapcar #'(lambda (kw) (cons 'keyword kw))
2131 (split-string tag-value "\\(, \\|,\\)"))))
2133 (defun Wand-mode-iptc-from-widgets (widgets)
2134 "Return profile made up from WIDGETS info."
2137 (let ((iptc-tag (widget-get widget :iptc-tag))
2138 (tag-value (widget-get widget :value)))
2139 (cond ((string= tag-value "") nil)
2140 ((eq iptc-tag 'keywords)
2141 ;; Special case for keywords
2142 (Wand-mode-iptc-split-keywords tag-value))
2143 (t (list (cons iptc-tag tag-value))))))
2146 (defun Wand-mode-iptc-notify (wid &rest args)
2147 "Called when some IPTC info changed."
2148 (Wand:image-save-iptc-profile
2149 image-wand (Wand-mode-iptc-from-widgets (cons wid widget-field-list)))
2150 (Wand-mode-update-info))
2152 (defun Wand-mode-insert-iptc-tags ()
2153 "Insert iptc tags info."
2154 (kill-local-variable 'widget-global-map)
2155 (kill-local-variable 'widget-field-new)
2156 (kill-local-variable 'widget-field-last)
2157 (kill-local-variable 'widget-field-was)
2158 (kill-local-variable 'widget-field-list)
2160 (let* ((iptc (Wand:image-profile-iptc image-wand))
2161 (cpt (cdr (assq 'caption iptc)))
2162 (kws (mapcar #'cdr (remove-if-not
2163 #'(lambda (e) (eq 'keyword (car e)))
2166 (widget-create 'editable-field
2168 :format "IPTC Caption: %v"
2170 :notify #'Wand-mode-iptc-notify
2173 (widget-create 'editable-field
2174 :format "IPTC Keywords: %v"
2177 :notify #'Wand-mode-iptc-notify
2178 (mapconcat #'identity kws ", ")))
2181 (defun Wand-mode-add-iptc-tag (tag value)
2182 "Add TAG to ITPC profile."
2183 (interactive (list (completing-read
2184 "IPTC Tag: " '(("caption") ("keywords")) nil t)
2185 (read-string "ITPC Tag value: ")))
2186 (let ((tags-val (cond ((string= tag "caption")
2187 (list (cons 'caption value)))
2188 ((string= tag "keywords")
2189 (Wand-mode-iptc-split-keywords value))
2190 (t (error "Invalid IPTC tag")))))
2191 (Wand:image-save-iptc-profile
2192 image-wand (nconc (Wand-mode-iptc-from-widgets widget-field-list)
2194 (Wand-mode-update-info)))
2196 (defun Wand-mode-insert-info ()
2197 "Insert some file informations."
2198 (when Wand-mode-show-fileinfo
2199 (insert (Wand-mode-file-info) "\n"))
2200 (when Wand-mode-show-iptc-info
2201 (Wand-mode-insert-iptc-tags))
2203 ;; XXX iptc may set those below again
2204 (let ((inhibit-read-only t)
2205 (before-change-functions nil)
2206 (after-change-functions nil))
2208 (when (and Wand-mode-show-operations)
2209 (when operations-list
2210 (insert (format "Operations: %S" operations-list) "\n"))
2211 (when Wand-global-operations-list
2212 (insert (format "Global operations: %S"
2213 Wand-global-operations-list) "\n")))
2215 ;; Info about pickup color
2216 (when (boundp 'pickup-color)
2217 (let* ((cf (make-face (gensym "dcolor-") nil t))
2218 (place (car pickup-color))
2219 (color (cdr pickup-color))
2220 (fcol (apply #'format "#%02x%02x%02x" color)))
2221 (set-face-background cf fcol)
2222 (insert (format "Color: +%d+%d " (car place) (cdr place)))
2223 (insert-face " " cf)
2224 (insert (format " %s R:%d, G:%d, B:%d\n" fcol
2225 (car color) (cadr color) (caddr color)))))))
2227 (defun Wand-mode-update-info ()
2228 "Only update info region."
2229 (let ((inhibit-read-only t)
2230 before-change-functions
2231 after-change-functions)
2232 (mapc 'widget-delete widget-field-list)
2234 (goto-char (point-min))
2235 (delete-region (point-at-bol)
2237 (goto-char (point-max))
2239 (Wand-mode-insert-info))
2240 (set-buffer-modified-p nil)))
2242 (defun Wand-mode-update-file-info ()
2244 (when Wand-mode-show-fileinfo
2245 (let ((inhibit-read-only t)
2246 before-change-functions
2247 after-change-functions)
2249 (goto-char (point-min))
2250 (delete-region (point-at-bol) (point-at-eol))
2251 (insert (Wand-mode-file-info))))
2252 (set-buffer-modified-p nil)))
2254 (defun Wand-mode-preview-with-region ()
2255 "Return highlighted version of `preview-wand' in case region is selected."
2256 (when preview-region
2257 (multiple-value-bind (w h x y) preview-region
2258 ;; Take into account current offset
2259 (incf x (get preview-wand 'offset-x))
2260 (incf y (get preview-wand 'offset-y))
2261 (Wand-with-drawing-wand dw
2262 (Wand-with-pixel-wand pw
2263 (setf (Wand:pixel-color pw) Wand-mode-region-outline-color)
2264 (Wand:DrawSetStrokeColor dw pw))
2265 (Wand-with-pixel-wand pw
2266 (setf (Wand:pixel-color pw) Wand-mode-region-fill-color)
2267 (setf (Wand:draw-fill-color dw) pw))
2268 (setf (Wand:draw-stroke-width dw) Wand-mode-region-outline-width
2269 (Wand:draw-stroke-opacity dw) Wand-mode-region-outline-opacity
2270 (Wand:draw-fill-opacity dw) Wand-mode-region-fill-opacity)
2271 (Wand:draw-lines dw (list (cons x y) (cons (+ x w) y)
2272 (cons (+ x w) (+ y h)) (cons x (+ y h))
2274 (let ((nw (Wand:copy-wand preview-wand)))
2275 (put nw 'offset-x (get preview-wand 'offset-x))
2276 (put nw 'offset-y (get preview-wand 'offset-y))
2277 (Wand:MagickDrawImage nw dw)
2280 (defun Wand-mode-insert-preview ()
2281 "Display wand W at the point."
2282 ;; NOTE: if size not changed, then keep offset-x and offset-y
2284 (let ((saved-w (and preview-wand (Wand:image-width preview-wand)))
2285 (saved-h (and preview-wand (Wand:image-height preview-wand)))
2286 (off-x (or (get preview-wand 'offset-x) 0))
2287 (off-y (or (get preview-wand 'offset-y) 0)))
2288 ;; Delete old preview and create new one
2289 (when preview-wand (Wand:delete-wand preview-wand))
2290 (setq preview-wand (Wand:get-image image-wand))
2292 ;; Rescale preview to fit the window
2293 (let ((scale-h (- (window-text-area-pixel-height)
2294 ;; TODO: we need something to do to count pixels
2295 ;; used by displayed text. Below constructions
2296 ;; does not work for some reason --lg
2297 (if t ;(string= (buffer-substring) "")
2299 (window-displayed-text-pixel-height))))
2300 (scale-w (window-text-area-pixel-width)))
2301 (when (and (get image-wand 'fitting)
2302 (Wand:fit-size preview-wand scale-w scale-h))
2303 (message "Rescale to %dx%d"
2304 (Wand:image-width preview-wand)
2305 (Wand:image-height preview-wand))))
2307 ;; Set offset properties
2308 (if (and (eq saved-w (Wand:image-width preview-wand))
2309 (eq saved-h (Wand:image-height preview-wand)))
2310 (progn (put preview-wand 'offset-x off-x)
2311 (put preview-wand 'offset-y off-y))
2312 (put preview-wand 'offset-x 0)
2313 (put preview-wand 'offset-y 0))
2315 ;; Hackery to insert invisible char, so widget-delete won't affect
2316 ;; preview-glyph visibility
2317 (let ((ext (make-extent (point) (progn (insert " ") (point)))))
2318 (set-extent-property ext 'invisible t)
2319 (set-extent-property ext 'start-open t))
2321 (let ((pwr (Wand-mode-preview-with-region)))
2324 (set-extent-end-glyph
2325 preview-extent (Wand-mode-preview-glyph (or pwr preview-wand)))
2326 (set-extent-endpoints
2327 preview-extent (point) (point) (current-buffer)))
2328 (when pwr (Wand:delete-wand pwr))))))
2330 (defun Wand-redisplay ()
2331 (let ((inhibit-read-only t)
2332 before-change-functions
2333 after-change-functions)
2335 (Wand-mode-insert-info)
2336 (Wand-mode-insert-preview)
2337 ;;(when Wand-interactive-resize
2338 ;; (Wand-mode-insert-resize-glyphs))
2339 (goto-char (point-min)))
2340 (set-buffer-modified-p nil))
2343 (defun Wand-display-noselect (file)
2344 (let* ((bn (format "*Wand: %s*" (file-name-nondirectory file)))
2345 (buf (if (eq major-mode 'Wand-mode)
2346 ;; Use current buffer
2350 (get-buffer-create bn))))
2351 (with-current-buffer buf
2352 (unless (eq major-mode 'Wand-mode)
2353 ;; Initialise local variables
2354 (kill-all-local-variables)
2355 (make-variable-buffer-local 'image-wand)
2356 (make-variable-buffer-local 'preview-wand)
2357 (make-variable-buffer-local 'preview-region)
2358 (make-variable-buffer-local 'preview-extent)
2359 (make-variable-buffer-local 'operations-list)
2360 (make-variable-buffer-local 'undo-list)
2361 (make-variable-buffer-local 'kill-buffer-hook)
2362 (setq operations-list nil)
2363 (setq undo-list nil)
2364 (setq preview-wand nil)
2365 (setq preview-extent (make-extent 0 0 ""))
2366 (setq image-wand (Wand:make-wand))
2367 (put image-wand 'fitting Wand-mode-auto-fit)
2369 (use-local-map Wand-mode-map)
2370 (setq mode-name "Wand")
2371 (setq major-mode 'Wand-mode)
2372 (setq buffer-read-only t)
2374 (when (featurep 'menubar)
2375 (set-buffer-menubar current-menubar)
2376 (add-submenu '() Wand-menu)
2377 (setq mode-popup-menu Wand-menu))
2378 (add-hook 'kill-buffer-hook 'Wand-mode-cleanup))
2381 (Wand:delete-wand preview-wand))
2382 (setq preview-wand nil)
2383 (setq preview-region nil)
2384 (setq operations-list nil)
2385 (setq undo-list nil)
2386 (Wand:clear-wand image-wand)
2387 ;; Fix buffer-file-name in case of viewing directory
2388 (when (file-directory-p file)
2389 (setq file (or (Wand-next-file (concat file "/.")) file)))
2390 (setq buffer-file-name file)
2391 (setq default-directory (file-name-directory file))
2393 (unless (Wand:read-image image-wand file)
2394 (kill-buffer (current-buffer))
2395 (error "Can't read file %s" file))
2396 (when Wand-mode-auto-rotate
2397 (Wand:correct-orientation image-wand))
2399 ;; Apply operations in case global operations list is used
2400 (mapc #'(lambda (op)
2401 (apply #'Wand-operation-apply
2402 (car op) image-wand (cdr op)))
2403 Wand-global-operations-list)
2408 (run-hooks 'Wand-mode-hook))
2412 (defun Wand-display (file)
2413 (interactive "fImage file: ")
2414 (switch-to-buffer (Wand-display-noselect file) t))
2417 "Start `Wand-display' on filename associated with current buffer.
2421 (Wand-display (buffer-file-name)))
2424 (defun Wand-find-file-enable ()
2425 "Enable `find-file' to use `Wand-display' for supported filetypes."
2426 (push '(Wand-file-supported-for-read-p . Wand-display-noselect)
2427 find-file-magic-files-alist))
2429 (defun Wand-mode-cleanup ()
2430 "Cleanup when wand buffer is killed."
2431 (when (extentp preview-extent)
2432 (delete-extent preview-extent))
2434 (Wand:delete-wand preview-wand))
2435 (Wand:delete-wand image-wand))
2437 (defun Wand-mode-quit ()
2438 "Quit Wand display mode."
2440 (kill-buffer (current-buffer)))
2442 (defun Wand-mode-reload ()
2443 "Reload and redisplay image file."
2445 (Wand-display buffer-file-name))
2447 (defun Wand-mode-identify ()
2448 "Show info about image."
2450 (let ((iw image-wand))
2451 (with-displaying-help-buffer
2453 (set-buffer standard-output)
2454 (insert (Wand:identify-image iw)))
2457 (defun Wand-mode-operations-table ()
2458 "Return completion table for Wand operations."
2459 (mapcar #'(lambda (to)
2460 (cons (downcase (get to 'menu-name)) to))
2461 (Wand-mode-commands-by-tag 'menu-name)))
2463 (defun Wand-mode-operate (op-name)
2465 (interactive (list (completing-read
2466 "Operation: " (Wand-mode-operations-table)
2468 (let ((op (assoc op-name (Wand-mode-operations-table))))
2469 (call-interactively (cdr op))))
2471 (defun Wand-format-supported-for-read-p (format)
2472 "Return non-nil if Wand can read files in FORMAT."
2473 (let ((fi (Wand:GetMagickInfo
2474 format (ffi-address-of
2475 (make-ffi-object 'MagickExceptionInfo)))))
2476 (and (not (ffi-null-p fi))
2477 (not (ffi-null-p (MagickInfo->decoder fi))))))
2479 (defun Wand-format-supported-for-write-p (format)
2480 "Return non-nil if Wand can write files in FORMAT."
2481 (let ((fi (Wand:GetMagickInfo
2482 format (ffi-address-of
2483 (make-ffi-object 'MagickExceptionInfo)))))
2484 (and (not (ffi-null-p fi))
2485 (not (ffi-null-p (MagickInfo->encoder fi))))))
2487 (defcustom Wand-file-extensions-unsupported
2488 '("a" "b" "c" "g" "h" "o" "k" "m" "r" "x" "y" "txt" "text" "pm")
2489 "List of file extensions that are not intented to be opened by Wand."
2490 :type '(list string)
2494 (defun Wand-file-supported-for-read-p (file)
2495 "Return non-nil if Wand can decode FILE."
2496 ;; Try by extension first, then try heuristic method using
2497 ;; `magic:file-type'
2498 (let ((ext (file-name-extension file)))
2499 (or (and ext (not (member (downcase ext) Wand-file-extensions-unsupported))
2500 (Wand-format-supported-for-read-p ext))
2501 (multiple-value-bind (itype imagetext)
2502 (split-string (magic:file-type file) " ")
2504 (string= (downcase imagetext) "image")
2505 (Wand-format-supported-for-read-p itype))))))
2507 (defun Wand-formats-list (fmt-regexp &optional mode)
2508 "Return name of supportef formats that matches FMT-REGEXP.
2509 Optionally you can specify MODE:
2510 'read - Only formats that we can read
2511 'write - Only formats that we can write
2512 'read-write - Formats that we can and read and write
2513 'any or nil - Any format (default)."
2514 (let* ((excp (make-ffi-object 'MagickExceptionInfo))
2515 (num (make-ffi-object 'unsigned-long))
2516 (fil (Wand:GetMagickInfoList
2517 fmt-regexp (ffi-address-of num) (ffi-address-of excp))))
2518 (unless (ffi-null-p fil)
2520 (loop for n from 0 below (ffi-get num)
2522 do (setq minfo (ffi-aref fil n))
2523 if (ecase (or mode 'any)
2524 (read (not (ffi-null-p (MagickInfo->decoder minfo))))
2525 (write (not (ffi-null-p (MagickInfo->encoder minfo))))
2527 (and (not (ffi-null-p (MagickInfo->decoder minfo)))
2528 (not (ffi-null-p (MagickInfo->encoder minfo)))))
2530 collect (ffi-get (MagickInfo->name minfo) :type 'c-string))
2531 (Wand:RelinquishMemory fil)))))
2534 ;;{{{ File navigation commands
2536 (defun Wand-next-file (curfile &optional reverse-order)
2537 "Return next (to CURFILE) image file in the directory.
2538 If REVERSE-ORDER is specified, then return previous file."
2539 (let* ((dir (file-name-directory curfile))
2540 (fn (file-name-nondirectory curfile))
2541 (dfiles (directory-files dir nil nil 'sorted-list t))
2542 (nfiles (cdr (member fn (if reverse-order (nreverse dfiles) dfiles)))))
2543 (while (and nfiles (not (Wand-file-supported-for-read-p
2544 (concat dir (car nfiles)))))
2545 (setq nfiles (cdr nfiles)))
2546 (and nfiles (concat dir (car nfiles)))))
2548 (defun Wand-mode-next-image (&optional reverse)
2551 (let ((nf (Wand-next-file buffer-file-name reverse)))
2553 (error (format "No %s file" (if reverse "previous" "next"))))
2556 (defun Wand-mode-prev-image ()
2557 "View previous image."
2559 (Wand-mode-next-image t))
2561 (defun Wand-mode-last-image (&optional reverse)
2562 "View last image in the directory."
2564 (let ((rf buffer-file-name)
2565 (ff (Wand-next-file buffer-file-name reverse)))
2568 (setq ff (Wand-next-file rf reverse)))
2571 (defun Wand-mode-first-image ()
2572 "View very first image in the directory."
2574 (Wand-mode-last-image t))
2577 ;;{{{ Pages navigation commands
2579 (defun Wand-mode-next-page ()
2580 "Display next image in image chain."
2582 (unless (Wand:has-next-image image-wand)
2583 (error "No next image in chain"))
2584 (Wand:next-image image-wand)
2587 (defun Wand-mode-prev-page ()
2588 "Display previous image in image chain."
2590 (unless (Wand:has-prev-image image-wand)
2591 (error "No previous image in chain"))
2592 (Wand:prev-image image-wand)
2595 (defun Wand-mode-first-page ()
2596 "Display first image in image chain."
2598 (Wand:set-first-iterator image-wand)
2601 (defun Wand-mode-last-page ()
2602 "Display last image in image chain."
2604 (Wand:set-last-iterator image-wand)
2607 (defun Wand-mode-goto-page (n)
2608 "Display last image in image chain."
2610 (list (if (numberp current-prefix-arg)
2612 (read-number "Goto page: " t))))
2613 ;; Internally images in chain counts from 0
2614 (unless (setf (Wand:iterator-index image-wand) (1- n))
2615 (error "No such page" n))
2620 ;;{{{ Transform operations
2622 (defun Wand-mode-flip ()
2625 (Wand-operation-apply 'flip image-wand)
2627 (put 'Wand-mode-flip 'transform-operation t)
2628 (put 'Wand-mode-flip 'menu-name "Flip")
2630 (defun Wand-mode-flop ()
2633 (Wand-operation-apply 'flop image-wand)
2635 (put 'Wand-mode-flop 'transform-operation t)
2636 (put 'Wand-mode-flop 'menu-name "Flop")
2638 (defun Wand-mode-trim (fuzz)
2640 (interactive (list (read-number "Fuzz [0%]: " nil "0")))
2641 (Wand-operation-apply 'trim image-wand (/ fuzz 100.0))
2643 (put 'Wand-mode-trim 'transform-operation t)
2644 (put 'Wand-mode-trim 'menu-name "Trim Edges")
2646 (defun Wand-mode-rotate (arg)
2647 "Rotate image to ARG degrees.
2648 If ARG is positive then rotate in clockwise direction.
2649 If negative then to the opposite."
2650 (interactive "nDegrees: ")
2651 (Wand-operation-apply 'rotate image-wand arg)
2653 (put 'Wand-mode-rotate 'transform-operation t)
2654 (put 'Wand-mode-rotate 'menu-name "Rotate")
2656 (defun Wand-mode-rotate-left (arg)
2657 "Rotate image to the left.
2658 If ARG is specified then rotate on ARG degree."
2659 (interactive (list (or (and current-prefix-arg
2660 (prefix-numeric-value current-prefix-arg))
2662 (Wand-mode-rotate (- arg)))
2664 (defun Wand-mode-rotate-right (arg)
2665 "Rotate image to the right.
2666 If ARG is specified then rotate on ARG degree."
2667 (interactive (list (or (and current-prefix-arg
2668 (prefix-numeric-value current-prefix-arg))
2670 (Wand-mode-rotate arg))
2672 (defun Wand-mode-raise (arg)
2673 "Create button-like 3d effect."
2675 (Wand-operation-apply 'raise image-wand arg)
2677 (put 'Wand-mode-raise 'transform-operation t)
2678 (put 'Wand-mode-raise 'menu-name "3D Button Effect")
2681 ;;{{{ Effect operations
2683 (defun Wand-mode-radial-blur (arg)
2684 "Blur the image radially by ARG degree."
2685 (interactive (list (read-number "Blur radius [2.0]: " nil "2.0")))
2686 (Wand-operation-apply 'radial-blur image-wand arg)
2688 (put 'Wand-mode-radial-blur 'effect-operation t)
2689 (put 'Wand-mode-radial-blur 'menu-name "Radial Blur")
2691 (defun Wand-mode-sharpen (radius sigma)
2692 "Sharpen image with by RADIUS and SIGMA."
2693 (interactive (list (read-number "Radius [1]: " nil "1")
2694 (read-number (format "Sigma [%d]: " Wand-mode-sigma)
2695 nil (number-to-string Wand-mode-sigma))))
2696 (Wand-operation-apply 'sharpen image-wand radius sigma)
2698 (put 'Wand-mode-sharpen 'effect-operation t)
2699 (put 'Wand-mode-sharpen 'menu-name "Sharpen")
2701 (defun Wand-mode-gaussian-blur (radius sigma)
2702 "Apply gaussian blur of RADIUS and SIGMA to the image."
2703 (interactive (list (read-number "Radius [1]: " nil "1")
2704 (read-number (format "Sigma [%d]: " Wand-mode-sigma)
2705 nil (number-to-string Wand-mode-sigma))))
2706 (Wand-operation-apply 'gauss-blur image-wand radius sigma)
2708 (put 'Wand-mode-gaussian-blur 'effect-operation t)
2709 (put 'Wand-mode-gaussian-blur 'menu-name "Gaussian Blur")
2711 (defun Wand-mode-despeckle ()
2714 (Wand-operation-apply 'despeckle image-wand)
2716 (put 'Wand-mode-despeckle 'effect-operation t)
2717 (put 'Wand-mode-despeckle 'menu-name "Despeckle")
2719 (defun Wand-mode-edge (radius)
2720 "Enhance edges of the image by RADIUS.
2722 (interactive (list (read-number "Radius [1.0]: " nil "1.0")))
2723 (Wand-operation-apply 'edge image-wand radius)
2725 (put 'Wand-mode-edge 'effect-operation t)
2726 (put 'Wand-mode-edge 'menu-name "Edge Detect")
2728 (defun Wand-mode-emboss (radius sigma)
2729 "Emboss the image with RADIUS and SIGMA."
2730 (interactive (list (read-number "Radius [1.0]: " nil "1.0")
2731 (read-number (format "Sigma [%d]: " Wand-mode-sigma)
2732 nil (number-to-string Wand-mode-sigma))))
2733 (Wand-operation-apply 'emboss image-wand radius sigma)
2735 (put 'Wand-mode-emboss 'effect-operation t)
2736 (put 'Wand-mode-emboss 'menu-name "Emboss")
2738 (defun Wand-mode-reduce-noise (arg)
2739 "Reduce the noise with ARG radius.
2742 (Wand-operation-apply 'reduce-noise image-wand arg)
2744 (put 'Wand-mode-reduce-noise 'effect-operation t)
2745 (put 'Wand-mode-reduce-noise 'menu-name "Reduce Noise")
2747 (defun Wand-mode-add-noise (noise-type)
2748 "Add noise of NOISE-TYPE."
2750 (list (completing-read "Noise type [PoissonNoise]: "
2751 (mapcar #'(lambda (ev)
2752 (cons (symbol-name (car ev)) nil))
2753 (ffi-enum-values 'MagickNoiseType))
2754 nil t nil nil "PoissonNoise")))
2755 (let ((nt (intern noise-type)))
2756 (Wand-operation-apply 'add-noise image-wand nt))
2758 (put 'Wand-mode-add-noise 'effect-operation t)
2759 (put 'Wand-mode-add-noise 'menu-name "Add Noise")
2761 (defun Wand-mode-spread (radius)
2762 "Add noise of NOISE-TYPE."
2763 (interactive (list (read-number "Spread radius [1.0]: " nil "1.0")))
2764 (Wand-operation-apply 'spread image-wand radius)
2766 (put 'Wand-mode-spread 'effect-operation t)
2767 (put 'Wand-mode-spread 'menu-name "Spread")
2770 ;;{{{ Enhance operations
2772 (defun Wand-mode-contrast (ctype)
2773 "Increase or decrease contrast.
2774 By default increase."
2775 (interactive (list (completing-read
2776 "Contrast [increase]: " '(("increase") ("decrease"))
2777 nil t nil nil "increase")))
2778 (Wand-operation-apply 'contrast image-wand (string= ctype "increase"))
2780 (put 'Wand-mode-contrast 'enhance-operation t)
2781 (put 'Wand-mode-contrast 'menu-name "Contrast")
2783 (defun Wand-mode-normalize ()
2786 (Wand-operation-apply 'normalize image-wand)
2788 (put 'Wand-mode-normalize 'enhance-operation t)
2789 (put 'Wand-mode-normalize 'menu-name "Normalize")
2791 (defun Wand-mode-enhance ()
2794 (Wand-operation-apply 'enhance image-wand)
2796 (put 'Wand-mode-enhance 'enhance-operation t)
2797 (put 'Wand-mode-enhance 'menu-name "Enhance")
2799 (defun Wand-mode-equalize ()
2802 (Wand-operation-apply 'equalize image-wand)
2804 (put 'Wand-mode-equalize 'enhance-operation t)
2805 (put 'Wand-mode-equalize 'menu-name "Equalize")
2807 (defun Wand-mode-negate (arg)
2809 If prefix ARG is specified then negate by grey."
2811 (Wand-operation-apply 'negate image-wand arg)
2813 (put 'Wand-mode-negate 'enhance-operation t)
2814 (put 'Wand-mode-negate 'menu-name "Negate")
2816 (defun Wand-mode-grayscale ()
2817 "Convert image to grayscale colorspace."
2819 (Wand-operation-apply 'grayscale image-wand)
2821 (put 'Wand-mode-grayscale 'enhance-operation t)
2822 (put 'Wand-mode-grayscale 'menu-name "Grayscale")
2824 (defun Wand-mode-modulate (type inc)
2825 "Modulate image's brightness, saturation or hue."
2826 (interactive (let* ((tp (completing-read
2827 "Modulate [saturation]: "
2828 '(("brightness") ("saturation") ("hue"))
2829 nil t nil nil "saturation"))
2830 (tinc (read-number (format "Increase %s [25%%]: " tp)
2832 (list (cond ((string= tp "brightness") :brightness)
2833 ((string= tp "hue") :hue)
2834 (t :saturation)) tinc)))
2835 (Wand-operation-apply 'modulate image-wand type inc)
2837 (put 'Wand-mode-modulate 'enhance-operation t)
2838 (put 'Wand-mode-modulate 'menu-name "Modulate")
2841 ;;{{{ F/X operations
2843 (defun Wand-mode-solarize (sf)
2844 "Solarise image with solarize factor SF."
2845 (interactive (list (read-number "Solarize factor [50%]: " nil "50")))
2846 (Wand-operation-apply 'solarize image-wand
2847 (* (Wand:quantum-range) (/ sf 100.0)))
2849 (put 'Wand-mode-solarize 'f/x-operation t)
2850 (put 'Wand-mode-solarize 'menu-name "Solarize")
2852 (defun Wand-mode-swirl (degrees)
2853 "Swirl the image by DEGREES."
2854 (interactive (list (read-number "Degrees [90]: " nil "90")))
2855 (Wand-operation-apply 'swirl image-wand degrees)
2857 (put 'Wand-mode-swirl 'f/x-operation t)
2858 (put 'Wand-mode-swirl 'menu-name "Swirl")
2860 (defun Wand-mode-oil-paint (radius)
2861 "Simulate oil painting with RADIUS for the image.
2862 Default radius is 3."
2863 (interactive (list (read-number "Radius [3.0]: " nil "3.0")))
2864 (Wand-operation-apply 'oil image-wand radius)
2866 (put 'Wand-mode-oil-paint 'f/x-operation t)
2867 (put 'Wand-mode-oil-paint 'menu-name "Oil Paint")
2869 (defun Wand-mode-charcoal (radius sigma)
2870 "Simulate charcoal painting for the image.
2871 If prefix ARG is specified then radius for charcoal painting is ARG.
2873 (interactive (list (read-number "Radius [1.0]: " nil "1.0")
2874 (read-number "Sigma [1.0]: " nil "1.0")))
2875 (Wand-operation-apply 'charcoal image-wand radius sigma)
2877 (put 'Wand-mode-charcoal 'f/x-operation t)
2878 (put 'Wand-mode-charcoal 'menu-name "Charcoal Draw")
2880 (defun Wand-mode-sepia-tone (threshold)
2881 "Apply sepia tone to image by THRESHOLD."
2882 (interactive (list (read-number "Threshold [80%]: " nil "80")))
2883 (Wand-operation-apply 'sepia-tone image-wand
2884 (* (Wand:quantum-range) (/ threshold 100.0)))
2886 (put 'Wand-mode-sepia-tone 'f/x-operation t)
2887 (put 'Wand-mode-sepia-tone 'menu-name "Sepia Tone")
2889 (defun Wand-mode-implode (radius)
2890 "Implode image by RADIUS.
2891 RADIUS range is [-1.0, 1.0]."
2892 (interactive (list (read-number "Radius [0.3]: " nil "0.3")))
2893 (Wand-operation-apply 'implode image-wand radius)
2895 (put 'Wand-mode-implode 'f/x-operation t)
2896 (put 'Wand-mode-implode 'menu-name "Implode")
2898 (defun Wand-mode-vignette (bw)
2899 "Create vignette using image."
2900 (interactive (list (read-number "Black/White [10]: " nil "10")))
2901 (Wand-operation-apply 'vignette image-wand bw bw 0 0)
2903 (put 'Wand-mode-vignette 'f/x-operation t)
2904 (put 'Wand-mode-vignette 'menu-name "Vignette")
2906 (defun Wand-mode-wave (amplitude wave-length)
2907 "Create wave effect on image with AMPLITUDE and WAVE-LENGTH."
2908 (interactive (list (read-number "Amplitude [2]: " nil "2")
2909 (read-number "Wave length [10]: " nil "10")))
2910 (Wand-operation-apply 'wave image-wand amplitude wave-length)
2912 (put 'Wand-mode-wave 'f/x-operation t)
2913 (put 'Wand-mode-wave 'menu-name "Wave")
2917 ;;{{{ Region commands
2919 (defun Wand-mode-select-region (event)
2922 (let ((gc-cons-threshold most-positive-fixnum) ; inhibit gc
2923 (sx (event-glyph-x-pixel event))
2924 (sy (event-glyph-y-pixel event))
2925 (had-preview-region preview-region)
2927 (setq preview-region (list 0 0 sx sy))
2929 (setq event (next-event event))
2930 (cond ((motion-event-p event)
2931 (let ((mx (event-glyph-x-pixel event))
2932 (my (event-glyph-y-pixel event)))
2934 (setq preview-region
2935 (list (abs (- sx mx)) (abs (- sy my))
2936 (min sx mx) (min sy my)))
2937 ;; Update info and preview image
2938 (Wand-mode-update-file-info)
2939 (let ((pwr (Wand-mode-preview-with-region)))
2941 (set-extent-end-glyph
2942 preview-extent (Wand-mode-preview-glyph pwr))
2943 (Wand:delete-wand pwr))))))
2945 ((button-release-event-p event)
2946 (setq mouse-down nil)
2947 (if (and (positivep (nth 0 preview-region))
2948 (positivep (nth 1 preview-region)))
2950 (put image-wand 'last-preview-region preview-region)
2952 (setq preview-region nil)
2953 (if had-preview-region
2955 ;; Remove any regions
2956 (Wand-mode-update-file-info)
2957 (set-extent-end-glyph
2958 preview-extent (Wand-mode-preview-glyph preview-wand)))
2960 ;; Otherwise pickup color
2961 (let* ((col (Wand:get-rgb-pixel-at preview-wand sx sy))
2962 (pickup-color (cons (cons sx sy) col)))
2963 (Wand-mode-update-info)))))
2964 (t (dispatch-event event))))))
2966 (defun Wand-mode-activate-region ()
2967 "Activate last preview-region."
2969 (setq preview-region (get image-wand 'last-preview-region))
2972 (defun Wand-mode-drag-image (event)
2973 "Drag image to view unshown part of the image."
2975 (let ((gc-cons-threshold most-positive-fixnum) ; inhibit gc
2976 (sx (event-glyph-x-pixel event))
2977 (sy (event-glyph-y-pixel event))
2978 (pw (Wand:image-width preview-wand))
2979 (ph (Wand:image-height preview-wand))
2982 (setq event (next-event event))
2983 (if (or (motion-event-p event) (button-release-event-p event))
2984 (let ((off-x (+ (- sx (event-glyph-x-pixel event))
2985 (or (get preview-wand 'offset-x) 0)))
2986 (off-y (+ (- sy (event-glyph-y-pixel event))
2987 (or (get preview-wand 'offset-y) 0))))
2988 (when (< off-x 0) (setq off-x 0))
2989 (when (< off-y 0) (setq off-y 0))
2990 (Wand-mode-update-file-info)
2991 (if (motion-event-p event)
2992 (set-extent-end-glyph
2993 preview-extent (Wand:glyph-internal
2994 preview-wand off-x off-y
2995 (- pw off-x) (- ph off-y)))
2998 (setq mouse-down nil)
2999 (put preview-wand 'offset-x off-x)
3000 (put preview-wand 'offset-y off-y)))
3002 (dispatch-event event)))))
3004 (defun Wand-mode-crop ()
3005 "Crop image to selected region."
3007 (unless preview-region
3008 (error "Region not selected"))
3009 (Wand-operation-apply 'crop image-wand (Wand-mode-image-region))
3010 (setq preview-region nil)
3012 (put 'Wand-mode-crop 'region-operation t)
3013 (put 'Wand-mode-crop 'menu-name "Crop")
3015 (defun Wand-mode-chop ()
3016 "Chop region from the image."
3018 (unless preview-region
3019 (error "Region not selected"))
3020 (Wand-operation-apply 'chop image-wand (Wand-mode-image-region))
3021 (setq preview-region nil)
3023 (put 'Wand-mode-chop 'region-operation t)
3024 (put 'Wand-mode-chop 'menu-name "Chop")
3026 (defun Wand-mode-redeye-remove ()
3027 "Remove red from the selected region."
3029 (unless preview-region
3030 (error "Region not selected"))
3031 (let ((gc-cons-threshold most-positive-fixnum)) ; inhibit gc
3032 (Wand-operation-apply 'redeye-remove image-wand (Wand-mode-image-region))
3033 (setq preview-region nil)
3035 (put 'Wand-mode-redeye-remove 'region-operation t)
3036 (put 'Wand-mode-redeye-remove 'menu-name "Remove red eye")
3039 ;;{{{ Zooming/Sampling
3041 (defun Wand-mode-zoom-in (&optional outp)
3042 "Zoom image in by `Wand-mode-zoom-factor'.."
3044 (Wand-operation-apply 'zoom image-wand outp Wand-mode-zoom-factor)
3047 (defun Wand-mode-zoom-out ()
3048 "Zoom image out by `Wand-mode-zoom-factor'."
3050 (Wand-mode-zoom-in t))
3052 (defun Wand-mode-sample (w h)
3053 "Sample image to WxH size."
3055 (list (read-number (format "Width [%d]: " (Wand:image-width image-wand))
3056 t (int-to-string (Wand:image-width image-wand)))
3057 (read-number (format "Height [%d]: " (Wand:image-height image-wand))
3058 t (int-to-string (Wand:image-height image-wand)))))
3059 (Wand-operation-apply 'sample image-wand w h)
3061 (put 'Wand-mode-sample 'transform-operation t)
3062 (put 'Wand-mode-sample 'menu-name "Sample")
3064 (defun Wand-mode-fit-size (w h)
3065 "Resize image to fit into WxH size."
3067 (let* ((dw (read-number
3068 (format "Width [%d]: " (Wand:image-width image-wand))
3069 t (int-to-string (Wand:image-width image-wand))))
3070 (dh (round (* (Wand:image-height image-wand)
3071 (// dw (Wand:image-width image-wand))))))
3072 (list dw (read-number (format "Height [%d]: " dh)
3073 t (int-to-string dh)))))
3075 (Wand-operation-apply 'fit-size image-wand w h)
3077 (put 'Wand-mode-fit-size 'transform-operation t)
3078 (put 'Wand-mode-fit-size 'menu-name "Fit to size")
3080 (defun Wand-mode-liquid-rescale (w h)
3081 "Rescale image to WxH using liquid rescale."
3083 (list (read-number (format "Width [%d]: " (Wand:image-width image-wand))
3084 t (int-to-string (Wand:image-width image-wand)))
3085 (read-number (format "Height [%d]: " (Wand:image-height image-wand))
3086 t (int-to-string (Wand:image-height image-wand)))))
3087 (Wand-operation-apply 'liquid-rescale image-wand w h)
3089 (put 'Wand-mode-liquid-rescale 'transform-operation t)
3090 (put 'Wand-mode-liquid-rescale 'menu-name "Liquid rescale")
3093 ;;{{{ Eval, Toggle fit, Undo/Redo, Saving
3095 (defun Wand-mode-eval-operation (op)
3096 "Evaluate raw operation OP."
3098 (list (read-from-minibuffer "Wand op: " nil
3099 read-expression-map t)))
3100 (apply #'Wand-operation-apply
3101 (car op) image-wand (cdr op))
3104 (defun Wand-mode-toggle-fit ()
3107 (put image-wand 'fitting (not (get image-wand 'fitting)))
3110 (defun Wand-mode-undo (&optional arg)
3111 "Undo last operation ARG times."
3113 (unless operations-list
3114 (error "Nothing to undo"))
3116 (push (car (last operations-list)) undo-list)
3117 (setq operations-list (butlast operations-list)))
3120 (Wand:clear-wand image-wand)
3121 (Wand:read-image image-wand buffer-file-name)
3122 (Wand-operation-list-apply image-wand)
3126 (defun Wand-mode-redo (&optional arg)
3127 "Redo last operations ARG times."
3130 (error "Nothing to redo"))
3132 (let ((op (pop undo-list)))
3134 (apply #'Wand-operation-apply (car op) image-wand (cdr op)))))
3138 (defun Wand-mode-repeat-last-operation ()
3139 "Repeat last operation on image."
3141 (let ((last-op (car (last operations-list))))
3143 (apply #'Wand-operation-apply
3144 (car last-op) image-wand (cdr last-op))
3147 (defun Wand-mode-global-operations-list (arg)
3148 "Fix operations list to be global for all images.
3149 If prefix ARG is supplied, then global operations list is reseted.
3150 Useful to skim over images in directory applying operations, for
3153 (setq Wand-global-operations-list
3154 (and (not arg) operations-list))
3157 (defun Wand-mode-write-file (format nfile)
3158 "Write file using output FORMAT."
3160 (let* ((ofmt (completing-read
3161 (format "Output Format [%s]: "
3162 (Wand:image-format image-wand))
3163 (mapcar #'list (Wand-formats-list "*" 'write))
3164 nil t nil nil (Wand:image-format image-wand)))
3165 (nfname (concat (file-name-sans-extension buffer-file-name)
3166 "." (downcase ofmt)))
3169 (file-name-directory buffer-file-name)
3170 nfname nil (file-name-nondirectory nfname))))
3172 (when (or (not Wand-mode-query-for-overwrite)
3173 (not (file-exists-p nfile))
3174 (y-or-n-p (format "File %s exists, overwrite? " nfile)))
3175 (setf (Wand:image-format image-wand) format)
3176 (let ((saved-iw image-wand)) ; do this because it is buffer-local
3178 (insert (Wand:image-blob saved-iw))
3179 (set-visited-file-name nfile t)
3180 (set-buffer-modified-p t)
3181 (setq buffer-read-only nil)
3182 (let ((buffer-file-coding-system (get-coding-system 'binary)))
3184 (message "File %s saved" nfile)
3186 ;; Redisplay in case we can do it
3187 (if (Wand-format-supported-for-read-p format)
3188 (Wand-display nfile)
3189 (find-file nfile))))
3191 (defun Wand-mode-save-file (nfile)
3192 "Save current wand to file NFILE.
3193 Output format determined by NFILE extension, and no sanity checks
3194 performed, use `Wand-mode-write-file' if are not sure."
3196 (list (read-file-name "Filename: "
3197 (file-name-directory buffer-file-name)
3198 buffer-file-name nil
3199 (file-name-nondirectory buffer-file-name))))
3200 (Wand-mode-write-file
3201 (upcase (file-name-extension nfile)) nfile))
3207 ;; now initialise the environment
3208 (when-fboundp 'Wand:MagickWandGenesis
3209 (Wand:MagickWandGenesis))
3211 (run-hooks 'ffi-wand-after-load-hook)
3213 ;;; ffi-wand.el ends here