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
55 (globally-declare-boundp
56 '(operations-list undo-list buffer-file-name image-wand preview-wand
57 preview-region preview-extent
58 find-file-magic-files-alist)))
63 (defvar Wand-ffio-as-image-data
65 (vector 'rawrgb :data (make-ffi-object 'pointer)
66 :pixel-width 2 :pixel-height 2) 'image))
69 "Non-nil if using GraphicsMagick.")
71 ;; this is our spine, barf if it does not exist
72 ;; ImageMagick version 6.4.0 calls libWand `libMagickWand' so try the
73 ;; old name first and don't error, fall back to the new name, barf if
74 ;; that fails as well --SY.
75 (or (ffi-load-library "libWand")
76 (ffi-load-library "libMagickWand")
77 (and (ffi-load "libGraphicsMagickWand")
81 ;;{{{ [+] FFI for MagickWand
84 (define-ffi-type MagickBooleanType long)
85 (define-ffi-translator-to-foreign MagickBooleanType
87 (define-ffi-translator-from-foreign MagickBooleanType
90 (define-ffi-struct MagickWand-private
92 (name (array char 4096))
95 (quantize-info pointer)
97 (active MagickBooleanType)
98 (pend MagickBooleanType)
99 (debug MagickBooleanType)
100 (signature unsigned-long))
102 (define-ffi-type MagickStatusType unsigned-int)
103 (define-ffi-struct MagickInfo
105 (description pointer)
114 (magick pointer) ; IsImageFormatHandler
115 (client-date pointer)
117 (adjoin MagickBooleanType)
118 (raw MagickBooleanType)
119 (endian_support MagickBooleanType)
120 (blob_support MagickBooleanType)
121 (seekable_stream MagickBooleanType)
122 (thread-support MagickStatusType)
123 (stealth MagickBooleanType)
125 ;; deprecated, use GetMagickInfoList()
129 (signature unsigned-long))
131 (define-ffi-enum MagickExceptionType
133 :WarningException = 300
134 :ResourceLimitWarning = :WarningException
137 :DelegateWarning = 315
138 :MissingDelegateWarning = 320
139 :CorruptImageWarning = 325
140 :FileOpenWarning = 330
150 :XServerWarning = 380
151 :MonitorWarning = 385
152 :RegistryWarning = 390
153 :ConfigureWarning = 395
154 :ErrorException = 400
155 :ResourceLimitError = :ErrorException
159 :MissingDelegateError = 420
160 :CorruptImageError = 425
174 :ConfigureError = 495
175 :FatalErrorException = 700
176 :ResourceLimitFatalError = :FatalErrorException
177 :TypeFatalError = 705
178 :OptionFatalError = 710
179 :DelegateFatalError = 715
180 :MissingDelegateFatalError = 720
181 :CorruptImageFatalError = 725
182 :FileOpenFatalError = 730
183 :BlobFatalError = 735
184 :StreamFatalError = 740
185 :CacheFatalError = 745
186 :CoderFatalError = 750
187 :ModuleFatalError = 755
188 :DrawFatalError = 760
189 :ImageFatalError = 765
190 :WandFatalError = 770
191 :RandomFatalError = 775
192 :XServerFatalError = 780
193 :MonitorFatalError = 785
194 :RegistryFatalError = 790
195 :ConfigureFatalError = 795)
197 (define-ffi-struct MagickExceptionInfo
198 (severity MagickExceptionType)
201 (description pointer)
203 (relinquish MagickBooleanType)
205 (signature unsigned-long))
208 (define-ffi-type MagickWand (pointer void))
209 (define-ffi-type DrawingWand (pointer void))
210 (define-ffi-type PixelWand (pointer void))
212 (define-ffi-struct PointInfo
213 (x double) (y double))
215 (define-ffi-enum MagickStorageType
217 :char-pixel = (if Wand-GM-p 0 1)
224 (define-ffi-enum MagickChannelType
226 :red-channel = #x0001
227 :cyan-channel = :red-channel
228 :gray-channel = :red-channel
229 :green-channel = #x0002
230 :magenta-channel = :green-channel
231 :blue-channel = #x0004
232 :yellow-channel = :blue-channel
233 :alpha-channel = #x0008
234 :opacity-channel = :alpha-channel
235 :black-channel = #x0020
236 :index-channel = :black-channel
237 :all-channel = #x7fff)
239 (define-ffi-enum WandCompositeOperator
240 :UndefinedCompositeOp
246 :ChangeMaskCompositeOp
248 :ColorBurnCompositeOp
249 :ColorDodgeCompositeOp
251 :CopyBlackCompositeOp
255 :CopyGreenCompositeOp
256 :CopyMagentaCompositeOp
257 :CopyOpacityCompositeOp
259 :CopyYellowCompositeOp
266 :DifferenceCompositeOp
269 :ExclusionCompositeOp
270 :HardLightCompositeOp
274 :LinearLightCompositeOp
286 :SoftLightCompositeOp
293 :ThresholdCompositeOp
297 (defun wand-camel-case-kw-string (kw n)
298 "Create a string from CamelCased keyword KW.
299 Strips last N words."
300 (let ((case-fold-search nil)
301 (kws (substring (symbol-name kw) 1)))
302 (while (string-match "[A-Z]" kws 1)
303 (setq kws (replace-match (concat "-" (downcase (match-string 0 kws)))
305 (mapconcat 'identity (butlast (split-string (downcase kws) "-") n) "-")))
307 (defmacro wand-camel-case-kw-completion (n)
309 (cons (wand-camel-case-kw-string x ,n) x)))
311 (defconst WandCompositeOperator-completion-table
312 (mapcar (wand-camel-case-kw-completion 2)
313 (mapcar #'car (ffi-enum-values 'WandCompositeOperator)))
314 "Completion table for composite operator.")
316 (define-ffi-enum FillRule
321 (define-ffi-enum PaintMethod
329 (define-ffi-enum MagickAlphaType
330 :UndefinedAlphaChannel
331 :ActivateAlphaChannel
332 :DeactivateAlphaChannel
336 (define-ffi-enum MagickNoiseType
340 :MultiplicativeGaussianNoise
346 (define-ffi-enum MagickFilterType
371 (define-ffi-enum MagickColorspaceType
375 :TransparentColorspace
389 :Rec601LumaColorspace
390 :Rec601YCbCrColorspace
391 :Rec709LumaColorspace
392 :Rec709YCbCrColorspace
396 (define-ffi-enum MagickAlignType
402 (define-ffi-enum MagickDecorationType
407 :LineThroughDecoration)
409 (define-ffi-enum MagickGravityType
411 :ForgetGravity = :UndefinedGravity
423 (define-ffi-enum MagickStretchType
426 :UltraCondensedStretch
427 :ExtraCondensedStretch
429 :SemiCondensedStretch
432 :ExtraExpandedStretch
433 :UltraExpandedStretch
436 (define-ffi-enum MagickStyleType
450 (define-ffi-enum MagickPreviewType
479 :CharcoalDrawingPreview
482 (defconst MagickPreviewType-completion-table
483 (mapcar (wand-camel-case-kw-completion 1)
484 (mapcar #'car (ffi-enum-values 'MagickPreviewType)))
485 "Completion table for preview types.")
488 ;;{{{ `-- Wand:version
490 (cffi:defcfun ("GetMagickVersion" Wand:GetMagickVersion) c-string
491 (n (pointer unsigned-long)))
493 (defun Wand:version ()
494 "Return Image Magick version string."
495 (let ((n (make-ffi-object 'unsigned-long)))
496 (Wand:GetMagickVersion (ffi-address-of n))))
499 ;;{{{ `-- Mime Type operations
501 (cffi:defcfun ("DestroyString" Wand:DestroyString) (pointer char)
504 (cffi:defcfun ("MagickToMime" Wand:MagickToMime) (pointer char)
507 (defun wand-format-mime-type (format)
508 "Return mime-type for the FORMAT."
509 (let ((mt (Wand:MagickToMime format)))
510 (unless (ffi-null-p mt)
512 (ffi-get mt :type 'c-string)
513 (Wand:DestroyString mt)))))
515 (defun Wand:image-mime-type (wand)
516 "Return mime-type for the WAND."
517 (wand-format-mime-type (Wand:image-format wand)))
520 ;;{{{ `-- MagickWand operations
522 ;; Return a newly allocated MagickWand.
523 (cffi:defcfun ("NewMagickWand" Wand:make-wand) MagickWand)
525 ;; Clear all resources associated with the WAND.
526 ;; This does not free the memory, i.e. @var{wand} can furtherly be used
527 ;; as a context, see `Wand:delete-wand'."
528 (cffi:defcfun ("ClearMagickWand" Wand:clear-wand) void
531 ;; Return a cloned copy of WAND.
532 (cffi:defcfun ("CloneMagickWand" Wand:copy-wand) MagickWand
535 ;; Gets the image at the current image index.
536 (cffi:defcfun ("MagickGetImage" Wand:get-image) MagickWand
540 ;; This frees all resources associated with the WAND.
541 ;; WARNING: Do not use WAND after calling this function!
542 (cffi:defcfun ("DestroyMagickWand" Wand:delete-wand) void
545 ;; Return non-nil if WAND is a magick wand, nil otherwise.
546 (cffi:defcfun ("IsMagickWand" Wand:wandp) MagickBooleanType
549 (defmacro Wand-with-wand (wand &rest forms)
550 "With allocated WAND do FORMS."
551 `(let ((,wand (Wand:make-wand)))
554 (Wand:delete-wand ,wand))))
555 (put 'Wand-with-wand 'lisp-indent-function 'defun)
557 (cffi:defcfun ("MagickNewImage" Wand:make-image) MagickBooleanType
558 "Adds a blank image canvas to the WAND."
559 (wand MagickWand) (cols unsigned-long) (rows unsigned-long)
562 ;; Extracts a region of the image and returns it as a a new wand.
563 (cffi:defcfun ("MagickGetImageRegion" Wand:image-region) MagickWand
564 (wand MagickWand) (dx unsigned-long) (dy unsigned-long)
565 (x unsigned-long) (y unsigned-long))
567 ;; MagickIdentifyImage() identifies an image by printing its
568 ;; attributes to the file. Attributes include the image width, height,
570 (cffi:defcfun ("MagickIdentifyImage" Wand:MagickIdentifyImage) pointer
573 (defun Wand:identify-image (wand)
574 "Return info about the image stored in WAND."
575 (let ((ii (Wand:MagickIdentifyImage wand)))
577 (ffi-get ii :type 'c-string)
578 (Wand:RelinquishMemory ii))))
580 ;; MagickResetImagePage() resets the Wand page canvas and position.
581 (cffi:defcfun ("MagickResetImagePage" Wand:MagickResetImagePage)
583 (wand MagickWand) (geom c-string))
585 (defun Wand:reset-image-page (wand &optional geometry)
586 "Reset the WAND page canvas and position to GEOMETRY.
587 If GEOMETRY is ommited then 0x0+0+0 is used."
588 (Wand:MagickResetImagePage wand (or geometry "0x0+0+0")))
591 (cffi:defcfun ("GetMagickProperty" Wand:GetMagickProperty) pointer
592 (info pointer) (image pointer) (property c-string))
594 (defun Wand:get-magick-property (wand prop)
595 "From WAND get magick property PROP.
596 PROP can be one of: `base', `channels', `colorspace', `depth',
597 `directory', `extension', `height', `input', `magick', `name',
598 `page', `size', `width', `xresolution', `yresolution'."
599 (when (member prop '("group" "kurtosis" "max" "mean"
600 "min" "output" "scene" "skewness"
601 "standard-deviation" "standard_deviation"
603 (error "Unsupported magick property" prop))
604 (let ((rt (Wand:GetMagickProperty
605 (ffi-null-pointer) (MagickWand-private->images wand)
607 (unless (ffi-null-p rt)
608 (ffi-get rt :type 'c-string))))
610 (defun Wand:image-orig-width (wand)
611 "Return original width of the image associated with WAND."
612 (string-to-int (Wand:get-magick-property wand "width")))
614 (defun Wand:image-orig-height (wand)
615 "Return original height of the image associated with WAND."
616 (string-to-int (Wand:get-magick-property wand "height")))
619 ;;{{{ `-- Images list operations
621 (cffi:defcfun ("MagickGetNumberImages" Wand:images-num) unsigned-long
624 (cffi:defcfun ("MagickHasNextImage" Wand:has-next-image) MagickBooleanType
627 (cffi:defcfun ("MagickNextImage" Wand:next-image) MagickBooleanType
630 (cffi:defcfun ("MagickHasPreviousImage" Wand:has-prev-image) MagickBooleanType
633 (cffi:defcfun ("MagickPreviousImage" Wand:prev-image) MagickBooleanType
636 (cffi:defcfun ("MagickGetIteratorIndex" Wand:iterator-index) long
639 (cffi:defcfun ("MagickSetIteratorIndex" Wand:MagickSetIteratorIndex)
641 (wand MagickWand) (idx long))
643 (defsetf Wand:iterator-index (w) (idx)
644 `(Wand:MagickSetIteratorIndex ,w ,idx))
646 (cffi:defcfun ("MagickSetFirstIterator" Wand:set-first-iterator) void
649 (cffi:defcfun ("MagickSetLastIterator" Wand:set-last-iterator) void
653 ;;{{{ `-- Image data input/output
655 (cffi:defcfun ("MagickReadImage" Wand:MagickReadImage) MagickBooleanType
659 (defun Wand:read-image (wand file)
660 "Read FILE and associate it with WAND."
661 (let ((fname (expand-file-name file)))
662 ;; simple error catchers
663 (unless (file-readable-p fname)
664 (error "File unreadable %s" fname))
665 (unless (Wand:wandp wand)
666 (wrong-type-argument 'Wand:wandp wand))
667 (Wand:MagickReadImage wand fname)))
669 (cffi:defcfun ("MagickReadImageBlob" Wand:MagickReadImageBlob) MagickBooleanType
674 (defun Wand:read-image-blob (wand blob)
675 "Read image from BLOB and associate it with WAND."
676 (let* ((lb (length blob))
677 (fob (make-ffi-object 'pointer (1+ lb))))
678 (ffi-store fob 0 'c-string blob)
679 (Wand:MagickReadImageBlob wand fob lb)))
681 (cffi:defcfun ("MagickDisplayImage" Wand:MagickDisplayImage) MagickBooleanType
685 (defun Wand:display-image (wand)
686 "Display the image associated with WAND.
687 WARNING: this will block untill display exits, so be careful."
688 (let ((x-server (device-connection (default-x-device))))
689 (Wand:MagickDisplayImage wand x-server)))
691 (cffi:defcfun ("MagickGetImageBlob" Wand:GetImageBlob) pointer
693 (len (pointer unsigned-int)))
695 (cffi:defcfun ("MagickRelinquishMemory" Wand:RelinquishMemory) pointer
698 (defun Wand:image-blob (wand)
699 "Return WAND's direct image data according to format.
700 Use \(setf \(Wand:image-format w\) FMT\) to set format."
701 (let* ((len (make-ffi-object 'unsigned-int))
702 (data (Wand:GetImageBlob wand (ffi-address-of len))))
704 (ffi-get data :type (cons 'c-data (ffi-get len)))
705 (Wand:RelinquishMemory data))))
707 (cffi:defcfun ("MagickWriteImage" Wand:MagickWriteImage) MagickBooleanType
710 (defun Wand:write-image (wand file)
711 "Write the image associated with WAND to FILE."
712 (let ((fname (expand-file-name file)))
713 ;; simple error catchers
714 (unless (file-writable-p fname)
715 (error "File unwritable %s" fname))
716 (unless (Wand:wandp wand)
717 (wrong-type-argument 'Wand:wandp wand))
718 (Wand:MagickWriteImage wand fname)))
721 ;;{{{ `-- Image format operations
723 (cffi:defcfun ("MagickQueryFormats"
724 Wand:QueryFormats) (pointer c-string)
726 (num-formats (pointer unsigned-long)))
728 (defun Wand:query-formats (pattern)
729 "Return list of supported formats that match PATTERN.
730 Use \"*\" to query all available formats."
731 (let* ((nf (make-ffi-object 'unsigned-long))
732 (fmts (Wand:QueryFormats pattern (ffi-address-of nf))))
733 (loop for n from 0 below (ffi-get nf)
735 (ffi-get fmts :off (* n (ffi-size-of-type 'pointer)))
738 (cffi:defcfun ("MagickGetFormat" Wand:wand-format) c-string
740 (cffi:defcfun ("MagickSetFormat" Wand:MagickSetFormat) MagickBooleanType
741 (wand MagickWand) (format c-string))
743 (defsetf Wand:wand-format (w) (nfmt)
744 `(Wand:MagickSetFormat ,w ,nfmt))
746 (cffi:defcfun ("MagickGetImageFormat" Wand:GetImageFormat) c-string
749 (cffi:defcfun ("MagickSetImageFormat" Wand:SetImageFormat) MagickBooleanType
753 (defun Wand:image-format (w)
754 "Return format for the image hold by W.
755 Use \(setf \(Wand:image-format w\) FMT\) to set new one."
756 (Wand:GetImageFormat w))
758 (defsetf Wand:image-format (w) (fmt)
759 `(Wand:SetImageFormat ,w ,fmt))
761 (cffi:defcfun ("GetMagickInfo" Wand:GetMagickInfo) (pointer MagickInfo)
765 (cffi:defcfun ("GetMagickInfoList" Wand:GetMagickInfoList)
766 (pointer (pointer MagickInfo))
768 (number-of-items (pointer unsigned-long))
771 (cffi:defcfun ("GetMagickBlobSupport" Wand:GetMagickBlobSupport)
773 (mi (pointer MagickInfo)))
775 (cffi:defcfun ("MagickGetImageColorspace" Wand:GetImageColorspace)
779 ;; ImageMagick changed API in favor for MagickTransformImageColorspace
780 ;(cffi:defcfun ("MagickSetImageColorspace" Wand:SetImageColorspace)
783 ; (cst MagickColorspaceType))
785 (cffi:defcfun ("MagickTransformImageColorspace" Wand:SetImageColorspace)
788 (cst MagickColorspaceType))
791 ;;{{{ `-- PixelWand operations
793 (cffi:defcfun ("NewPixelWand" Wand:NewPixelWand) PixelWand)
794 (cffi:defcfun ("DestroyPixelWand" Wand:DestroyPixelWand) PixelWand
797 (defmacro Wand-with-pixel-wand (pw &rest forms)
798 "With allocated pixel wand PW do FORMS."
799 `(let ((,pw (Wand:NewPixelWand)))
802 (Wand:DestroyPixelWand ,pw))))
803 (put 'Wand-with-pixel-wand 'lisp-indent-function 'defun)
805 (cffi:defcfun ("PixelGetHSL" Wand:PixelGetHSL) void
806 (pw PixelWand) (hue (pointer double)) (saturation (pointer double))
807 (lightness (pointer double)))
809 (cffi:defcfun ("PixelSetHSL" Wand:PixelSetHSL) void
810 (pw PixelWand) (hue double) (saturation double) (lightness double))
812 (defun Wand:pixel-hsl (pw)
813 "Return HSL for pixel wand PW."
814 (let ((hue (make-ffi-object 'double))
815 (sat (make-ffi-object 'double))
816 (light (make-ffi-object 'double)))
817 (Wand:PixelGetHSL pw (ffi-address-of hue) (ffi-address-of sat)
818 (ffi-address-of light))
819 (mapcar #'ffi-get (list hue sat light))))
821 (defsetf Wand:pixel-hsl (pw) (hsl)
822 `(apply #'Wand:PixelSetHSL ,pw ,hsl))
824 (cffi:defcfun ("PixelGetRed" Wand:pixel-red) double
826 (cffi:defcfun ("PixelGetGreen" Wand:pixel-green) double
828 (cffi:defcfun ("PixelGetBlue" Wand:pixel-blue) double
831 (cffi:defcfun ("PixelSetRed" Wand:PixelSetRed) void
832 (pw pointer) (red double))
833 (cffi:defcfun ("PixelSetGreen" Wand:PixelSetGreen) void
834 (pw pointer) (red double))
835 (cffi:defcfun ("PixelSetBlue" Wand:PixelSetBlue) void
836 (pw pointer) (red double))
838 (defsetf Wand:pixel-red (pw) (r)
839 `(Wand:PixelSetRed ,pw ,r))
840 (defsetf Wand:pixel-green (pw) (g)
841 `(Wand:PixelSetGreen ,pw ,g))
842 (defsetf Wand:pixel-blue (pw) (b)
843 `(Wand:PixelSetBlue ,pw ,b))
845 (defun Wand:pixel-rgb-components (pw)
846 "Return RGB components for pixel wand PW."
847 (mapcar #'(lambda (c) (int (* (funcall c pw) 65535.0)))
848 '(Wand:pixel-red Wand:pixel-green Wand:pixel-blue)))
850 (defsetf Wand:pixel-rgb-components (pw) (rgb)
851 "For pixel wand PW set RGB components."
852 `(mapcar* #'(lambda (sf c) (funcall sf ,pw (/ c 65535.0)))
853 '(Wand:PixelSetRed Wand:PixelSetGreen Wand:PixelSetBlue)
856 ;; PixelGetColorAsString() returns the color of the pixel wand as a
858 (cffi:defcfun ("PixelGetColorAsString" Wand:pixel-color) c-string
861 ;; PixelSetColor() sets the color of the pixel wand with a string
862 ;; (e.g. "blue", "#0000ff", "rgb(0,0,255)", "cmyk(100,100,100,10)",
864 (cffi:defcfun ("PixelSetColor" Wand:PixelSetColor) MagickBooleanType
868 (defsetf Wand:pixel-color (pw) (color)
869 `(Wand:PixelSetColor ,pw ,color))
871 ;; PixelGetAlpha() returns the normalized alpha color of the pixel
873 (cffi:defcfun ("PixelGetAlpha" Wand:pixel-alpha) double
876 ;; PixelSetAlpha() sets the normalized alpha color of the pixel wand.
877 ;; The level of transparency: 1.0 is fully opaque and 0.0 is fully
879 (cffi:defcfun ("PixelSetAlpha" Wand:PixelSetAlpha) void
883 (defsetf Wand:pixel-alpha (pw) (alpha)
884 `(Wand:PixelSetAlpha ,pw ,alpha))
887 ;;{{{ `-- Image pixels operations
889 (cffi:defcfun ("MagickGetImagePixels" Wand:MagickGetImagePixels)
894 (delta-width unsigned-long)
895 (delta-height unsigned-long)
897 (storage MagickStorageType)
898 (target (pointer int)))
900 (defun Wand:get-image-pixels-internal
901 (wand img-type from-width from-height delta-width delta-height)
902 "Return WAND's raw string of image pixel data (RGB triples).
903 FROM-WIDTH, FROM-HEIGHT, DELTA-WIDTH, DELTA-HEIGHT specifies region to
905 (let* ((tsz (ecase img-type (rawrgb 3) (rawrgba 4)))
906 (mapn (ecase img-type (rawrgb "RGB") (rawrgba "RGBA")))
907 (target (make-ffi-object 'c-data (* delta-width delta-height tsz))))
908 (when (Wand:MagickGetImagePixels
909 wand from-width from-height delta-width delta-height
910 mapn :char-pixel target)
911 (if Wand-ffio-as-image-data
915 (defun Wand:get-image-pixels (wand)
916 "Return WAND's raw string of image pixel data (RGB triples)."
917 (Wand:get-image-pixels-internal
918 wand 'rawrgb 0 0 (Wand:image-width wand) (Wand:image-height wand)))
920 (cffi:defcfun ("MagickSetImagePixels" Wand:MagickSetImagePixels)
922 (wand MagickWand) (x-offset long) (y-offset long)
923 (columns unsigned-long) (rows unsigned-long)
924 (map c-string) (storage-type MagickStorageType)
927 (defun Wand:set-image-pixels-internal (wand x y width height pixels)
928 (let ((stor (make-ffi-object 'c-data (* width height 3))))
929 (ffi-set stor pixels)
930 (Wand:MagickSetImagePixels
931 wand x y width height "RGB" 'char-pixel stor)))
933 (defun Wand:pixels-extract-colors (ss &optional n)
934 "Extract colors from SS string.
935 Return list of lists of N int elements representing RBG(A) values."
936 (let ((cls (mapcar #'char-to-int (string-to-list ss)))
939 (push (subseq cls 0 (or n 3)) rls)
940 (setq cls (nthcdr (or n 3) cls)))
943 (defun Wand:pixels-arrange-colors (cls)
944 "Create pixels string from CLS.
945 CLS is list of lists of N int elements representing RBG(A) values."
946 (mapconcat #'identity
947 (mapcan #'(lambda (els)
948 (mapcar #'char-to-string
949 (mapcar #'int-to-char els)))
953 ;; MagickConstituteImage() adds an image to the wand comprised of the
954 ;; pixel data you supply. The pixel data must be in scanline order
955 ;; top-to-bottom. The data can be char, short int, int, float, or
956 ;; double. Float and double require the pixels to be normalized
957 ;; [0..1], otherwise [0..Max], where Max is the maximum value the type
958 ;; can accomodate (e.g. 255 for char). For example, to create a
959 ;; 640x480 image from unsigned red-green-blue character data, use
960 (cffi:defcfun ("MagickConstituteImage" Wand:MagickConstituteImage)
962 (wand MagickWand) (width unsigned-long) (height unsigned-long)
963 (map c-string) (storage MagickStorageType) (pixels pointer))
966 ;;{{{ `-- Image modification functions
968 (cffi:defcfun ("MagickThumbnailImage" Wand:thumbnail-image)
970 (wand MagickWand) (width unsigned-long) (height unsigned-long))
972 (cffi:defcfun ("MagickRotateImage" Wand:RotateImage) MagickBooleanType
973 (wand MagickWand) (background-pixel PixelWand) (degrees double))
975 ;;Scale the image in WAND to the dimensions WIDTHxHEIGHT.
976 (cffi:defcfun ("MagickScaleImage" Wand:scale-image) MagickBooleanType
977 (wand MagickWand) (width unsigned-long) (height unsigned-long))
980 (cffi:defcfun ("MagickSampleImage" Wand:sample-image) MagickBooleanType
981 (wand MagickWand) (width unsigned-long) (height unsigned-long))
983 (cffi:defcfun ("MagickResizeImage" Wand:resize-image) MagickBooleanType
984 (wand MagickWand) (width unsigned-long) (height unsigned-long)
985 (filter MagickFilterType) (blur double))
988 (cffi:defcfun ("MagickLiquidRescaleImage" Wand:liquid-rescale)
990 (wand MagickWand) (width unsigned-long) (height unsigned-long)
991 (delta-x double) (rigidity double)))
993 ;; Crop to the rectangle spanned at X and Y by width DX and
994 ;; height DY in the image associated with WAND."
995 (cffi:defcfun ("MagickCropImage" Wand:crop-image) MagickBooleanType
996 (wand MagickWand) (width unsigned-long) (heigth unsigned-long)
997 (x unsigned-long) (y unsigned-long))
999 ;; MagickChopImage() removes a region of an image and collapses the
1000 ;; image to occupy the removed portion
1001 (cffi:defcfun ("MagickChopImage" Wand:chop-image) MagickBooleanType
1002 (wand MagickWand) (width unsigned-long) (heigth unsigned-long)
1005 (cffi:defcfun ("MagickFlipImage" Wand:flip-image) MagickBooleanType
1007 (cffi:defcfun ("MagickFlopImage" Wand:flop-image) MagickBooleanType
1009 ;; Rolls (offsets) the image associated with WAND to an offset
1011 (cffi:defcfun ("MagickRollImage" Wand:roll-image) MagickBooleanType
1012 (wand MagickWand) (x long) (y long))
1014 ;; Composite one image COMPOSITE-WAND onto another WAND at the
1015 ;; specified offset X, Y, using composite operator COMPOSE.
1016 (cffi:defcfun ("MagickCompositeImage" Wand:image-composite) MagickBooleanType
1017 (wand MagickWand) (composite-wand MagickWand) (compose WandCompositeOperator)
1020 (cffi:defcfun ("MagickCompositeImageChannel" Wand:image-composite-channel)
1022 (wand MagickWand) (channel MagickChannelType) (region-wand MagickWand)
1023 (compose WandCompositeOperator) (x long) (y long))
1025 ;;; image improvements and basic image properties
1026 (cffi:defcfun ("MagickContrastImage" Wand:MagickContrastImage)
1028 (wand MagickWand) (contrast MagickBooleanType))
1029 (defun Wand:increase-contrast-image (wand)
1030 "Increase the contrast of the image associated with WAND."
1031 (Wand:MagickContrastImage wand t))
1032 (defun Wand:decrease-contrast-image (wand)
1033 "Decrease the contrast of the image associated with WAND."
1034 (Wand:MagickContrastImage wand nil))
1036 ;; Reduce the speckle noise in the image associated with WAND.
1037 (cffi:defcfun ("MagickDespeckleImage" Wand:despeckle-image) MagickBooleanType
1039 ;; Enhance the image associated with WAND.
1040 (cffi:defcfun ("MagickEnhanceImage" Wand:enhance-image) MagickBooleanType
1042 ;; Equalise the image associated with WAND.
1043 (cffi:defcfun ("MagickEqualizeImage" Wand:equalize-image) MagickBooleanType
1045 ;; Normalise the image associated with WAND.
1046 (cffi:defcfun ("MagickNormalizeImage" Wand:normalize-image) MagickBooleanType
1051 (cffi:defcfun ("MagickColorizeImage" Wand:MagickColorizeImage)
1053 (w MagickWand) (color pointer) (opacity pointer))
1055 ;; Simulate a charcoal drawing of the image associated with WAND.
1056 ;; The RADIUS argument is a float and measured in pixels.
1057 ;; The SIGMA argument is a float and defines a derivation.
1058 (cffi:defcfun ("MagickCharcoalImage" Wand:charcoal-image) MagickBooleanType
1059 (wand MagickWand) (radius double) (sigma double))
1061 ;; Simulate oil-painting of image associated with WAND.
1062 ;; The RADIUS argument is a float and measured in pixels.
1063 (cffi:defcfun ("MagickOilPaintImage" Wand:oil-paint-image) MagickBooleanType
1064 (wand MagickWand) (radius double))
1066 ;; MagickSepiaToneImage() applies a special effect to the image,
1067 ;; similar to the effect achieved in a photo darkroom by sepia
1068 ;; toning. Threshold ranges from 0 to QuantumRange and is a measure of
1069 ;; the extent of the sepia toning. A threshold of 80 is a good
1070 ;; starting point for a reasonable tone.
1071 (cffi:defcfun ("MagickSepiaToneImage" Wand:sepia-tone-image) MagickBooleanType
1072 (wand MagickWand) (threshold double))
1074 ;; MagickImplodeImage() creates a new image that is a copy of an
1075 ;; existing one with the image pixels "implode" by the specified
1076 ;; percentage. It allocates the memory necessary for the new Image
1077 ;; structure and returns a pointer to the new image.
1078 (cffi:defcfun ("MagickImplodeImage" Wand:implode-image) MagickBooleanType
1079 (wand MagickWand) (radius double))
1081 ;; MagickVignetteImage() softens the edges of the image in vignette
1083 (cffi:defcfun ("MagickVignetteImage" Wand:vignette-image)
1085 (wand MagickWand) (black-point double) (white-point double)
1086 (x double) (y double))
1088 ;; Enhance the edges of the image associated with WAND.
1089 ;; The RADIUS argument is a float and measured in pixels.
1090 (cffi:defcfun ("MagickEdgeImage" Wand:edge-image) MagickBooleanType
1091 (wand MagickWand) (radius double))
1093 ;; Emboss the image associated with WAND (a relief effect).
1094 ;; The RADIUS argument is a float and measured in pixels.
1095 ;; The SIGMA argument is a float and defines a derivation.
1096 (cffi:defcfun ("MagickEmbossImage" Wand:emboss-image) MagickBooleanType
1097 (wand MagickWand) (radius double) (sigma double))
1099 ;; MagickWaveImage() creates a "ripple" effect in the image by
1100 ;; shifting the pixels vertically along a sine wave whose amplitude
1101 ;; and wavelength is specified by the given parameters.
1102 ;; The AMPLITUDE argument is a float and defines the how large
1104 ;; The WAVELENGTH argument is a float and defines how often the
1106 (cffi:defcfun ("MagickWaveImage" Wand:wave-image) MagickBooleanType
1107 (wand MagickWand) (amplitude double) (wavelength double))
1109 ;; Swirl the image associated with WAND by DEGREES.
1110 (cffi:defcfun ("MagickSwirlImage" Wand:swirl-image) MagickBooleanType
1111 (wand MagickWand) (degrees double))
1113 (cffi:defcfun ("MagickPosterizeImage" Wand:MagickPosterizeImage)
1115 (wand MagickWand) (levels unsigned-long) (ditherp MagickBooleanType))
1116 (defun Wand:posterize-image (wand levels &optional ditherp)
1117 "Posterize the image associated with WAND.
1118 that is quantise the range of used colours to at most LEVELS.
1119 If optional argument DITHERP is non-nil use a dithering
1120 effect to wipe hard contrasts."
1121 (Wand:MagickPosterizeImage wand levels ditherp))
1123 ;; MagickAddNoiseImage() adds random noise to the image.
1124 (cffi:defcfun ("MagickAddNoiseImage" Wand:add-noise-image) MagickBooleanType
1125 (wand MagickWand) (noise-type MagickNoiseType))
1127 (cffi:defcfun ("MagickAddNoiseImageChannel" Wand:add-noise-image-channel)
1129 (wand MagickWand) (channel MagickChannelType) (noise-type MagickNoiseType))
1131 ;; Reduce the noise in the image associated with WAND by RADIUS.
1132 (cffi:defcfun ("MagickReduceNoiseImage" Wand:reduce-noise-image)
1134 (wand MagickWand) (radius double))
1136 ;; Perform gamma correction on the image associated with WAND.
1137 ;; The argument LEVEL is a positive float, a value of 1.00 (read 100%)
1139 (cffi:defcfun ("MagickGammaImage" Wand:gamma-image) MagickBooleanType
1140 (wand MagickWand) (level double))
1142 ;; Perform gamma correction on CHANNEL of LEVEL on the image
1143 ;; associated with WAND.
1144 (cffi:defcfun ("MagickGammaImageChannel" Wand:gamma-image-channel)
1146 (wand MagickWand) (channel MagickChannelType) (level double))
1148 ;; Perform median normalisation of the pixels in the image associated
1150 (cffi:defcfun ("MagickMedianFilterImage" Wand:median-filter-image)
1152 (wand MagickWand) (radius double))
1154 ;; Solarise the image associated with WAND.
1155 (cffi:defcfun ("MagickSolarizeImage" Wand:solarize-image) MagickBooleanType
1159 ;; Tweak the image associated with WAND.
1160 (cffi:defcfun ("MagickModulateImage" Wand:MagickModulateImage)
1162 (wand MagickWand) (brightness double) (saturation double) (hue double))
1164 (defun* Wand:modulate-image (wand &key (brightness 100.0)
1167 (Wand:MagickModulateImage wand brightness saturation hue))
1169 ;; Separate a two-color high contrast image.
1170 (cffi:defcfun ("MagickThresholdImage" Wand:threshold-image) MagickBooleanType
1171 (wand MagickWand) (threshold double))
1173 ;; Separate a two-color high contrast image on CHANNEL.
1174 (cffi:defcfun ("MagickThresholdImageChannel" Wand:threshold-image-channel)
1176 (wand MagickWand) (channel MagickChannelType) (threshold double))
1178 (cffi:defcfun ("MagickWhiteThresholdImage" Wand:white-threshold-image)
1180 (wand MagickWand) (threshold double))
1182 (cffi:defcfun ("MagickRaiseImage" Wand:MagickRaiseImage) MagickBooleanType
1183 (wand MagickWand) (width unsigned-long) (height unsigned-long)
1184 (x long) (y long) (raise MagickBooleanType))
1186 (defun Wand:raise-image (wand &optional raise)
1188 (Wand:MagickRaiseImage
1189 wand (Wand:image-width wand) (Wand:image-height wand)
1194 ;; Blur the image associated with WAND.
1195 ;; The RADIUS argument is a float and measured in pixels.
1196 ;; The SIGMA argument is a float and defines a derivation.
1197 (cffi:defcfun ("MagickBlurImage" Wand:blur-image) MagickBooleanType
1198 (wand MagickWand) (radius double) (sigma double))
1200 ;; Blur CHANNEL in the image associated with WAND by RADIUS
1201 ;; pixels with derivation SIGMA.
1202 (cffi:defcfun ("MagickBlurImageChannel" Wand:blur-image-channel)
1204 (wand MagickWand) (channel MagickChannelType)
1205 (radius double) (sigma double))
1207 ;; Blur the image associated with WAND.
1208 ;; The RADIUS argument is a float and measured in pixels.
1209 ;; The SIGMA argument is a float and defines a derivation.
1210 (cffi:defcfun ("MagickGaussianBlurImage" Wand:gaussian-blur-image)
1212 (wand MagickWand) (radius double) (sigma double))
1214 ;; Blur CHANNEL in the image associated with WAND by RADIUS
1215 ;; pixels with derivation SIGMA.
1216 (cffi:defcfun ("MagickGaussianBlurImageChannel"
1217 Wand:gaussian-blur-image-channel) MagickBooleanType
1218 (wand MagickWand) (channel MagickChannelType)
1219 (radius double) (sigma double))
1221 ;; Blur the image associated with WAND.
1222 ;; The RADIUS argument is a float and measured in pixels.
1223 ;; The SIGMA argument is a float and defines a derivation.
1224 ;; The ANGLE argument is a float and measured in degrees.
1225 (cffi:defcfun ("MagickMotionBlurImage" Wand:motion-blur-image)
1227 (wand MagickWand) (radius double) (sigma double) (angle double))
1229 ;; Blur the image associated with WAND.
1230 ;; The ANGLE argument is a float and measured in degrees.
1231 (cffi:defcfun ("MagickRadialBlurImage" Wand:radial-blur-image)
1233 (wand MagickWand) (radius double))
1235 ;; Simulates an image shadow
1236 (cffi:defcfun ("MagickShadowImage" Wand:shadow-image)
1238 (wand MagickWand) (opacity double) (sigma double) (x long) (y long))
1240 ;; Sharpen the image associated with WAND.
1241 ;; The RADIUS argument is a float and measured in pixels.
1242 ;; The SIGMA argument is a float and defines a derivation.
1243 (cffi:defcfun ("MagickSharpenImage" Wand:sharpen-image) MagickBooleanType
1245 (radius double) (sigma double))
1247 ;; Sharpen CHANNEL in the image associated with WAND by RADIUS
1248 ;; pixels with derivation SIGMA.
1249 (cffi:defcfun ("MagickSharpenImageChannel" Wand:sharpen-image-channel)
1251 (wand MagickWand) (channel MagickChannelType)
1252 (radius double) (sigma double))
1254 ;; Sharpen the image associated with WAND using an unsharp mask.
1255 ;; The unsharp mask is defined by RADIUS and SIGMA.
1256 ;; The strength of sharpening is controlled by AMOUNT and THRESHOLD.
1257 (cffi:defcfun ("MagickUnsharpMaskImage" Wand:unsharp-mask-image)
1259 (wand MagickWand) (radius double) (sigma double)
1260 (amount double) (threshold double))
1262 ;; Sharpen CHANNEL in the image associated with WAND with an unsharp mask
1263 ;; defined by RADIUS and SIGMA. The strength of sharpening is controlled
1264 ;; by AMOUNT and THRESHOLD.
1265 (cffi:defcfun ("MagickUnsharpMaskImageChannel"
1266 Wand:unsharp-mask-image-channel)
1268 (wand MagickWand) (channel MagickChannelType)
1269 (radius double) (sigma double) (amount double) (threshold double))
1271 (cffi:defcfun ("MagickNegateImage" Wand:MagickNegateImage) MagickBooleanType
1273 (greyp MagickBooleanType))
1274 (defun Wand:negate-image (wand &optional greyp)
1275 "Perform negation on the image associated with WAND."
1276 (Wand:MagickNegateImage wand greyp))
1278 (cffi:defcfun ("MagickNegateImageChannel"
1279 Wand:MagickNegateImageChannel)
1281 (wand MagickWand) (channel MagickChannelType) (greyp MagickBooleanType))
1282 (defun Wand:negate-image-channel (wand channel &optional greyp)
1283 "Perform negation of CHANNEL on the image associated with WAND."
1284 (Wand:MagickNegateImageChannel wand channel greyp))
1286 (cffi:defcfun ("MagickSpreadImage" Wand:spread-image) MagickBooleanType
1287 (wand MagickWand) (radius double))
1289 ;; MagickTrimImage() remove edges that are the background color from
1291 (cffi:defcfun ("MagickTrimImage" Wand:trim-image) MagickBooleanType
1292 (wand MagickWand) (fuzz double))
1294 (cffi:defcfun ("MagickPreviewImages" Wand:preview-images) MagickWand
1295 (wand MagickWand) (ptype MagickPreviewType))
1298 ;;{{{ `-- Image size
1300 (cffi:defcfun ("MagickGetSize" Wand:MagickGetSize) MagickBooleanType
1301 (w MagickWand) (width (pointer unsigned-long))
1302 (height (pointer unsigned-long)))
1303 (cffi:defcfun ("MagickSetSize" Wand:MagickSetSize) MagickBooleanType
1304 (w MagickWand) (width unsigned-long) (height unsigned-long))
1306 (defun Wand:image-size (wand)
1307 "Return size of the image, associated with WAND."
1308 (let ((w (make-ffi-object 'unsigned-long))
1309 (h (make-ffi-object 'unsigned-long)))
1310 (when (Wand:MagickGetSize wand (ffi-address-of w) (ffi-address-of h))
1311 (cons (ffi-get w) (ffi-get h)))))
1312 (defsetf Wand:image-size (wand) (size)
1313 `(Wand:MagickSetSize ,wand (car ,size) (cdr ,size)))
1315 (cffi:defcfun ("MagickGetImageHeight" Wand:image-height) unsigned-long
1317 (cffi:defcfun ("MagickGetImageWidth" Wand:image-width) unsigned-long
1321 ;;{{{ `-- Image profiles
1323 (defun Wand-fetch-relinquish-strings (strs slen)
1324 "Fetch strings from strings array STRS of length SLEN."
1325 (unless (ffi-null-p strs)
1327 (mapcar #'(lambda (pr)
1328 (ffi-get pr :type 'c-string))
1329 (ffi-get strs :type (list 'array 'pointer slen)))
1330 (Wand:RelinquishMemory strs))))
1333 (cffi:defcfun ("MagickGetImageProfiles" Wand:MagickGetImageProfiles) pointer
1336 (number-profiles pointer))
1338 (defun Wand:image-profiles (wand pattern)
1339 "Get list of WAND's profiles matching PATTERN."
1340 (let* ((plen (make-ffi-object 'unsigned-long))
1341 (profs (Wand:MagickGetImageProfiles
1342 wand pattern (ffi-address-of plen))))
1343 (Wand-fetch-relinquish-strings profs (ffi-get plen))))
1345 (cffi:defcfun ("MagickGetImageProfile" Wand:MagickGetImageProfile) pointer
1350 (cffi:defcfun ("MagickSetImageProfile" Wand:MagickSetImageProfile)
1352 (w MagickWand) (pname c-string)
1353 (prof pointer) (sz unsigned-int))
1355 (defconst Wand-iptc-names-table
1356 '((120 . caption) (25 . keyword)))
1358 (defun Wand:image-profile-iptc (wand)
1359 "Fetch IPTC profile from WAND in lisp-friendly form."
1360 (let* ((plen (make-ffi-object 'unsigned-int))
1361 (prof (Wand:MagickGetImageProfile wand "iptc" (ffi-address-of plen)))
1362 (rlen (ffi-get plen)) (coff 0) (rv nil))
1363 (unless (ffi-null-p prof)
1365 (flet ((getbyte () (prog1
1366 (ffi-get prof :off coff :type 'byte)
1368 ;; 28 - must start any iptc header
1369 (while (and (< coff rlen) (= (getbyte) 28))
1370 (let* ((itype (getbyte)) (idset (getbyte))
1371 (l1 (getbyte)) (l2 (getbyte))
1372 (ln (logior (ash l1 8) l2)))
1374 ;; only string type supported
1375 (push (cons (cdr (assq idset Wand-iptc-names-table))
1376 (ffi-get prof :off coff :type `(c-data . ,ln)))
1380 (Wand:RelinquishMemory prof)))))
1382 (defun Wand:image-save-iptc-profile (w iptc)
1383 "For wand W store IPTC profile."
1384 (let ((oolen (reduce #'(lambda (e1 e2)
1385 (+ e1 5 (length (cdr e2))))
1386 iptc :initial-value 0)))
1388 (let ((prof (make-ffi-object 'pointer oolen))
1390 (flet ((savebyte (byte)
1392 (ffi-store prof coff 'byte byte)
1394 (loop for ipel in iptc do
1395 (savebyte 28) (savebyte 2)
1396 (savebyte (car (find (car ipel)
1397 Wand-iptc-names-table :key #'cdr)))
1398 (let* ((ln (length (cdr ipel)))
1399 (l1 (ash (logand ln #xff00) -8))
1400 (l2 (logand ln #x00ff)))
1401 (savebyte l1) (savebyte l2)
1402 (ffi-store prof coff 'c-string (cdr ipel))
1404 (Wand:MagickSetImageProfile w "iptc" prof oolen)))
1408 ;;{{{ `-- Image properties
1410 (cffi:defcfun ("MagickGetImageProperties" Wand:MagickGetImageProperties) pointer
1413 (number-properties pointer))
1415 (defun Wand:image-properties (w pattern)
1416 "Return list of image properties that match PATTERN."
1417 (let* ((plen (make-ffi-object 'unsigned-long))
1418 (props (Wand:MagickGetImageProperties
1419 w pattern (ffi-address-of plen))))
1420 (Wand-fetch-relinquish-strings props (ffi-get plen))))
1422 (cffi:defcfun ("MagickGetImageProperty" Wand:MagickGetImageProperty) pointer
1423 (w MagickWand) (property c-string))
1425 (cffi:defcfun ("MagickSetImageProperty" Wand:MagickSetImageProperty)
1427 (w MagickWand) (prop c-string) (val c-string))
1429 (defun Wand:image-property (w property)
1430 "Return value for PROPERTY.
1431 Use \(setf \(Wand:image-property w prop\) VAL\) to set property."
1432 (let ((pv (Wand:MagickGetImageProperty w property)))
1433 (unless (ffi-null-p pv)
1435 (ffi-get pv :type 'c-string)
1436 (Wand:RelinquishMemory pv)))))
1438 (defsetf Wand:image-property (w prop) (val)
1439 `(Wand:MagickSetImageProperty ,w ,prop ,val))
1441 (cffi:defcfun ("MagickGetQuantumRange" Wand:MagickGetQuantumRange) pointer
1442 (qr (pointer unsigned-long)))
1443 (defun Wand:quantum-range ()
1444 (let ((qr (make-ffi-object 'unsigned-long)))
1445 (Wand:MagickGetQuantumRange (ffi-address-of qr))
1448 ;; Very simple properties editor
1449 (defun Wand-mode-prop-editor ()
1450 "Run properties editor."
1452 (let* ((iw image-wand)
1453 (props (remove-if-not
1455 (string-match Wand-mode-properties-pattern prop))
1456 (Wand:image-properties iw ""))))
1457 (save-window-excursion
1460 (mapc #'(lambda (prop)
1461 (insert prop ": " (Wand:image-property iw prop) "\n"))
1463 (pop-to-buffer (current-buffer))
1465 (message "Press %s when done, or %s to cancel"
1466 (sorted-key-descriptions
1467 (where-is-internal 'exit-recursive-edit))
1468 (sorted-key-descriptions
1469 (where-is-internal 'abort-recursive-edit)))
1472 ;; User pressed C-M-c, parse buffer and store new props
1473 (goto-char (point-min))
1475 (let* ((st (buffer-substring (point-at-bol) (point-at-eol)))
1476 (pv (split-string st ": ")))
1477 (setf (Wand:image-property iw (first pv)) (second pv)))
1481 ;;{{{ `-- Image clip mask
1483 (cffi:defcfun ("MagickGetImageClipMask" Wand:clip-mask) MagickWand
1486 (cffi:defcfun ("SetImageClipMask" Wand:SetImageClipMask) MagickBooleanType
1487 (i pointer) (m pointer))
1489 (cffi:defcfun ("MagickSetImageClipMask" Wand:MagickSetImageClipMask)
1491 (w MagickWand) (cm MagickWand))
1493 (defsetf Wand:clip-mask (w) (cm)
1494 "Set wand's W clip mask to be CM.
1495 If CM is nil or null-pointer then unset clip mask."
1496 `(if (and ,cm (not (ffi-null-p ,cm)))
1497 (Wand:MagickSetImageClipMask ,w ,cm)
1498 ;; call SetImageClipMask directly to unset the clip mask
1499 (Wand:SetImageClipMask
1500 (ffi-fetch ,w (ffi-slot-offset 'MagickWand-private 'images) 'pointer)
1501 (ffi-null-pointer))))
1504 ;;{{{ `-- Misc image functions
1506 ;; MagickSetImageMatte() (un)sets the image matte channel
1507 (cffi:defcfun ("MagickSetImageMatte" Wand:MagickSetImageMatte) MagickBooleanType
1509 (matte MagickBooleanType))
1511 (cffi:defcfun ("MagickGetImageAlphaChannel" Wand:image-alpha-channel)
1515 (cffi:defcfun ("MagickSetImageAlphaChannel" Wand:MagickSetImageAlphaChannel)
1518 (alpha MagickAlphaType))
1520 (defsetf Wand:image-alpha-channel (w) (at)
1521 `(Wand:MagickSetImageAlphaChannel ,w ,at))
1524 ;;{{{ `-- DrawingWand operations
1526 ;; MagickDrawImage() renders the drawing wand on the current image.
1527 (cffi:defcfun ("MagickDrawImage" Wand:MagickDrawImage) MagickBooleanType
1528 (w MagickWand) (dw DrawingWand))
1530 (cffi:defcfun ("MagickAnnotateImage" Wand:MagickAnnotateImage)
1532 (w MagickWand) (dw DrawingWand) (x double) (y double)
1533 (angle double) (text c-string))
1535 (cffi:defcfun ("ClearDrawingWand" Wand:clear-drawing-wand) void
1538 (cffi:defcfun ("CloneDrawingWand" Wand:copy-drawing-wand) DrawingWand
1541 (cffi:defcfun ("DestroyDrawingWand" Wand:delete-drawing-wand) DrawingWand
1544 (cffi:defcfun ("NewDrawingWand" Wand:make-drawing-wand) DrawingWand)
1546 ;; MagickQueryFontMetrics() returns a 13 element array representing the
1547 ;; following font metrics:
1549 ;; Element Description
1550 ;; -------------------------------------------------
1551 ;; 0 character width
1552 ;; 1 character height
1557 ;; 6 maximum horizontal advance
1558 ;; 7 bounding box: x1
1559 ;; 8 bounding box: y1
1560 ;; 9 bounding box: x2
1561 ;; 10 bounding box: y2
1564 (cffi:defcfun ("MagickQueryFontMetrics" Wand:query-font-metrics) (array double 13)
1565 (wand MagickWand) (dw DrawingWand) (text c-string))
1567 (defmacro Wand-with-drawing-wand (dw &rest forms)
1568 "With allocated drawing wand DW do FORMS."
1569 `(let ((,dw (Wand:make-drawing-wand)))
1572 (Wand:delete-drawing-wand ,dw))))
1573 (put 'Wand-with-drawing-wand 'lisp-indent-function 'defun)
1576 (defun Wand:draw-font (dw)
1577 "For drawing wand DW return draw font as wand-font object."
1578 (make-wand-font :family (Wand:draw-font-family dw)
1579 :size (Wand:draw-font-size dw)
1580 :weight (Wand:draw-font-weight dw)
1581 :stretch (Wand:draw-font-stretch dw)
1582 :style (Wand:draw-font-style dw)))
1584 (defsetf Wand:draw-font (dw) (fn)
1585 "For drawing wand DW set font to FN.
1586 FN might be a string or wand-font object."
1588 (setf (Wand:draw-font-font ,dw) ,fn)
1589 (let ((fm (wand-font-family ,fn))
1590 (sz (wand-font-size ,fn))
1591 (weight (wand-font-weight ,fn))
1592 (stretch (wand-font-stretch ,fn))
1593 (style (wand-font-style ,fn)))
1594 (when fm (setf (Wand:draw-font-family ,dw) fm))
1595 (when sz (setf (Wand:draw-font-size ,dw) sz))
1596 (when weight (setf (Wand:draw-font-weight ,dw) weight))
1597 (when stretch (setf (Wand:draw-font-stretch ,dw) stretch))
1598 (when style (setf (Wand:draw-font-style ,dw) style)))))
1600 (cffi:defcfun ("DrawGetFont" Wand:draw-font-font) safe-string
1602 (cffi:defcfun ("DrawSetFont" Wand:DrawSetFont) MagickBooleanType
1603 (dw DrawingWand) (font-name c-string))
1605 (defsetf Wand:draw-font-font (dw) (fn)
1606 `(Wand:DrawSetFont ,dw ,fn))
1608 (cffi:defcfun ("DrawGetFontFamily" Wand:draw-font-family) safe-string
1610 (cffi:defcfun ("DrawSetFontFamily" Wand:DrawSetFontFamily) MagickBooleanType
1611 (dw DrawingWand) (font-family c-string))
1613 (defsetf Wand:draw-font-family (dw) (ff)
1614 `(Wand:DrawSetFontFamily ,dw ,ff))
1616 (cffi:defcfun ("DrawGetFontSize" Wand:DrawGetFontSize) double
1618 (cffi:defcfun ("DrawSetFontSize" Wand:DrawSetFontSize) void
1619 (dw DrawingWand) (font-size double))
1621 (defun Wand:draw-font-size (dw)
1622 (int (Wand:DrawGetFontSize dw)))
1623 (defsetf Wand:draw-font-size (dw) (fn-size)
1624 `(Wand:DrawSetFontSize ,dw (float ,fn-size)))
1626 (cffi:defcfun ("DrawGetFontStretch" Wand:draw-font-stretch) MagickStretchType
1628 (cffi:defcfun ("DrawSetFontStretch" Wand:DrawSetFontStretch) void
1629 (dw DrawingWand) (stretch MagickStretchType))
1630 (defsetf Wand:draw-font-stretch (dw) (fs)
1631 `(Wand:DrawSetFontStretch ,dw ,fs))
1633 (cffi:defcfun ("DrawGetFontStyle" Wand:draw-font-style) MagickStyleType
1635 (cffi:defcfun ("DrawSetFontStyle" Wand:DrawSetFontStyle) void
1636 (dw DrawingWand) (stretch MagickStyleType))
1637 (defsetf Wand:draw-font-style (dw) (fs)
1638 `(Wand:DrawSetFontStyle ,dw ,fs))
1640 (cffi:defcfun ("DrawGetFontWeight" Wand:draw-font-weight) unsigned-long
1642 (cffi:defcfun ("DrawSetFontWeight" Wand:DrawSetFontWeight) void
1643 (dw DrawingWand) (fw unsigned-long))
1644 (defsetf Wand:draw-font-weight (dw) (fw)
1645 `(Wand:DrawSetFontWeight ,dw ,fw))
1647 (cffi:defcfun ("DrawGetFillRule" Wand:draw-fill-rule) FillRule
1649 (cffi:defcfun ("DrawSetFillRule" Wand:DrawSetFillRule) void
1650 (dw DrawingWand) (fill-rule FillRule))
1652 (defsetf Wand:draw-fill-rule (dw) (fr)
1653 `(Wand:DrawSetFillRule ,dw ,fr))
1655 (cffi:defcfun ("DrawPoint" Wand:draw-point) void
1656 (dw DrawingWand) (x double) (y double))
1658 (defun Wand:draw-points (dw points)
1659 (mapc #'(lambda (p) (Wand:draw-point dw (car p) (cdr p))) points))
1661 (cffi:defcfun ("DrawAnnotation" Wand:draw-annotation) void
1662 (dw DrawingWand) (x double) (y double) (text c-string))
1664 (cffi:defcfun ("DrawGetTextAntialias" Wand:text-antialias)
1667 (cffi:defcfun ("DrawSetTextAntialias" Wand:SetTextAntialias) void
1668 (dw DrawingWand) (taa MagickBooleanType))
1669 (defsetf Wand:text-antialias (dw) (taa)
1670 `(Wand:SetTextAntialias ,dw ,taa))
1672 (cffi:defcfun ("DrawGetTextAlignment" Wand:text-alignment)
1675 (cffi:defcfun ("DrawSetTextAlignment" Wand:SetTextAlignment) void
1676 (dw DrawingWand) (tat MagickAlignType))
1677 (defsetf Wand:text-alignment (dw) (tat)
1678 `(Wand:SetTextAlignment ,dw ,tat))
1680 (cffi:defcfun ("DrawGetGravity" Wand:text-gravity)
1683 (cffi:defcfun ("DrawSetGravity" Wand:SetTextGravity) void
1684 (dw DrawingWand) (tat MagickGravityType))
1685 (defsetf Wand:text-gravity (dw) (tgt)
1686 `(Wand:SetTextGravity ,dw ,tgt))
1688 ; DrawSetTextDecoration(DrawingWand *,const DecorationType),
1690 (cffi:defcfun ("DrawArc" Wand:draw-arc) void
1691 (dw DrawingWand) (sx double) (sy double) (ex double)
1692 (ey double) (sd double) (ed double))
1694 (cffi:defcfun ("DrawCircle" Wand:draw-circle) void
1695 (dw DrawingWand) (ox double) (oy double) (px double) (py double))
1697 (cffi:defcfun ("DrawRectangle" Wand:draw-rectangle) void
1698 (dw DrawingWand) (ox double) (oy double) (ex double) (ey double))
1700 (cffi:defcfun ("DrawRoundRectangle" Wand:draw-round-rectangle) void
1701 (dw DrawingWand) (x1 double) (y1 double) (x2 double) (y2 double)
1702 (rx double) (ry double))
1704 (cffi:defcfun ("DrawColor" Wand:draw-color) void
1705 (dw DrawingWand) (x double) (y double) (paint-method PaintMethod))
1707 (cffi:defcfun ("DrawPolygon" Wand:DrawPolygon) void
1709 (number-coordinates unsigned-long)
1710 (coordinates PointInfo))
1712 (cffi:defcfun ("DrawPolyline" Wand:DrawPolyline) void
1714 (number-coordinates unsigned-long)
1715 (coordinates PointInfo))
1717 (cffi:defcfun ("DrawBezier" Wand:DrawBezier) void
1719 (number-coordinates unsigned-long)
1720 (coordinates PointInfo))
1722 (defun Wand:points-PointInfo (points)
1723 (let* ((plen (length points))
1724 (coords (make-ffi-object (list 'array 'PointInfo plen))))
1726 (let ((poi (make-ffi-object 'PointInfo))
1727 (npo (nth n points)))
1728 (setf (PointInfo->x poi) (float (car npo))
1729 (PointInfo->y poi) (float (cdr npo)))
1730 (ffi-aset coords n poi)))
1733 (defun Wand:draw-polygon (dw points)
1734 (Wand:DrawPolygon dw (length points) (Wand:points-PointInfo points)))
1736 (cffi:defcfun ("DrawLine" Wand:draw-line) void
1737 (dw DrawingWand) (sx double) (sy double)
1738 (ex double) (ey double))
1740 (defun Wand:draw-lines (dw points)
1741 (Wand:DrawPolyline dw (length points) (Wand:points-PointInfo points)))
1743 (defun Wand:draw-bezier (dw points)
1744 (Wand:DrawBezier dw (length points) (Wand:points-PointInfo points)))
1746 (defun Wand:draw-segment (dw seg)
1747 (Wand:draw-line dw (float (caar seg)) (float (cdar seg))
1748 (float (cadr seg)) (float (cddr seg))))
1750 (defun Wand:draw-segments (dw segs)
1751 (mapc #'(lambda (seg) (Wand:draw-segment dw seg)) segs))
1753 ;; DrawComposite() composites an image onto the current image, using
1754 ;; the specified composition operator, specified position, and at the
1756 (cffi:defcfun ("DrawComposite" Wand:DrawComposite) MagickBooleanType
1757 (dw DrawingWand) (compose WandCompositeOperator)
1758 (x double) (y double) (width double) (height double) (wand MagickWand))
1760 ;; DrawEllipse() draws an ellipse on the image.
1761 (cffi:defcfun ("DrawEllipse" Wand:draw-ellipse) void
1762 (dw DrawingWand) (ox double) (oy double) (rx double)
1763 (ry double) (start double) (end double))
1765 (cffi:defcfun ("DrawGetFillColor" Wand:DrawGetFillColor) void
1766 (dw DrawingWand) (pixel PixelWand))
1768 (cffi:defcfun ("DrawSetFillColor" Wand:DrawSetFillColor) void
1769 (dw DrawingWand) (pixel pointer))
1771 (defun Wand:draw-fill-color (dw)
1772 (let ((pw (Wand:NewPixelWand)))
1773 (Wand:DrawGetFillColor dw pw)
1776 (defsetf Wand:draw-fill-color (w) (p)
1777 `(Wand:DrawSetFillColor ,w ,p))
1779 (cffi:defcfun ("DrawGetStrokeColor" Wand:DrawGetStrokeColor) void
1780 (dw DrawingWand) (pixel PixelWand))
1782 (cffi:defcfun ("DrawSetStrokeColor" Wand:DrawSetStrokeColor) void
1783 (dw DrawingWand) (pixel pointer))
1785 (defun Wand:draw-stroke-color (dw)
1786 (let ((pw (Wand:NewPixelWand)))
1787 (Wand:DrawGetStrokeColor dw pw)
1790 (defsetf Wand:draw-stroke-color (w) (p)
1791 `(Wand:DrawSetStrokeColor ,w ,p))
1793 (cffi:defcfun ("DrawGetFillOpacity" Wand:draw-fill-opacity) double
1796 (cffi:defcfun ("DrawSetFillOpacity" Wand:DrawSetFillOpacity) void
1797 (dw DrawingWand) (fo double))
1799 (defsetf Wand:draw-fill-opacity (w) (fo)
1800 `(Wand:DrawSetFillOpacity ,w ,fo))
1802 (cffi:defcfun ("DrawMatte" Wand:draw-matte) void
1803 (dw DrawingWand) (x double) (y double) (paint-method PaintMethod))
1805 (cffi:defcfun ("DrawGetStrokeWidth" Wand:draw-stroke-width) double
1808 (cffi:defcfun ("DrawSetStrokeWidth" Wand:DrawSetStrokeWidth) void
1809 (dw DrawingWand) (stroke-width double))
1811 (defsetf Wand:draw-stroke-width (dw) (sw)
1812 `(Wand:DrawSetStrokeWidth ,dw ,sw))
1814 (cffi:defcfun ("DrawGetStrokeOpacity" Wand:draw-stroke-opacity) double
1817 (cffi:defcfun ("DrawSetStrokeOpacity" Wand:DrawSetStrokeOpacity) void
1818 (dw DrawingWand) (stroke-opacity double))
1820 (defsetf Wand:draw-stroke-opacity (dw) (so)
1821 `(Wand:DrawSetStrokeOpacity ,dw ,so))
1823 (cffi:defcfun ("DrawGetStrokeAntialias" Wand:draw-stroke-antialias)
1827 (cffi:defcfun ("DrawSetStrokeAntialias" Wand:DrawSetStrokeAntialias) void
1828 (dw DrawingWand) (aa MagickBooleanType))
1830 (defsetf Wand:draw-stroke-antialias (dw) (aa)
1831 `(Wand:DrawSetStrokeAntialias ,dw ,aa))
1833 (cffi:defcfun ("DrawGetClipPath" Wand:draw-clip-path) safe-string
1836 (cffi:defcfun ("DrawSetClipPath" Wand:DrawSetClipPath) MagickBooleanType
1837 (dw DrawingWand) (clip-path c-string))
1839 (defsetf Wand:draw-clip-path (dw) (cp)
1840 `(Wand:DrawSetClipPath ,dw ,cp))
1842 (cffi:defcfun ("DrawPushClipPath" Wand:draw-push-clip-path) void
1843 (dw DrawingWand) (clip-mask-id c-string))
1845 (cffi:defcfun ("DrawPopClipPath" Wand:draw-pop-clip-path) void
1849 (cffi:defcfun ("PushDrawingWand" Wand:push-drawing-wand) void
1851 (cffi:defcfun ("PopDrawingWand" Wand:pop-drawing-wand) void
1854 (cffi:defcfun ("DrawPushDefs" Wand:draw-push-defs) void
1857 (cffi:defcfun ("DrawPopDefs" Wand:draw-pop-defs) void
1863 ;; I wonder if we actually need this, Wand-API documentation says
1864 ;; yeah, but I've seen gazillions of code snippets not using it
1867 (cffi:defcfun ("MagickWandGenesis" Wand:MagickWandGenesis) void)
1868 (cffi:defcfun ("MagickWandTerminus" Wand:MagickWandTerminus) void))
1872 ;;{{{ Util image, glyph and size related functions
1874 (defun Wand:emacs-image-type (wand)
1875 "Return `rawrgb' or `rawrgba' image type suitable for WAND."
1878 ;; NOTE: 'rawrgba DOES NOT actually works in SXEmacs, so we strip
1881 ; (if (Wand:image-alpha-channel wand)
1885 (defun Wand:emacs-image-internal (wand img-type x y w h)
1886 "Return Emacs image spec."
1888 :data (Wand:get-image-pixels-internal wand img-type x y w h)
1892 (defun Wand:emacs-image (wand)
1893 "Return Emacs image for the WAND."
1894 (Wand:emacs-image-internal
1895 wand (Wand:emacs-image-type wand)
1896 0 0 (Wand:image-width wand) (Wand:image-height wand)))
1898 (defun Wand:glyph-internal (wand x y w h)
1899 "Return glyph for the WAND."
1901 (Wand:emacs-image-internal
1902 wand (Wand:emacs-image-type wand) x y w h)))
1904 (defun Wand:glyph (wand)
1905 "Return glyph for the WAND."
1906 (make-glyph (Wand:emacs-image wand)))
1908 (defun Wand:correct-orientation (wand)
1909 "Automatically rotate WAND image according to exif:Orientation."
1910 (let* ((orient (Wand:image-property wand "exif:Orientation"))
1911 (angle (cond ((string= orient "6") 90)
1912 ((string= orient "3") 180)
1913 ((string= orient "8") -90))))
1915 (setf (Wand:image-property wand "exif:Orientation") "1")
1916 (Wand-operation-apply 'rotate wand angle))))
1918 (defun Wand:fit-size (wand max-width max-height &optional scaler force)
1919 "Fit WAND image into MAX-WIDTH and MAX-HEIGHT.
1920 This operation keeps aspect ratio of the image.
1921 Use SCALER function to perform scaling, by default `Wand:scale-image'
1923 Return non-nil if fiting was performed."
1924 (unless scaler (setq scaler #'Wand:scale-image))
1925 (let* ((width (Wand:image-width wand))
1926 (height (Wand:image-height wand))
1927 (prop (/ (float width) (float height)))
1929 (when (or force (< max-width width))
1930 (setq width max-width
1931 height (round (/ max-width prop))
1933 (when (or force (< max-height height))
1934 (setq width (round (* max-height prop))
1939 (funcall scaler wand width height))
1942 (defun Wand-mode-preview-glyph (wand)
1943 (let ((off-x (get wand 'offset-x))
1944 (off-y (get wand 'offset-y)))
1945 (Wand:glyph-internal
1947 (- (Wand:image-width wand) off-x)
1948 (- (Wand:image-height wand) off-y))))
1951 ;;{{{ Custom variables for Wand-mode
1953 (defgroup Wand-mode nil
1954 "Group to customize Wand mode."
1955 :prefix "Wand-mode-")
1957 (defcustom Wand-mode-redeye-threshold 1.6
1958 "*Threshold to fix red eyes."
1962 (defcustom Wand-mode-sigma 2.0
1963 "*Sigma for operations such as gaussian-blur, sharpen, etc."
1967 (defcustom Wand-mode-zoom-factor 2
1968 "Default zoom in/out factor."
1972 (defcustom Wand-mode-region-outline-color "black"
1973 "*Color used to outline region when selecting."
1977 (defcustom Wand-mode-region-fill-color "white"
1978 "*Color used to fill region when selecting."
1982 (defcustom Wand-mode-region-outline-width 1.3
1983 "*Width of outline line for region when selecting."
1987 (defcustom Wand-mode-region-outline-opacity 0.7
1988 "*Opacity of the outline.
1994 (defcustom Wand-mode-region-fill-opacity 0.35
1995 "*Opacity for the region when selecting.
2001 (defcustom Wand-mode-show-fileinfo t
2002 "*Non-nil to show file info on top of display."
2006 (defcustom Wand-mode-show-iptc-info t
2007 "*Non-nil to display IPTC info if any."
2011 (defcustom Wand-mode-show-operations t
2012 "*Non-nil to show operations done on file."
2016 (defcustom Wand-mode-auto-fit t
2017 "*Non-nil to perform fiting to window size.
2018 You can always toggle fitting using `Wand-mode-toggle-fit' command
2019 \(bound to \\<Wand-mode-map>\\[Wand-mode-toggle-fit]\)."
2023 (defcustom Wand-mode-auto-rotate t
2024 "*Non-nil to perform automatic rotation according to orientation.
2025 Orientation is taken from EXIF."
2029 (defcustom Wand-mode-query-for-overwrite t
2030 "*Non-nil to ask user when overwriting existing files."
2034 (defcustom Wand-mode-properties-pattern "^exif:"
2035 "Pattern for properties editor."
2039 (defvar Wand-global-operations-list nil
2040 "Denotes global operations list")
2042 (defcustom Wand-mode-scaler #'Wand:scale-image
2043 "Function used to scale image for \"fit to size\" operation.
2044 You could use one of `Wand:scale-image', `Wand:sample-image' or create
2045 your own scaler with `Wand-make-scaler'."
2049 (defvar Wand-mode-hook nil
2050 "Hooks to call when entering `Wand-mode'.")
2052 (defvar Wand-insert-info-hook nil
2053 "Hooks to call when inserting info into `Wand-mode'.")
2058 (defvar Wand-mode-map
2059 (let ((map (make-sparse-keymap)))
2060 ;; Undo/Redo operation
2061 (define-key map [(control /)] #'Wand-mode-undo)
2062 (define-key map [(control _)] #'Wand-mode-undo)
2063 (define-key map [undo] #'Wand-mode-undo)
2064 (define-key map [(control ?x) (control ?/)] #'Wand-mode-redo)
2065 (define-key map [(control ?x) (meta ?:)] #'Wand-mode-repeat-last-operation)
2066 (define-key map [(control ?\.)] #'Wand-mode-repeat-last-operation)
2069 (define-key map [(control ?x) (control ?s)] #'Wand-mode-save-file)
2070 (define-key map [(control ?x) (control ?w)] #'Wand-mode-write-file)
2073 (define-key map [space] #'Wand-mode-next-image)
2074 (define-key map [backspace] #'Wand-mode-prev-image)
2075 (define-key map [(meta ?<)] #'Wand-mode-first-image)
2076 (define-key map [(meta >)] #'Wand-mode-last-image)
2078 (define-key map [next] #'Wand-mode-next-page)
2079 (define-key map [prior] #'Wand-mode-prev-page)
2080 (define-key map [home] #'Wand-mode-first-page)
2081 (define-key map [end] #'Wand-mode-last-page)
2082 (define-key map [?g] #'Wand-mode-goto-page)
2083 (define-key map [(meta ?g)] #'Wand-mode-goto-page)
2086 (define-key map [button1] #'Wand-mode-select-region)
2087 (define-key map [(control meta ?z)] #'Wand-mode-activate-region)
2090 (define-key map [button3] #'Wand-mode-popup-menu)
2091 (define-key map [(meta button1)] #'Wand-mode-drag-image)
2092 (define-key map [(control button1)] #'Wand-mode-drag-image)
2093 (define-key map [o] #'Wand-mode-operate)
2094 (define-key map [O] #'Wand-mode-global-operations-list)
2095 (define-key map [x] #'Wand-mode-toggle-fit)
2096 (define-key map [i] #'Wand-mode-identify)
2097 (define-key map [e] #'Wand-mode-prop-editor)
2098 (define-key map [q] #'Wand-mode-quit)
2099 (define-key map [(control ?r)] #'Wand-mode-reload)
2100 (define-key map [p] #'Wand-mode-add-iptc-tag)
2103 (define-key map [+] #'Wand-mode-zoom-in)
2104 (define-key map [-] #'Wand-mode-zoom-out)
2107 (define-key map [r] #'Wand-mode-rotate-right)
2108 (define-key map [l] #'Wand-mode-rotate-left)
2110 ;; Region operations
2111 (define-key map [c] #'Wand-mode-crop)
2112 (define-key map [\.] #'Wand-mode-redeye-remove)
2115 "Keymap for Wand mode.")
2122 ["Next" Wand-mode-next-image
2123 :active (Wand-next-file buffer-file-name)]
2124 ["Previous" Wand-mode-prev-image
2125 :active (Wand-next-file buffer-file-name t)]
2126 ["First" Wand-mode-first-image]
2127 ["Last" Wand-mode-last-image]
2128 ("Page" :filter Wand-menu-page-navigations)
2130 ["Image Info" Wand-mode-identify]
2131 ["Reload" Wand-mode-reload]
2132 ["Fitting" Wand-mode-toggle-fit
2133 :style toggle :selected (get image-wand 'fitting)]
2135 ["Undo" Wand-mode-undo :active operations-list]
2136 ["Redo" Wand-mode-redo :active undo-list]
2137 ["Save Image" Wand-mode-save-file]
2138 ["Save Image As" Wand-mode-write-file]
2140 ["Zoom In" Wand-mode-zoom-in]
2141 ["Zoom Out" Wand-mode-zoom-out]
2143 ["Rotate right" Wand-mode-rotate-right]
2144 ["Rotate left" Wand-mode-rotate-left]
2146 ("Region" :filter Wand-menu-region-operations)
2147 ("Transform" :filter (lambda (not-used)
2148 (Wand-menu-generate 'transform-operation)))
2149 ("Effects" :filter (lambda (not-used)
2150 (Wand-menu-generate 'effect-operation)))
2151 ("Enhance" :filter (lambda (not-used)
2152 (Wand-menu-generate 'enhance-operation)))
2153 ("F/X" :filter (lambda (not-used)
2154 (Wand-menu-generate 'f/x-operation)))
2156 ["Quit" Wand-mode-quit])
2157 "Menu for Wand display mode.")
2159 (defun Wand-menu-page-navigations (not-used)
2160 "Generate menu for page navigation."
2161 (list ["Next Page" Wand-mode-next-page
2162 :active (Wand:has-next-image image-wand)]
2163 ["Previous Page" Wand-mode-prev-page
2164 :active (Wand:has-prev-image image-wand)]
2165 ["First Page" Wand-mode-first-page
2166 :active (/= (Wand:iterator-index image-wand) 0) ]
2167 ["Last Page" Wand-mode-last-page
2168 :active (/= (Wand:iterator-index image-wand)
2169 (1- (Wand:images-num image-wand))) ]
2171 ["Goto Page" Wand-mode-goto-page
2172 :active (/= (Wand:images-num image-wand) 1)]))
2174 (defun Wand-menu-region-operations (not-used)
2175 "Generate menu for region operations."
2176 (mapcar #'(lambda (ro)
2177 (vector (get ro 'menu-name) ro :active 'preview-region))
2178 (apropos-internal "^Wand-mode-"
2181 (get c 'region-operation)
2182 (get c 'menu-name))))))
2184 (defun Wand-mode-commands-by-tag (tag)
2185 "Return list of wand command for which TAG property is set."
2186 (apropos-internal "^Wand-mode-"
2187 #'(lambda (c) (and (commandp c) (get c tag)))))
2189 (defun Wand-menu-generate (tag)
2190 "Generate menu structure for TAG commands."
2191 (mapcar #'(lambda (to)
2192 (vector (get to 'menu-name) to))
2193 (remove-if-not #'(lambda (c) (get c tag))
2194 (Wand-mode-commands-by-tag 'menu-name))))
2196 (defun Wand-mode-popup-menu (be)
2199 (popup-menu Wand-menu be))
2202 ;;{{{ Operations definitions
2204 (defmacro define-Wand-operation (name args &rest body)
2205 "Define new operation of NAME.
2206 ARGS specifies arguments to operation, first must always be wand."
2207 (let ((fsym (intern (format "Wand-op-%S" name))))
2211 (defmacro Wand-possible-for-region (wand &rest body)
2213 (let* ((iwand ,wand)
2214 (region (Wand-mode-image-region))
2215 (wand (apply #'Wand:image-region iwand region)))
2219 (Wand:image-composite iwand wand :CopyCompositeOp
2220 (nth 2 region) (nth 3 region)))
2221 (setq preview-region nil)
2222 (Wand:delete-wand wand)))
2224 (put 'Wand-possible-for-region 'lisp-indent-function 'defun)
2226 (define-Wand-operation flip (wand)
2228 (Wand-possible-for-region wand
2229 (Wand:flip-image wand)))
2231 (define-Wand-operation flop (wand)
2233 (Wand-possible-for-region wand
2234 (Wand:flop-image wand)))
2236 (define-Wand-operation rotate (wand degree)
2237 "Rotate image by DEGREE.
2238 This is NOT lossless rotation for jpeg-like formats."
2239 (Wand-with-pixel-wand pw
2240 (setf (Wand:pixel-color pw) "black")
2241 (Wand:RotateImage wand pw (float degree))))
2243 (define-Wand-operation contrast (wand cp)
2244 "Increase/decrease contrast of the image."
2245 (Wand-possible-for-region wand
2246 (Wand:MagickContrastImage wand cp)))
2248 (define-Wand-operation normalize (wand)
2250 (Wand-possible-for-region wand
2251 (Wand:normalize-image wand)))
2253 (define-Wand-operation despeckle (wand)
2255 (Wand-possible-for-region wand
2256 (Wand:despeckle-image wand)))
2258 (define-Wand-operation enhance (wand)
2260 (Wand-possible-for-region wand
2261 (Wand:enhance-image wand)))
2263 (define-Wand-operation equalize (wand)
2265 (Wand-possible-for-region wand
2266 (Wand:equalize-image wand)))
2268 (define-Wand-operation gauss-blur (wand radius sigma)
2270 (Wand-possible-for-region wand
2271 (Wand:gaussian-blur-image wand (float radius) (float sigma))))
2273 (define-Wand-operation sharpen (wand radius sigma)
2275 (Wand-possible-for-region wand
2276 (Wand:sharpen-image wand (float radius) (float sigma))))
2278 (define-Wand-operation radial-blur (wand angle)
2280 (Wand-possible-for-region wand
2281 (Wand:radial-blur-image wand (float angle))))
2283 (define-Wand-operation negate (wand greyp)
2285 (Wand-possible-for-region wand
2286 (Wand:negate-image wand greyp)))
2288 (define-Wand-operation modulate (wand mtype minc)
2289 "Modulate the image WAND using MTYPE by MINC."
2290 (Wand-possible-for-region wand
2291 (Wand:modulate-image wand mtype (float (+ 100 minc)))))
2293 (define-Wand-operation grayscale (wand)
2295 (Wand-possible-for-region wand
2296 (Wand:SetImageColorspace wand :GRAYColorspace)))
2298 (define-Wand-operation solarize (wand threshold)
2299 "Solarise image by THRESHOLD."
2300 (Wand-possible-for-region wand
2301 (Wand:solarize-image wand (float threshold))))
2303 (define-Wand-operation swirl (wand degrees)
2305 (Wand-possible-for-region wand
2306 (Wand:swirl-image wand (float degrees))))
2308 (define-Wand-operation oil (wand radius)
2309 "Simulate oil-painting of image."
2310 (Wand-possible-for-region wand
2311 (Wand:oil-paint-image wand (float radius))))
2313 (define-Wand-operation charcoal (wand radius sigma)
2314 "Simulate charcoal painting of image."
2315 (Wand-possible-for-region wand
2316 (Wand:charcoal-image wand (float radius) (float sigma))))
2318 (define-Wand-operation sepia-tone (wand threshold)
2319 "Apply sepia tone to image by THRESHOLD."
2320 (Wand-possible-for-region wand
2321 (Wand:sepia-tone-image wand (float threshold))))
2323 (define-Wand-operation implode (wand radius)
2324 "Implude image by RADIUS."
2325 (Wand-possible-for-region wand
2326 (Wand:implode-image wand (float radius))))
2328 (define-Wand-operation wave (wand amplitude wave-length)
2329 "Create wave effect for image with AMPLITUDE and WAVE-LENGTH."
2330 (Wand-possible-for-region wand
2331 (Wand:wave-image wand (float amplitude) (float wave-length))))
2333 (define-Wand-operation vignette (wand white black x y)
2334 "Vignette from image."
2335 (Wand-possible-for-region wand
2336 (Wand:vignette-image wand (float white) (float black) (float x) (float y))))
2338 (define-Wand-operation edge (wand radius)
2339 "Enhance the edges of the image."
2340 (Wand-possible-for-region wand
2341 (Wand:edge-image wand (float radius))))
2343 (define-Wand-operation emboss (wand radius sigma)
2344 "Emboss the image, i.e. add relief."
2345 (Wand-possible-for-region wand
2346 (Wand:emboss-image wand (float radius) (float sigma))))
2348 (define-Wand-operation reduce-noise (wand radius)
2349 "Reduce noise in the image."
2350 (Wand-possible-for-region wand
2351 (Wand:reduce-noise-image wand (float radius))))
2353 (define-Wand-operation add-noise (wand noise-type)
2354 "Add noise to image."
2355 (Wand-possible-for-region wand
2356 (Wand:add-noise-image wand noise-type)))
2358 (define-Wand-operation spread (wand radius)
2360 (Wand-possible-for-region wand
2361 (Wand:spread-image wand (float radius))))
2363 (define-Wand-operation trim (wand fuzz)
2365 (Wand-possible-for-region wand
2366 (Wand:trim-image wand (float fuzz))))
2368 (define-Wand-operation raise (wand raise)
2370 (Wand-possible-for-region wand
2371 (Wand:raise-image wand raise)))
2373 (define-Wand-operation crop (wand region)
2374 "Crop image to REGION."
2375 (apply #'Wand:crop-image wand region)
2376 (Wand:reset-image-page wand))
2378 (define-Wand-operation chop (wand region)
2379 "Chop REGION in the image."
2380 (apply #'Wand:chop-image wand region))
2382 (define-Wand-operation preview-op (wand ptype)
2383 "Preview operation PTYPE.
2385 (Wand-possible-for-region wand
2386 (Wand:preview-images
2387 wand (cdr (assoc ptype MagickPreviewType-completion-table)))))
2389 (defun Wand:get-image-rgb-pixels (wand x y w h)
2390 "Extract RGB pixels from WAND."
2391 (let ((target (make-ffi-object 'c-data (* w h 3))))
2392 (when (Wand:MagickGetImagePixels
2393 wand x y w h "RGB" :char-pixel target)
2394 (Wand:pixels-extract-colors (ffi-get target) 3))))
2396 (defun Wand:get-rgb-pixel-at (wand x y)
2397 "Return WAND's RGB pixel at X, Y."
2398 (car (Wand:get-image-rgb-pixels wand x y 1 1)))
2400 (defun Wand-fix-red-pixels (pixels)
2401 "Simple red PIXELS fixator.
2402 Normalize pixel color if it is too 'red'."
2403 (let* ((rchan '(0.1 0.6 0.3))
2404 (gchan '(0.0 1.0 0.0))
2405 (bchan '(0.0 0.0 1.0))
2406 (rnorm (/ 1.0 (apply #'+ rchan)))
2407 (gnorm (/ 1.0 (apply #'+ gchan)))
2408 (bnorm (/ 1.0 (apply #'+ bchan))))
2409 (flet ((normalize (chan norm r g b)
2410 (min 255 (int (* norm (+ (* (first chan) r)
2412 (* (third chan) b)))))))
2413 (mapcar #'(lambda (pixel-value)
2414 (multiple-value-bind (r g b) pixel-value
2415 (if (>= r (* Wand-mode-redeye-threshold g))
2416 (list (normalize rchan rnorm r g b)
2417 (normalize gchan gnorm r g b)
2418 (normalize bchan bnorm r g b))
2422 (defun Wand-mode-redeye-blur-radius (w h)
2423 "Return apropriate blur radius for region of width W and height H.
2424 It should not be too large for large regions, and it should not be
2425 too small for small regions."
2426 (1- (sqrt (sqrt (sqrt (sqrt (* w h)))))))
2428 (define-Wand-operation redeye-remove (wand region)
2429 "Remove redeye in the REGION."
2430 (multiple-value-bind (w h x y) region
2432 ;; Consitute new wand with fixed red pixels
2433 (Wand:MagickConstituteImage
2434 cw w h "RGB" :char-pixel
2435 (let ((stor (make-ffi-object 'c-data (* w h 3))))
2436 (ffi-set stor (Wand:pixels-arrange-colors
2437 (Wand-fix-red-pixels
2438 (Wand:get-image-rgb-pixels wand x y w h))))
2441 ;; Limit blur effect to ellipse at the center of REGION by
2442 ;; setting clip mask
2443 (let ((mask (Wand:copy-wand cw)))
2446 (Wand-with-drawing-wand dw
2447 (Wand-with-pixel-wand pw
2448 (setf (Wand:pixel-color pw) "white")
2449 (setf (Wand:draw-fill-color dw) pw)
2450 (Wand:draw-color dw 0.0 0.0 :ResetMethod))
2451 (Wand-with-pixel-wand pw
2452 (setf (Wand:pixel-color pw) "black")
2453 (setf (Wand:draw-fill-color dw) pw))
2455 dw (/ w 2.0) (/ h 2.0) (/ w 2.0) (/ h 2.0) 0.0 360.0)
2456 (Wand:MagickDrawImage mask dw))
2457 (setf (Wand:clip-mask cw) mask))
2458 (Wand:delete-wand mask)))
2460 (Wand:gaussian-blur-image
2461 cw 0.0 (Wand-mode-redeye-blur-radius w h))
2462 (setf (Wand:clip-mask cw) nil)
2464 ;; Finally copy blured image to WAND
2465 (Wand:image-composite wand cw :CopyCompositeOp x y))))
2467 (define-Wand-operation zoom (wand outp factor)
2468 (let ((nw (funcall (if outp #'/ #'*)
2469 (Wand:image-width wand) (float factor)))
2470 (nh (funcall (if outp #'/ #'*)
2471 (Wand:image-height wand) (float factor))))
2472 (Wand:scale-image wand (round nw) (round nh))))
2474 (define-Wand-operation sample (wand width height)
2475 (Wand:scale-image wand width height))
2477 (defmacro Wand-make-scaler (filter-type blur)
2478 "Create resize function, suitable with `Wand:fit-resize'.
2479 FILTER-TYPE and BLUR specifies smothing applied after resize.
2480 FILTER-TYPE is one of: :PointFilter, :BoxFilter, :TriangleFilter,
2481 :HermiteFilter, :HanningFilter, :HammingFilter, :BlackmanFilter,
2482 :GaussianFilter, :QuadraticFilter, :CubicFilter, :CatromFilter,
2483 :MitchellFilter, :LanczosFilter, :BesselFilter, :SincFilter,
2484 :KaiserFilter, :WelshFilter, :ParzenFilter, :LagrangeFilter,
2485 :BohmanFilter, :BartlettFilter, :SentinelFilter.
2486 BLUR is float, 0.25 for insane pixels, > 2.0 for excessively smoth."
2488 (Wand:resize-image iw x y ,filter-type (float ,blur))))
2490 (define-Wand-operation fit-size (wand width height)
2491 (Wand:fit-size wand width height Wand-mode-scaler t))
2493 (define-Wand-operation liquid-rescale (wand width height)
2495 (Wand:liquid-rescale wand width height 0.0 0.0)))
2497 (define-Wand-operation posterize (wand levels &optional ditherp)
2498 (Wand:posterize-image wand levels ditherp))
2500 (defvar Wand-pattern-composite-op "dst-over")
2502 (defvar Wand-patterns
2503 (mapcar (lambda (x) (list (symbol-name x)))
2504 '(bricks checkerboard circles crosshatch crosshatch30 crosshatch45
2505 fishscales gray0 gray5 gray10 gray15 gray20 gray25 gray30
2506 gray35 gray40 gray45 gray50 gray55 gray60 gray65 gray70
2507 gray75 gray80 gray85 gray90 gray95 gray100 hexagons horizontal
2508 horizontalsaw hs_bdiagonal hs_cross
2509 hs_diagcross hs_fdiagonal hs_horizontal hs_vertical left30
2510 left45 leftshingle octagons right30 right45 rightshingle
2511 smallfishscales vertical verticalbricks
2512 verticalleftshingle verticalrightshingle verticalsaw)))
2514 (define-Wand-operation pattern (wand pattern op)
2515 (Wand-with-wand cb-wand
2516 (setf (Wand:image-size cb-wand)
2517 (cons (Wand:image-width wand) (Wand:image-height wand)))
2518 (Wand:MagickReadImage cb-wand (concat "pattern:" pattern))
2519 (Wand:image-composite wand cb-wand
2520 (cdr (assoc op WandCompositeOperator-completion-table)) 0 0)))
2523 ;;{{{ Operations list functions
2525 (defun Wand-operation-lookup (opname)
2526 (intern (format "Wand-op-%S" opname)))
2528 (defun Wand-operation-apply (operation wand &rest args)
2529 "Apply OPERATION to WAND using addition arguments ARGS."
2530 (setq operations-list
2531 (append operations-list (list (cons operation args))))
2532 (setq undo-list nil) ; Reset undo
2533 (apply (Wand-operation-lookup operation) wand args))
2535 (defun Wand-operation-list-apply (wand &optional operations)
2536 "Apply all operations in OPERATIONS list."
2537 (dolist (op (or operations operations-list))
2538 (apply (Wand-operation-lookup (car op))
2542 ;;{{{ Helper functions
2544 (defun Wand-mode-image-region ()
2545 "Return region in real image, according to `preview-region'."
2546 (let ((off-x (get preview-wand 'offset-x))
2547 (off-y (get preview-wand 'offset-y))
2548 (xcoeff (// (Wand:image-width image-wand)
2549 (Wand:image-width preview-wand)))
2550 (ycoeff (// (Wand:image-height image-wand)
2551 (Wand:image-height preview-wand))))
2552 (mapcar #'round (list (* (nth 0 preview-region) xcoeff)
2553 (* (nth 1 preview-region) ycoeff)
2554 (* (+ (nth 2 preview-region) off-x) xcoeff)
2555 (* (+ (nth 3 preview-region) off-y) ycoeff)))))
2557 (defun Wand-mode-file-info ()
2558 "Return info about file as a string."
2559 (declare (special off-x))
2560 (declare (special off-y))
2561 (let ((iw (Wand:image-width image-wand))
2562 (ih (Wand:image-height image-wand))
2563 (ow (Wand:image-orig-width image-wand))
2564 (oh (Wand:image-orig-height image-wand)))
2565 (concat "File: " (file-name-nondirectory buffer-file-name)
2566 " (" (Wand:get-magick-property image-wand "size") "), "
2567 (Wand:image-format image-wand)
2568 " " (format "%dx%d" iw ih)
2569 (if (and (not (zerop ow)) (not (zerop oh))
2570 (or (/= ow iw) (/= oh ih)))
2571 (format " (Orig: %dx%d)" ow oh)
2573 (if (> (Wand:images-num image-wand) 1)
2574 (format ", Page: %d/%d" (1+ (Wand:iterator-index image-wand))
2575 (Wand:images-num image-wand))
2577 ;; Print offset info
2578 (if (and preview-wand (boundp 'off-x) (boundp 'off-y)
2579 (or (positivep off-x) (positivep off-y)))
2580 (format ", Offset: +%d+%d" off-x off-y)
2582 ;; Print region info
2584 (apply #'format ", Region: %dx%d+%d+%d"
2585 (Wand-mode-image-region))
2588 (defun Wand-mode-iptc-split-keywords (tag-value)
2589 (mapcar #'(lambda (kw) (cons 'keyword kw))
2591 (split-string tag-value "\\(, \\|,\\)"))))
2593 (defun Wand-mode-iptc-from-widgets (widgets)
2594 "Return profile made up from WIDGETS info."
2597 (let ((iptc-tag (widget-get widget :iptc-tag))
2598 (tag-value (widget-get widget :value)))
2599 (cond ((string= tag-value "") nil)
2600 ((eq iptc-tag 'keywords)
2601 ;; Special case for keywords
2602 (Wand-mode-iptc-split-keywords tag-value))
2603 (t (list (cons iptc-tag tag-value))))))
2606 (defun Wand-mode-iptc-notify (wid &rest args)
2607 "Called when some IPTC info changed."
2608 (Wand:image-save-iptc-profile
2609 image-wand (Wand-mode-iptc-from-widgets (cons wid widget-field-list)))
2610 (Wand-mode-update-info))
2612 (defun Wand-mode-insert-iptc-tags ()
2613 "Insert iptc tags info."
2614 (kill-local-variable 'widget-global-map)
2615 (kill-local-variable 'widget-field-new)
2616 (kill-local-variable 'widget-field-last)
2617 (kill-local-variable 'widget-field-was)
2618 (kill-local-variable 'widget-field-list)
2620 (let* ((iptc (Wand:image-profile-iptc image-wand))
2621 (cpt (cdr (assq 'caption iptc)))
2622 (kws (mapcar #'cdr (remove-if-not
2623 #'(lambda (e) (eq 'keyword (car e)))
2626 (widget-create 'editable-field
2628 :format "IPTC Caption: %v"
2630 :notify #'Wand-mode-iptc-notify
2633 (widget-create 'editable-field
2634 :format "IPTC Keywords: %v"
2637 :notify #'Wand-mode-iptc-notify
2638 (mapconcat #'identity kws ", ")))
2641 (defun Wand-mode-add-iptc-tag (tag value)
2642 "Add TAG to ITPC profile."
2643 (interactive (list (completing-read
2644 "IPTC Tag: " '(("caption") ("keywords")) nil t)
2645 (read-string "ITPC Tag value: ")))
2646 (let ((tags-val (cond ((string= tag "caption")
2647 (list (cons 'caption value)))
2648 ((string= tag "keywords")
2649 (Wand-mode-iptc-split-keywords value))
2650 (t (error "Invalid IPTC tag")))))
2651 (Wand:image-save-iptc-profile
2652 image-wand (nconc (Wand-mode-iptc-from-widgets widget-field-list)
2654 (Wand-mode-update-info)))
2656 (defun Wand-mode-insert-info ()
2657 "Insert some file informations."
2658 (when Wand-mode-show-fileinfo
2659 (insert (Wand-mode-file-info) "\n"))
2660 (when Wand-mode-show-iptc-info
2661 (Wand-mode-insert-iptc-tags))
2663 ;; XXX iptc may set those below again
2664 (let ((inhibit-read-only t)
2665 (before-change-functions nil)
2666 (after-change-functions nil))
2668 (when (and Wand-mode-show-operations)
2669 (when operations-list
2670 (insert (format "Operations: %S" operations-list) "\n"))
2671 (when Wand-global-operations-list
2672 (insert (format "Global operations: %S"
2673 Wand-global-operations-list) "\n")))
2675 ;; Info about pickup color
2676 (when (boundp 'pickup-color)
2677 (declare (special pickup-color))
2678 (let* ((cf (make-face (gensym "dcolor-") nil t))
2679 (place (car pickup-color))
2680 (color (cdr pickup-color))
2681 (fcol (apply #'format "#%02x%02x%02x" color)))
2682 (set-face-background cf fcol)
2683 (insert (format "Color: +%d+%d " (car place) (cdr place)))
2684 (insert-face " " cf)
2685 (insert (format " %s R:%d, G:%d, B:%d\n" fcol
2686 (car color) (cadr color) (caddr color)))))
2688 (run-hooks 'Wand-insert-info-hook)))
2690 (defun Wand-mode-update-info ()
2691 "Only update info region."
2692 (let ((inhibit-read-only t)
2693 before-change-functions
2694 after-change-functions)
2695 (mapc 'widget-delete widget-field-list)
2697 (goto-char (point-min))
2698 (delete-region (point-at-bol)
2700 (goto-char (point-max))
2702 (Wand-mode-insert-info))
2703 (set-buffer-modified-p nil)))
2705 (defun Wand-mode-update-file-info ()
2707 (when Wand-mode-show-fileinfo
2708 (let ((inhibit-read-only t)
2709 before-change-functions
2710 after-change-functions)
2712 (goto-char (point-min))
2713 (delete-region (point-at-bol) (point-at-eol))
2714 (insert (Wand-mode-file-info))))
2715 (set-buffer-modified-p nil)))
2717 (defun Wand-mode-preview-with-region ()
2718 "Return highlighted version of `preview-wand' in case region is selected."
2719 (when preview-region
2720 (multiple-value-bind (w h x y) preview-region
2721 ;; Take into account current offset
2722 (incf x (get preview-wand 'offset-x))
2723 (incf y (get preview-wand 'offset-y))
2724 (Wand-with-drawing-wand dw
2725 (Wand-with-pixel-wand pw
2726 (setf (Wand:pixel-color pw) Wand-mode-region-outline-color)
2727 (Wand:DrawSetStrokeColor dw pw))
2728 (Wand-with-pixel-wand pw
2729 (setf (Wand:pixel-color pw) Wand-mode-region-fill-color)
2730 (setf (Wand:draw-fill-color dw) pw))
2731 (setf (Wand:draw-stroke-width dw) Wand-mode-region-outline-width
2732 (Wand:draw-stroke-opacity dw) Wand-mode-region-outline-opacity
2733 (Wand:draw-fill-opacity dw) Wand-mode-region-fill-opacity)
2734 (Wand:draw-lines dw (list (cons x y) (cons (+ x w) y)
2735 (cons (+ x w) (+ y h)) (cons x (+ y h))
2737 (let ((nw (Wand:copy-wand preview-wand)))
2738 (put nw 'offset-x (get preview-wand 'offset-x))
2739 (put nw 'offset-y (get preview-wand 'offset-y))
2740 (Wand:MagickDrawImage nw dw)
2743 (defun Wand-mode-insert-preview ()
2744 "Display wand W at the point."
2745 ;; NOTE: if size not changed, then keep offset-x and offset-y
2747 (let ((saved-w (and preview-wand (Wand:image-width preview-wand)))
2748 (saved-h (and preview-wand (Wand:image-height preview-wand)))
2749 (off-x (or (get preview-wand 'offset-x) 0))
2750 (off-y (or (get preview-wand 'offset-y) 0)))
2751 ;; Delete old preview and create new one
2752 (when preview-wand (Wand:delete-wand preview-wand))
2753 (setq preview-wand (Wand:get-image image-wand))
2756 ;; If last character is \n, try to remove it before calculating
2757 ;; displayed-text-pixel-height, and then restore
2758 ;; Rescale preview to fit the window
2759 (let ((scale-h (- (window-text-area-pixel-height)
2760 (if (zerop (buffer-size)) 0
2763 (backward-delete-char)
2764 (window-displayed-text-pixel-height))
2766 (scale-w (window-text-area-pixel-width)))
2767 (when (and (get image-wand 'fitting)
2768 (Wand:fit-size preview-wand scale-w scale-h))
2769 (message "Rescale to %dx%d"
2770 (Wand:image-width preview-wand)
2771 (Wand:image-height preview-wand))))
2773 ;; Set offset properties
2774 (if (and (eq saved-w (Wand:image-width preview-wand))
2775 (eq saved-h (Wand:image-height preview-wand)))
2776 (progn (put preview-wand 'offset-x off-x)
2777 (put preview-wand 'offset-y off-y))
2778 (put preview-wand 'offset-x 0)
2779 (put preview-wand 'offset-y 0))
2781 ;; Hackery to insert invisible char, so widget-delete won't affect
2782 ;; preview-glyph visibility
2783 (let ((ext (make-extent (point) (progn (insert " ") (point)))))
2784 (set-extent-property ext 'invisible t)
2785 (set-extent-property ext 'start-open t))
2787 (let ((pwr (Wand-mode-preview-with-region)))
2790 (set-extent-end-glyph
2791 preview-extent (Wand-mode-preview-glyph (or pwr preview-wand)))
2792 (set-extent-endpoints
2793 preview-extent (point) (point) (current-buffer)))
2794 (when pwr (Wand:delete-wand pwr))))))
2796 (defun Wand-redisplay (&optional wand)
2797 "Redisplay Wand buffer with possible a new WAND."
2799 ;; A new wand in the air
2800 (map-plist (lambda (k v) (put wand k v)) (object-plist image-wand))
2801 (Wand:delete-wand image-wand)
2802 (setq image-wand wand))
2804 (let ((inhibit-read-only t)
2805 before-change-functions
2806 after-change-functions)
2808 (Wand-mode-insert-info)
2809 (Wand-mode-insert-preview)
2810 (goto-char (point-min)))
2811 (set-buffer-modified-p nil))
2814 (defun Wand-display-noselect (file)
2815 (let* ((bn (format "*Wand: %s*" (file-name-nondirectory file)))
2816 (buf (if (and (eq major-mode 'Wand-mode)
2817 (not (get-buffer bn)))
2818 ;; Use current buffer
2822 (get-buffer-create bn))))
2823 (with-current-buffer buf
2824 (unless (eq major-mode 'Wand-mode)
2825 ;; Initialise local variables
2826 (kill-all-local-variables)
2827 (make-variable-buffer-local 'image-wand)
2828 (make-variable-buffer-local 'preview-wand)
2829 (make-variable-buffer-local 'preview-region)
2830 (make-variable-buffer-local 'preview-extent)
2831 (make-variable-buffer-local 'operations-list)
2832 (make-variable-buffer-local 'undo-list)
2833 (make-variable-buffer-local 'kill-buffer-hook)
2834 (setq operations-list nil)
2835 (setq undo-list nil)
2836 (setq preview-wand nil)
2837 (setq preview-extent (make-extent 0 0 ""))
2838 (setq image-wand (Wand:make-wand))
2839 (put image-wand 'fitting Wand-mode-auto-fit)
2841 (use-local-map Wand-mode-map)
2842 (setq mode-name "Wand")
2843 (setq major-mode 'Wand-mode)
2844 (setq buffer-read-only t)
2846 (when (featurep 'menubar)
2847 (set-buffer-menubar current-menubar)
2848 (add-submenu '() Wand-menu)
2849 (setq mode-popup-menu Wand-menu))
2850 (add-hook 'kill-buffer-hook 'Wand-mode-cleanup))
2853 (Wand:delete-wand preview-wand))
2854 (setq preview-wand nil)
2855 (setq preview-region nil)
2856 (setq operations-list nil)
2857 (setq undo-list nil)
2858 (Wand:clear-wand image-wand)
2859 ;; Fix buffer-file-name in case of viewing directory
2860 (when (file-directory-p file)
2861 (setq file (or (Wand-next-file (concat file "/.")) file)))
2862 (setq buffer-file-name file)
2863 (setq default-directory (file-name-directory file))
2865 (unless (Wand:read-image image-wand file)
2866 (kill-buffer (current-buffer))
2867 (error "Can't read file %s" file))
2868 (when Wand-mode-auto-rotate
2869 (Wand:correct-orientation image-wand))
2871 ;; Apply operations in case global operations list is used
2872 (mapc #'(lambda (op)
2873 (apply #'Wand-operation-apply
2874 (car op) image-wand (cdr op)))
2875 Wand-global-operations-list)
2880 (run-hooks 'Wand-mode-hook))
2884 (defun Wand-display (file)
2885 (interactive "fImage file: ")
2886 (switch-to-buffer (Wand-display-noselect file) t))
2889 "Start `Wand-display' on filename associated with current buffer.
2893 (Wand-display (buffer-file-name)))
2896 (defun Wand-find-file-enable ()
2897 "Enable `find-file' to use `Wand-display' for supported filetypes."
2898 (push '(Wand-file-supported-for-read-p . Wand-display-noselect)
2899 find-file-magic-files-alist))
2901 (defun Wand-mode-cleanup ()
2902 "Cleanup when wand buffer is killed."
2903 (when (extentp preview-extent)
2904 (delete-extent preview-extent))
2906 (Wand:delete-wand preview-wand))
2907 (Wand:delete-wand image-wand))
2909 (defun Wand-mode-quit ()
2910 "Quit Wand display mode."
2912 (kill-buffer (current-buffer)))
2914 (defun Wand-mode-reload ()
2915 "Reload and redisplay image file."
2917 (Wand-display buffer-file-name))
2919 (defun Wand-mode-identify ()
2920 "Show info about image."
2922 (let ((iw image-wand))
2923 (with-displaying-help-buffer
2925 (set-buffer standard-output)
2926 (insert (Wand:identify-image iw)))
2929 (defun Wand-mode-operations-table ()
2930 "Return completion table for Wand operations."
2931 (mapcar #'(lambda (to)
2932 (cons (downcase (get to 'menu-name)) to))
2933 (Wand-mode-commands-by-tag 'menu-name)))
2935 (defun Wand-mode-operate (op-name)
2937 (interactive (list (completing-read
2938 "Operation: " (Wand-mode-operations-table)
2940 (let ((op (assoc op-name (Wand-mode-operations-table))))
2941 (let ((current-prefix-arg current-prefix-arg))
2942 (call-interactively (cdr op)))))
2944 (defcustom Wand-formats-read-unsupported
2945 '("a" "b" "c" "g" "h" "o" "k" "m" "r" "x" "y" "txt" "text" "pm")
2946 "List of formats that are not intented to be opened by Wand."
2947 :type '(list string)
2950 (defun Wand-format-supported-for-read-p (format)
2951 "Return non-nil if Wand can read files in FORMAT."
2952 (unless (member (downcase format) Wand-formats-read-unsupported)
2953 (let ((fi (Wand:GetMagickInfo
2954 format (ffi-address-of
2955 (make-ffi-object 'MagickExceptionInfo)))))
2956 (and (not (ffi-null-p fi))
2957 (not (ffi-null-p (MagickInfo->decoder fi)))
2959 ;; ImageMagick on linux treats any format to be RAW for some reason
2960 ;; We can't read raw formats
2961 ; (not (MagickInfo->raw fi))))))
2963 (defcustom Wand-formats-write-unsupported
2965 "List of formats that are not intented to be written by Wand."
2966 :type '(list string)
2969 (defun Wand-format-supported-for-write-p (format)
2970 "Return non-nil if Wand can write files in FORMAT."
2971 (unless (member (downcase format) Wand-formats-write-unsupported)
2972 (let ((fi (Wand:GetMagickInfo
2973 format (ffi-address-of
2974 (make-ffi-object 'MagickExceptionInfo)))))
2975 (and (not (ffi-null-p fi))
2976 (not (ffi-null-p (MagickInfo->encoder fi)))))))
2979 (defun Wand-file-supported-for-read-p (file)
2980 "Return non-nil if Wand can decode FILE."
2981 ;; Try by extension first, then try heuristic method using
2982 ;; `magic:file-type'
2983 (let ((ext (file-name-extension file)))
2984 (or (and ext (Wand-format-supported-for-read-p ext))
2986 (multiple-value-bind (itype imagetext)
2987 (split-string (or (magic:file-type file) " ") " ")
2989 (string= (downcase imagetext) "image")
2990 (Wand-format-supported-for-read-p itype))))))
2992 (defun Wand-formats-list (fmt-regexp &optional mode)
2993 "Return names of supported formats that matches FMT-REGEXP.
2994 Optionally you can specify MODE:
2995 'read - Only formats that we can read
2996 'write - Only formats that we can write
2997 'read-write - Formats that we can and read and write
2998 'any or nil - Any format (default)."
2999 (let* ((excp (make-ffi-object 'MagickExceptionInfo))
3000 (num (make-ffi-object 'unsigned-long))
3001 (fil (Wand:GetMagickInfoList
3002 fmt-regexp (ffi-address-of num) (ffi-address-of excp))))
3003 (unless (ffi-null-p fil)
3005 (loop for n from 0 below (ffi-get num)
3007 do (setq minfo (ffi-aref fil n))
3008 if (ecase (or mode 'any)
3009 (read (not (ffi-null-p (MagickInfo->decoder minfo))))
3010 (write (not (ffi-null-p (MagickInfo->encoder minfo))))
3012 (and (not (ffi-null-p (MagickInfo->decoder minfo)))
3013 (not (ffi-null-p (MagickInfo->encoder minfo)))))
3015 collect (ffi-get (MagickInfo->name minfo) :type 'c-string))
3016 (Wand:RelinquishMemory fil)))))
3019 ;;{{{ File navigation commands
3021 (defun Wand-next-file (curfile &optional reverse-order)
3022 "Return next (to CURFILE) image file in the directory.
3023 If REVERSE-ORDER is specified, then return previous file."
3024 (let* ((dir (file-name-directory curfile))
3025 (fn (file-name-nondirectory curfile))
3026 (dfiles (directory-files dir nil nil 'sorted-list t))
3027 (nfiles (cdr (member fn (if reverse-order (nreverse dfiles) dfiles)))))
3028 (while (and nfiles (not (Wand-file-supported-for-read-p
3029 (concat dir (car nfiles)))))
3030 (setq nfiles (cdr nfiles)))
3031 (and nfiles (concat dir (car nfiles)))))
3033 (defun Wand-mode-next-image (&optional reverse)
3036 (let ((nf (Wand-next-file buffer-file-name reverse)))
3038 (error (format "No %s file" (if reverse "previous" "next"))))
3041 (defun Wand-mode-prev-image ()
3042 "View previous image."
3044 (Wand-mode-next-image t))
3046 (defun Wand-mode-last-image (&optional reverse)
3047 "View last image in the directory."
3049 (let ((rf buffer-file-name)
3050 (ff (Wand-next-file buffer-file-name reverse)))
3053 (setq ff (Wand-next-file rf reverse)))
3056 (defun Wand-mode-first-image ()
3057 "View very first image in the directory."
3059 (Wand-mode-last-image t))
3062 ;;{{{ Pages navigation commands
3064 (defun Wand-mode-next-page ()
3065 "Display next image in image chain."
3067 (unless (Wand:has-next-image image-wand)
3068 (error "No next image in chain"))
3069 (Wand:next-image image-wand)
3072 (defun Wand-mode-prev-page ()
3073 "Display previous image in image chain."
3075 (unless (Wand:has-prev-image image-wand)
3076 (error "No previous image in chain"))
3077 (Wand:prev-image image-wand)
3080 (defun Wand-mode-first-page ()
3081 "Display first image in image chain."
3083 (Wand:set-first-iterator image-wand)
3086 (defun Wand-mode-last-page ()
3087 "Display last image in image chain."
3089 (Wand:set-last-iterator image-wand)
3092 (defun Wand-mode-goto-page (n)
3093 "Display last image in image chain."
3095 (list (if (numberp current-prefix-arg)
3097 (read-number "Goto page: " t))))
3098 ;; Internally images in chain counts from 0
3099 (unless (setf (Wand:iterator-index image-wand) (1- n))
3100 (error "No such page" n))
3105 ;;{{{ Transform operations
3107 (defun Wand-mode-flip ()
3110 (Wand-operation-apply 'flip image-wand)
3112 (put 'Wand-mode-flip 'transform-operation t)
3113 (put 'Wand-mode-flip 'menu-name "Flip")
3115 (defun Wand-mode-flop ()
3118 (Wand-operation-apply 'flop image-wand)
3120 (put 'Wand-mode-flop 'transform-operation t)
3121 (put 'Wand-mode-flop 'menu-name "Flop")
3123 (defun Wand-mode-trim (fuzz)
3125 (interactive (list (read-number "Fuzz [0%]: " nil "0")))
3126 (Wand-operation-apply 'trim image-wand (/ fuzz 100.0))
3128 (put 'Wand-mode-trim 'transform-operation t)
3129 (put 'Wand-mode-trim 'menu-name "Trim Edges")
3131 (defun Wand-mode-rotate (arg)
3132 "Rotate image to ARG degrees.
3133 If ARG is positive then rotate in clockwise direction.
3134 If negative then to the opposite."
3135 (interactive "nDegrees: ")
3136 (Wand-operation-apply 'rotate image-wand arg)
3138 (put 'Wand-mode-rotate 'can-preview :RotatePreview)
3139 (put 'Wand-mode-rotate 'transform-operation t)
3140 (put 'Wand-mode-rotate 'menu-name "Rotate")
3142 (defun Wand-mode-rotate-left (arg)
3143 "Rotate image to the left.
3144 If ARG is specified then rotate on ARG degree."
3145 (interactive (list (or (and current-prefix-arg
3146 (prefix-numeric-value current-prefix-arg))
3148 (Wand-mode-rotate (- arg)))
3150 (defun Wand-mode-rotate-right (arg)
3151 "Rotate image to the right.
3152 If ARG is specified then rotate on ARG degree."
3153 (interactive (list (or (and current-prefix-arg
3154 (prefix-numeric-value current-prefix-arg))
3156 (Wand-mode-rotate arg))
3158 (defun Wand-mode-raise (arg)
3159 "Create button-like 3d effect."
3161 (Wand-operation-apply 'raise image-wand arg)
3163 (put 'Wand-mode-raise 'transform-operation t)
3164 (put 'Wand-mode-raise 'menu-name "3D Button Effect")
3167 ;;{{{ Effect operations
3169 (defun Wand-mode-radial-blur (arg)
3170 "Blur the image radially by ARG degree."
3171 (interactive (list (read-number "Blur radius [2.0]: " nil "2.0")))
3172 (Wand-operation-apply 'radial-blur image-wand arg)
3174 (put 'Wand-mode-radial-blur 'effect-operation t)
3175 (put 'Wand-mode-radial-blur 'menu-name "Radial Blur")
3177 (defun Wand-mode-sharpen (radius sigma)
3178 "Sharpen image with by RADIUS and SIGMA."
3179 (interactive (list (read-number "Radius [1]: " nil "1")
3180 (read-number (format "Sigma [%d]: " Wand-mode-sigma)
3181 nil (number-to-string Wand-mode-sigma))))
3182 (Wand-operation-apply 'sharpen image-wand radius sigma)
3184 (put 'Wand-mode-sharpen 'can-preview :SharpenPreview)
3185 (put 'Wand-mode-sharpen 'effect-operation t)
3186 (put 'Wand-mode-sharpen 'menu-name "Sharpen")
3188 (defun Wand-mode-gaussian-blur (radius sigma)
3189 "Apply gaussian blur of RADIUS and SIGMA to the image."
3190 (interactive (list (read-number "Radius [1]: " nil "1")
3191 (read-number (format "Sigma [%d]: " Wand-mode-sigma)
3192 nil (number-to-string Wand-mode-sigma))))
3193 (Wand-operation-apply 'gauss-blur image-wand radius sigma)
3195 (put 'Wand-mode-gaussian-blur 'can-preview :BlurPreview)
3196 (put 'Wand-mode-gaussian-blur 'effect-operation t)
3197 (put 'Wand-mode-gaussian-blur 'menu-name "Gaussian Blur")
3199 (defun Wand-mode-despeckle ()
3202 (Wand-operation-apply 'despeckle image-wand)
3204 (put 'Wand-mode-despeckle 'can-preview :DespecklePreview)
3205 (put 'Wand-mode-despeckle 'effect-operation t)
3206 (put 'Wand-mode-despeckle 'menu-name "Despeckle")
3208 (defun Wand-mode-edge (radius)
3209 "Enhance edges of the image by RADIUS.
3211 (interactive (list (read-number "Radius [1.0]: " nil "1.0")))
3212 (Wand-operation-apply 'edge image-wand radius)
3214 (put 'Wand-mode-edge 'effect-operation t)
3215 (put 'Wand-mode-edge 'menu-name "Edge Detect")
3217 (defun Wand-mode-emboss (radius sigma)
3218 "Emboss the image with RADIUS and SIGMA."
3219 (interactive (list (read-number "Radius [1.0]: " nil "1.0")
3220 (read-number (format "Sigma [%d]: " Wand-mode-sigma)
3221 nil (number-to-string Wand-mode-sigma))))
3222 (Wand-operation-apply 'emboss image-wand radius sigma)
3224 (put 'Wand-mode-emboss 'effect-operation t)
3225 (put 'Wand-mode-emboss 'menu-name "Emboss")
3227 (defun Wand-mode-reduce-noise (arg)
3228 "Reduce the noise with ARG radius.
3231 (Wand-operation-apply 'reduce-noise image-wand arg)
3233 (put 'Wand-mode-reduce-noise 'can-preview :ReduceNoisePreview)
3234 (put 'Wand-mode-reduce-noise 'effect-operation t)
3235 (put 'Wand-mode-reduce-noise 'menu-name "Reduce Noise")
3237 (defun Wand-mode-add-noise (noise-type)
3238 "Add noise of NOISE-TYPE."
3240 (list (completing-read "Noise type [poisson]: "
3241 (mapcar #'(lambda (ev)
3242 (let ((sn (symbol-name (car ev))))
3243 (list (and (string-match
3244 ":\\(.+\\)Noise" sn)
3246 (match-string 1 sn))))))
3247 (ffi-enum-values 'MagickNoiseType))
3248 nil t nil nil "poisson")))
3249 (let ((nt (intern (format ":%sNoise" (capitalize noise-type)))))
3250 (Wand-operation-apply 'add-noise image-wand nt))
3252 (put 'Wand-mode-add-noise 'effect-operation t)
3253 (put 'Wand-mode-add-noise 'menu-name "Add Noise")
3255 (defun Wand-mode-spread (radius)
3256 "Add noise of NOISE-TYPE."
3257 (interactive (list (read-number "Spread radius [1.0]: " nil "1.0")))
3258 (Wand-operation-apply 'spread image-wand radius)
3260 (put 'Wand-mode-spread 'effect-operation t)
3261 (put 'Wand-mode-spread 'menu-name "Spread")
3264 ;;{{{ Enhance operations
3266 (defun Wand-mode-contrast (ctype)
3267 "Increase or decrease contrast.
3268 By default increase."
3269 (interactive (list (completing-read
3270 "Contrast [increase]: " '(("increase") ("decrease"))
3271 nil t nil nil "increase")))
3272 (Wand-operation-apply 'contrast image-wand (string= ctype "increase"))
3274 (put 'Wand-mode-contrast 'enhance-operation t)
3275 (put 'Wand-mode-contrast 'menu-name "Contrast")
3277 (defun Wand-mode-normalize ()
3280 (Wand-operation-apply 'normalize image-wand)
3282 (put 'Wand-mode-normalize 'enhance-operation t)
3283 (put 'Wand-mode-normalize 'menu-name "Normalize")
3285 (defun Wand-mode-enhance ()
3288 (Wand-operation-apply 'enhance image-wand)
3290 (put 'Wand-mode-enhance 'enhance-operation t)
3291 (put 'Wand-mode-enhance 'menu-name "Enhance")
3293 (defun Wand-mode-equalize ()
3296 (Wand-operation-apply 'equalize image-wand)
3298 (put 'Wand-mode-equalize 'enhance-operation t)
3299 (put 'Wand-mode-equalize 'menu-name "Equalize")
3301 (defun Wand-mode-negate (arg)
3303 If prefix ARG is specified then negate by grey."
3305 (Wand-operation-apply 'negate image-wand arg)
3307 (put 'Wand-mode-negate 'enhance-operation t)
3308 (put 'Wand-mode-negate 'menu-name "Negate")
3310 (defun Wand-mode-grayscale ()
3311 "Convert image to grayscale colorspace."
3313 (Wand-operation-apply 'grayscale image-wand)
3315 (put 'Wand-mode-grayscale 'enhance-operation t)
3316 (put 'Wand-mode-grayscale 'menu-name "Grayscale")
3318 (defun Wand-mode-modulate (type inc)
3319 "Modulate image's brightness, saturation or hue."
3320 (interactive (let* ((tp (completing-read
3321 "Modulate [saturation]: "
3322 '(("brightness") ("saturation") ("hue"))
3323 nil t nil nil "saturation"))
3324 (tinc (read-number (format "Increase %s [25%%]: " tp)
3326 (list (cond ((string= tp "brightness") :brightness)
3327 ((string= tp "hue") :hue)
3328 (t :saturation)) tinc)))
3329 (Wand-operation-apply 'modulate image-wand type inc)
3331 (put 'Wand-mode-modulate 'enhance-operation t)
3332 (put 'Wand-mode-modulate 'menu-name "Modulate")
3335 ;;{{{ F/X operations
3337 (defun Wand-mode-solarize (sf)
3338 "Solarise image with solarize factor SF."
3339 (interactive (list (read-number "Solarize factor [50%]: " nil "50")))
3340 (Wand-operation-apply 'solarize image-wand
3341 (* (Wand:quantum-range) (/ sf 100.0)))
3343 (put 'Wand-mode-solarize 'f/x-operation t)
3344 (put 'Wand-mode-solarize 'menu-name "Solarize")
3346 (defun Wand-mode-swirl (degrees)
3347 "Swirl the image by DEGREES."
3348 (interactive (list (read-number "Degrees [90]: " nil "90")))
3349 (Wand-operation-apply 'swirl image-wand degrees)
3351 (put 'Wand-mode-swirl 'f/x-operation t)
3352 (put 'Wand-mode-swirl 'menu-name "Swirl")
3354 (defun Wand-mode-oil-paint (radius)
3355 "Simulate oil painting with RADIUS for the image.
3356 Default radius is 3."
3357 (interactive (list (read-number "Radius [3.0]: " nil "3.0")))
3358 (Wand-operation-apply 'oil image-wand radius)
3360 (put 'Wand-mode-oil-paint 'can-preview :OilPaintPreview)
3361 (put 'Wand-mode-oil-paint 'f/x-operation t)
3362 (put 'Wand-mode-oil-paint 'menu-name "Oil Paint")
3364 (defun Wand-mode-charcoal (radius sigma)
3365 "Simulate charcoal painting for the image.
3366 If prefix ARG is specified then radius for charcoal painting is ARG.
3368 (interactive (list (read-number "Radius [1.0]: " nil "1.0")
3369 (read-number "Sigma [1.0]: " nil "1.0")))
3370 (Wand-operation-apply 'charcoal image-wand radius sigma)
3372 (put 'Wand-mode-charcoal 'can-preview :CharcoalDrawingPreview)
3373 (put 'Wand-mode-charcoal 'f/x-operation t)
3374 (put 'Wand-mode-charcoal 'menu-name "Charcoal Draw")
3376 (defun Wand-mode-sepia-tone (threshold)
3377 "Apply sepia tone to image by THRESHOLD."
3378 (interactive (list (read-number "Threshold [80%]: " nil "80")))
3379 (Wand-operation-apply 'sepia-tone image-wand
3380 (* (Wand:quantum-range) (/ threshold 100.0)))
3382 (put 'Wand-mode-sepia-tone 'f/x-operation t)
3383 (put 'Wand-mode-sepia-tone 'menu-name "Sepia Tone")
3385 (defun Wand-mode-implode (radius)
3386 "Implode image by RADIUS.
3387 RADIUS range is [-1.0, 1.0]."
3388 (interactive (list (read-number "Radius [0.3]: " nil "0.3")))
3389 (Wand-operation-apply 'implode image-wand radius)
3391 (put 'Wand-mode-implode 'f/x-operation t)
3392 (put 'Wand-mode-implode 'menu-name "Implode")
3394 (defun Wand-mode-vignette (bw)
3395 "Create vignette using image."
3396 (interactive (list (read-number "Black/White [10]: " nil "10")))
3397 (Wand-operation-apply 'vignette image-wand bw bw 0 0)
3399 (put 'Wand-mode-vignette 'f/x-operation t)
3400 (put 'Wand-mode-vignette 'menu-name "Vignette")
3402 (defun Wand-mode-wave (amplitude wave-length)
3403 "Create wave effect on image with AMPLITUDE and WAVE-LENGTH."
3404 (interactive (list (read-number "Amplitude [2]: " nil "2")
3405 (read-number "Wave length [10]: " nil "10")))
3406 (Wand-operation-apply 'wave image-wand amplitude wave-length)
3408 (put 'Wand-mode-wave 'f/x-operation t)
3409 (put 'Wand-mode-wave 'menu-name "Wave")
3413 ;;{{{ Region commands
3415 (defun Wand-mode-select-region (event)
3418 (with-current-buffer (event-buffer event)
3419 (let ((gc-cons-threshold most-positive-fixnum) ; inhibit gc
3420 (sx (event-glyph-x-pixel event))
3421 (sy (event-glyph-y-pixel event))
3422 (had-preview-region preview-region)
3424 (setq preview-region (list 0 0 sx sy))
3426 (setq event (next-event event))
3427 (cond ((motion-event-p event)
3428 (let ((mx (event-glyph-x-pixel event))
3429 (my (event-glyph-y-pixel event)))
3431 (setq preview-region
3432 (list (abs (- sx mx)) (abs (- sy my))
3433 (min sx mx) (min sy my)))
3434 ;; Update info and preview image
3435 (Wand-mode-update-file-info)
3436 (let ((pwr (Wand-mode-preview-with-region)))
3438 (set-extent-end-glyph
3439 preview-extent (Wand-mode-preview-glyph pwr))
3440 (Wand:delete-wand pwr))))))
3442 ((button-release-event-p event)
3443 (setq mouse-down nil)
3444 (if (and (positivep (nth 0 preview-region))
3445 (positivep (nth 1 preview-region)))
3447 (put image-wand 'last-preview-region preview-region)
3449 (setq preview-region nil)
3450 (if had-preview-region
3452 ;; Remove any regions
3453 (Wand-mode-update-file-info)
3454 (set-extent-end-glyph
3455 preview-extent (Wand-mode-preview-glyph preview-wand)))
3457 ;; Otherwise pickup color
3458 (let* ((col (Wand:get-rgb-pixel-at preview-wand sx sy))
3459 (pickup-color (cons (cons sx sy) col)))
3460 (declare (special pickup-color))
3461 (Wand-mode-update-info)))))
3462 (t (dispatch-event event)))))))
3464 (defun Wand-mode-activate-region ()
3465 "Activate last preview-region."
3467 (setq preview-region (get image-wand 'last-preview-region))
3470 (defun Wand-mode-drag-image (event)
3471 "Drag image to view unshown part of the image."
3473 (let ((gc-cons-threshold most-positive-fixnum) ; inhibit gc
3474 (sx (event-glyph-x-pixel event))
3475 (sy (event-glyph-y-pixel event))
3476 (pw (Wand:image-width preview-wand))
3477 (ph (Wand:image-height preview-wand))
3480 (setq event (next-event event))
3481 (if (or (motion-event-p event) (button-release-event-p event))
3482 (let ((off-x (+ (- sx (event-glyph-x-pixel event))
3483 (or (get preview-wand 'offset-x) 0)))
3484 (off-y (+ (- sy (event-glyph-y-pixel event))
3485 (or (get preview-wand 'offset-y) 0))))
3486 (when (< off-x 0) (setq off-x 0))
3487 (when (< off-y 0) (setq off-y 0))
3488 (Wand-mode-update-file-info)
3489 (if (motion-event-p event)
3490 (set-extent-end-glyph
3491 preview-extent (Wand:glyph-internal
3492 preview-wand off-x off-y
3493 (- pw off-x) (- ph off-y)))
3496 (setq mouse-down nil)
3497 (put preview-wand 'offset-x off-x)
3498 (put preview-wand 'offset-y off-y)))
3500 (dispatch-event event)))))
3502 (defun Wand-mode-crop ()
3503 "Crop image to selected region."
3505 (unless preview-region
3506 (error "Region not selected"))
3507 (Wand-operation-apply 'crop image-wand (Wand-mode-image-region))
3508 (setq preview-region nil)
3510 (put 'Wand-mode-crop 'region-operation t)
3511 (put 'Wand-mode-crop 'menu-name "Crop")
3513 (defun Wand-mode-chop ()
3514 "Chop region from the image."
3516 (unless preview-region
3517 (error "Region not selected"))
3518 (Wand-operation-apply 'chop image-wand (Wand-mode-image-region))
3519 (setq preview-region nil)
3521 (put 'Wand-mode-chop 'region-operation t)
3522 (put 'Wand-mode-chop 'menu-name "Chop")
3524 (defun Wand-mode-redeye-remove ()
3525 "Remove red from the selected region."
3527 (unless preview-region
3528 (error "Region not selected"))
3529 (let ((gc-cons-threshold most-positive-fixnum)) ; inhibit gc
3530 (Wand-operation-apply 'redeye-remove image-wand (Wand-mode-image-region))
3531 (setq preview-region nil)
3533 (put 'Wand-mode-redeye-remove 'region-operation t)
3534 (put 'Wand-mode-redeye-remove 'menu-name "Remove red eye")
3536 (defun Wand-mode-preview-op (op)
3537 "Preview some operation OP with 8 subnails."
3538 (interactive (list (completing-read "Operation: "
3539 MagickPreviewType-completion-table nil t)))
3540 (Wand-redisplay (Wand-operation-apply 'preview-op image-wand op)))
3541 (put 'Wand-mode-preview-op 'region-operation t)
3542 (put 'Wand-mode-preview-op 'menu-name "Preview operation")
3545 ;;{{{ Zooming/Sampling
3547 (defun Wand-mode-zoom-in (factor)
3548 "Zoom image by FACTOR.
3549 If FACTOR is nil, then `Wand-mode-zoom-factor' is used."
3551 (Wand-operation-apply 'zoom image-wand nil
3553 (prefix-numeric-value factor)
3554 Wand-mode-zoom-factor))
3557 (defun Wand-mode-zoom-out (factor)
3558 "Zoom image out by `Wand-mode-zoom-factor'."
3560 (Wand-operation-apply 'zoom image-wand t
3562 (prefix-numeric-value factor)
3563 Wand-mode-zoom-factor))
3566 (defun Wand-mode-sample (w h)
3567 "Sample image to WxH size."
3569 (list (read-number (format "Width [%d]: " (Wand:image-width image-wand))
3570 t (int-to-string (Wand:image-width image-wand)))
3571 (read-number (format "Height [%d]: " (Wand:image-height image-wand))
3572 t (int-to-string (Wand:image-height image-wand)))))
3573 (Wand-operation-apply 'sample image-wand w h)
3575 (put 'Wand-mode-sample 'transform-operation t)
3576 (put 'Wand-mode-sample 'menu-name "Sample")
3578 (defun Wand-mode-fit-size (w h)
3579 "Resize image to fit into WxH size."
3581 (let* ((dw (read-number
3582 (format "Width [%d]: " (Wand:image-width image-wand))
3583 t (int-to-string (Wand:image-width image-wand))))
3584 (dh (round (* (Wand:image-height image-wand)
3585 (// dw (Wand:image-width image-wand))))))
3586 (list dw (read-number (format "Height [%d]: " dh)
3587 t (int-to-string dh)))))
3589 (Wand-operation-apply 'fit-size image-wand w h)
3591 (put 'Wand-mode-fit-size 'transform-operation t)
3592 (put 'Wand-mode-fit-size 'menu-name "Fit to size")
3594 (defun Wand-mode-liquid-rescale (w h)
3595 "Rescale image to WxH using liquid rescale."
3597 (list (read-number (format "Width [%d]: " (Wand:image-width image-wand))
3598 t (int-to-string (Wand:image-width image-wand)))
3599 (read-number (format "Height [%d]: " (Wand:image-height image-wand))
3600 t (int-to-string (Wand:image-height image-wand)))))
3601 (Wand-operation-apply 'liquid-rescale image-wand w h)
3603 (put 'Wand-mode-liquid-rescale 'transform-operation t)
3604 (put 'Wand-mode-liquid-rescale 'menu-name "Liquid rescale")
3606 (defun Wand-mode-posterize (levels &optional ditherp)
3608 Levels is a number of color levels allowed in each channel.
3609 2, 3, or 4 have the most visible effect."
3610 (interactive "nLevel: \nP")
3611 (Wand-operation-apply 'posterize image-wand levels (not (not ditherp)))
3613 (put 'Wand-mode-posterize 'transform-operation t)
3614 (put 'Wand-mode-posterize 'menu-name "Posterize")
3616 (defun Wand-mode-pattern (pattern &optional op)
3617 "Enable checkerboard as tile background."
3618 (interactive (list (completing-read "Pattern: " Wand-patterns nil t)
3619 (if current-prefix-arg
3620 (completing-read "Composite Op: "
3621 WandCompositeOperator-completion-table nil t)
3622 Wand-pattern-composite-op)))
3623 (Wand-operation-apply 'pattern image-wand pattern op)
3625 (put 'Wand-mode-pattern 'transform-operation t)
3626 (put 'Wand-mode-pattern 'menu-name "Pattern")
3628 (defun Wand-list-composite-ops ()
3629 "Show composite operations.
3630 A-la `list-colors-display'."
3632 (Wand-with-drawing-wand d-in
3633 (Wand-with-pixel-wand pw
3634 (setf (Wand:pixel-color pw) "red")
3635 (setf (Wand:draw-fill-color d-in) pw))
3636 (Wand:draw-rectangle d-in 0.0 4.0 26.0 26.0)
3638 (Wand-with-drawing-wand d-out
3639 (Wand-with-pixel-wand pw
3640 (setf (Wand:pixel-color pw) "blue")
3641 (setf (Wand:draw-fill-color d-out) pw))
3642 (Wand:draw-rectangle d-out 10.0 0.0 42.0 32.0)
3644 (Wand-with-wand w-out
3645 (setf (Wand:image-size w-out)
3646 (cons 80 (face-height 'default)))
3647 (Wand:MagickReadImage w-out "pattern:horizontal")
3648 (Wand:MagickDrawImage w-out d-out)
3650 (flet ((draw-in-out (cop)
3651 (Wand-with-wand w-in
3652 (setf (Wand:image-size w-in)
3653 (cons 80 (face-height 'default)))
3654 (Wand:MagickReadImage w-in "pattern:vertical")
3655 (Wand:MagickDrawImage w-in d-in)
3656 (Wand:image-composite w-in w-out (cdr cop) 0 0)
3657 (let ((pnt (point)))
3658 (insert " " (car cop) "\n")
3659 (set-extent-end-glyph
3660 (make-extent pnt pnt)
3661 (Wand:glyph w-in))))))
3662 (with-output-to-temp-buffer "*Wand-Composite-Ops*"
3663 (set-buffer standard-output)
3665 (cdr WandCompositeOperator-completion-table))))))))
3667 (defun Wand-list-patterns ()
3668 "Show available patterns in separate buffer.
3669 A-la `list-colors-display'."
3671 (with-output-to-temp-buffer "*Wand-Patterns*"
3672 (flet ((draw-pattern (pat-name)
3673 (let ((pnt (point)))
3674 (insert " " pat-name "\n")
3675 (set-extent-end-glyph
3676 (make-extent pnt pnt)
3677 (Wand-with-wand wand
3678 (setf (Wand:image-size wand)
3679 (cons 80 (face-height 'default)))
3680 (Wand:MagickReadImage wand (concat "pattern:" pat-name))
3681 (Wand:glyph wand))))))
3683 (set-buffer standard-output)
3684 (mapc #'draw-pattern (mapcar #'car Wand-patterns))))))
3685 (put 'Wand-list-patterns 'transform-operation t)
3686 (put 'Wand-list-patterns 'menu-name "List Patterns")
3689 ;;{{{ Toggle fit, Undo/Redo, Saving
3691 (defun Wand-mode-toggle-fit ()
3694 (put image-wand 'fitting (not (get image-wand 'fitting)))
3697 (defun Wand-mode-undo (&optional arg)
3698 "Undo last operation ARG times."
3700 (unless operations-list
3701 (error "Nothing to undo"))
3703 (push (car (last operations-list)) undo-list)
3704 (setq operations-list (butlast operations-list)))
3707 (Wand:clear-wand image-wand)
3708 (Wand:read-image image-wand buffer-file-name)
3709 (Wand-operation-list-apply image-wand)
3713 (defun Wand-mode-redo (&optional arg)
3714 "Redo last operations ARG times."
3717 (error "Nothing to redo"))
3719 (let ((op (pop undo-list)))
3721 (apply #'Wand-operation-apply (car op) image-wand (cdr op)))))
3725 (defun Wand-mode-repeat-last-operation ()
3726 "Repeat last operation on image."
3728 (let ((last-op (car (last operations-list))))
3730 (apply #'Wand-operation-apply
3731 (car last-op) image-wand (cdr last-op))
3734 (defun Wand-mode-global-operations-list (arg)
3735 "Fix operations list to be global for all images.
3736 If prefix ARG is supplied, then global operations list is reseted.
3737 Useful to skim over images in directory applying operations, for
3740 (setq Wand-global-operations-list
3741 (and (not arg) operations-list))
3744 (defun Wand-mode-write-file (format nfile)
3745 "Write file using output FORMAT."
3747 (let* ((ofmt (completing-read
3748 (format "Output Format [%s]: "
3749 (Wand:image-format image-wand))
3750 (mapcar #'list (Wand-formats-list "*" 'write))
3751 nil t nil nil (Wand:image-format image-wand)))
3752 (nfname (concat (file-name-sans-extension buffer-file-name)
3753 "." (downcase ofmt)))
3756 (file-name-directory buffer-file-name)
3757 nfname nil (file-name-nondirectory nfname))))
3760 (unless (Wand-format-supported-for-write-p format)
3761 (error "Unsupported format for writing: %s" format))
3763 (when (or (not Wand-mode-query-for-overwrite)
3764 (not (file-exists-p nfile))
3765 (y-or-n-p (format "File %s exists, overwrite? " nfile)))
3766 (setf (Wand:image-format image-wand) format)
3767 (let ((saved-iw image-wand)) ; do this because it is buffer-local
3769 (insert (Wand:image-blob saved-iw))
3770 (set-visited-file-name nfile t)
3771 (set-buffer-modified-p t)
3772 (setq buffer-read-only nil)
3773 (let ((buffer-file-coding-system (get-coding-system 'binary)))
3775 (message "File %s saved" nfile)
3777 ;; Redisplay in case we can do it
3778 (if (Wand-format-supported-for-read-p format)
3779 (Wand-display nfile)
3780 (find-file nfile))))
3782 (defun Wand-mode-save-file (nfile)
3783 "Save current wand to file NFILE.
3784 Output format determined by NFILE extension, and no sanity checks
3785 performed, use `Wand-mode-write-file' if are not sure."
3787 (list (read-file-name "Filename: "
3788 (file-name-directory buffer-file-name)
3789 buffer-file-name nil
3790 (file-name-nondirectory buffer-file-name))))
3791 (Wand-mode-write-file
3792 (upcase (file-name-extension nfile)) nfile))
3798 ;; now initialise the environment
3799 (when-fboundp 'Wand:MagickWandGenesis
3800 (Wand:MagickWandGenesis))
3802 (run-hooks 'ffi-wand-after-load-hook)
3804 ;;; ffi-wand.el ends here