guile-openai/openai/utils/magick.scm

;;; guile-openai --- An OpenAI API client for Guile
;;; Copyright © 2023 Andrew Whatson <whatson@tailcall.au>
;;;
;;; This file is part of guile-openai.
;;;
;;; guile-openai is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU Affero General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; guile-openai is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Affero General Public License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public
;;; License along with guile-openai.  If not, see
;;; <https://www.gnu.org/licenses/>.

(define-module (openai utils magick)
  #:use-module (openai config)
  #:use-module (openai utils foreign)
  #:use-module (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-9)
  #:use-module ((system foreign) #:prefix ffi:)
  #:export (magick-alpha-channel-options
            magick-convert-image
            magick-create-image))

(define-foreign-library libMagickWand %libmagickwand)

(define-foreign-enum-type alpha-channel-enum int
  alpha-channel? alpha-channel-list
  int->alpha-channel alpha-channel->int
  (Undefined
   Activate
   Associate
   Background
   Copy
   Deactivate
   Discrete
   Disassociate
   Extract
   Off
   On
   Opaque
   Remove
   Set
   Shape
   Transparent))

(define-foreign-enum-type exception-type-enum int
  exception-type? exception-type-list
  int->exception-type exception-type->int
  (UndefinedException
   WarningException => 300
   ResourceLimitWarning => 300
   TypeWarning => 305
   OptionWarning => 310
   DelegateWarning => 315
   MissingDelegateWarning => 320
   CorruptImageWarning => 325
   FileOpenWarning => 330
   BlobWarning => 335
   StreamWarning => 340
   CacheWarning => 345
   CoderWarning => 350
   FilterWarning => 352
   ModuleWarning => 355
   DrawWarning => 360
   ImageWarning => 365
   WandWarning => 370
   RandomWarning => 375
   XServerWarning => 380
   MonitorWarning => 385
   RegistryWarning => 390
   ConfigureWarning => 395
   PolicyWarning => 399
   ErrorException => 400
   ResourceLimitError => 400
   TypeError => 405
   OptionError => 410
   DelegateError => 415
   MissingDelegateError => 420
   CorruptImageError => 425
   FileOpenError => 430
   BlobError => 435
   StreamError => 440
   CacheError => 445
   CoderError => 450
   FilterError => 452
   ModuleError => 455
   DrawError => 460
   ImageError => 465
   WandError => 470
   RandomError => 475
   XServerError => 480
   MonitorError => 485
   RegistryError => 490
   ConfigureError => 495
   PolicyError => 499
   FatalErrorException => 700
   ResourceLimitFatalError => 700
   TypeFatalError => 705
   OptionFatalError => 710
   DelegateFatalError => 715
   MissingDelegateFatalError => 720
   CorruptImageFatalError => 725
   FileOpenFatalError => 730
   BlobFatalError => 735
   StreamFatalError => 740
   CacheFatalError => 745
   CoderFatalError => 750
   FilterFatalError => 752
   ModuleFatalError => 755
   DrawFatalError => 760
   ImageFatalError => 765
   WandFatalError => 770
   RandomFatalError => 775
   XServerFatalError => 780
   MonitorFatalError => 785
   RegistryFatalError => 790
   ConfigureFatalError => 795
   PolicyFatalError => 799))

(define-foreign-pointer-type wand-ptr <wand>
  wand? pointer->wand wand->pointer)

(define-foreign-return-type wand-error int
  (lambda (result wand . _)
    (when (zero? result)
      (apply error (MagickGetException wand)))))

(define-foreign-pointer-type pixel-wand-ptr <pixel-wand>
  pixel-wand? pointer->pixel-wand pixel-wand->pointer)

(define-foreign-return-type pixel-wand-error int
  (lambda (result pixel-wand . _)
    (when (zero? result)
      (apply error (PixelGetException pixel-wand)))))

(define-foreign-functions libMagickWand
  (MagickWandGenesis -> void)
  (MagickWandTerminus -> void)
  (NewMagickWand -> wand-ptr)
  (DestroyMagickWand wand-ptr -> wand-ptr)
  (MagickRelinquishMemory pointer -> pointer)
  (MagickGetException wand-ptr pointer -> pointer)
  (MagickReadImage wand-ptr cstring -> wand-error)
  (MagickReadImageBlob wand-ptr pointer size_t -> wand-error)
  (MagickNewImage wand-ptr size_t size_t pixel-wand-ptr -> wand-error)
  (MagickWriteImage wand-ptr cstring -> bool)
  (MagickGetImageBlob wand-ptr pointer -> pointer)
  (MagickGetImageFormat wand-ptr -> cstring)
  (MagickSetImageFormat wand-ptr cstring -> wand-error)
  (MagickGetImageAlphaChannel wand-ptr -> alpha-channel-enum)
  (MagickSetImageAlphaChannel wand-ptr alpha-channel-enum -> wand-error)
  (NewPixelWand -> pixel-wand-ptr)
  (DestroyPixelWand pixel-wand-ptr -> pixel-wand-ptr)
  (PixelGetException pixel-wand-ptr pointer -> pointer)
  (PixelSetColor pixel-wand-ptr cstring -> pixel-wand-error)
  (PixelSetAlpha pixel-wand-ptr double -> void))

(define %MagickGetException MagickGetException)
(define (MagickGetException wand)
  (let* ((type-ptr (ffi:make-c-struct (list ffi:int) (list 0)))
         (message-ptr (%MagickGetException wand type-ptr))
         (message (ffi:pointer->string message-ptr))
         (type-int (car (ffi:parse-c-struct type-ptr (list ffi:int))))
         (type (int->exception-type type-int)))
    (MagickRelinquishMemory message-ptr)
    (list type message)))

(define %MagickReadImageBlob MagickReadImageBlob)
(define (MagickReadImageBlob wand bv)
  (let ((ptr (ffi:bytevector->pointer bv))
        (len (bytevector-length bv)))
    (%MagickReadImageBlob wand ptr len)))

(define %MagickGetImageBlob MagickGetImageBlob)
(define (MagickGetImageBlob wand)
  (let* ((len-ptr (ffi:make-c-struct (list ffi:size_t) (list 0)))
         (data-ptr (%MagickGetImageBlob wand len-ptr))
         (data-len (car (ffi:parse-c-struct len-ptr (list ffi:size_t)))))
    (ffi:pointer->bytevector data-ptr data-len)))

(define %PixelGetException PixelGetException)
(define (PixelGetException pixel-wand)
  (let* ((type-ptr (ffi:make-c-struct (list ffi:int) (list 0)))
         (message-ptr (%PixelGetException pixel-wand type-ptr))
         (message (ffi:pointer->string message-ptr))
         (type-int (car (ffi:parse-c-struct type-ptr (list ffi:int))))
         (type (int->exception-type type-int)))
    (MagickRelinquishMemory message-ptr)
    (list type message)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (call-with-pointer alloc free proc)
  (let ((ptr #f))
    (dynamic-wind
      (const #t)
      (lambda ()
        (set! ptr (alloc))
        (proc ptr))
      (lambda ()
        (when ptr
          (free ptr))))))

(define (call-with-magick-wand proc)
  (call-with-pointer NewMagickWand DestroyMagickWand proc))

(define (call-with-pixel-wand proc)
  (call-with-pointer NewPixelWand DestroyPixelWand proc))

(define (magick-alpha-channel-options)
  (alpha-channel-list))

(define* (magick-convert-image image-bytes #:key
                               format
                               alpha-channel)
  (call-with-magick-wand
   (lambda (wand)
     (MagickReadImageBlob wand image-bytes)
     (when format
       (MagickSetImageFormat wand format))
     (when alpha-channel
       (MagickSetImageAlphaChannel wand alpha-channel))
     (MagickGetImageBlob wand))))

(define* (magick-create-image #:key width height
                              format
                              background-color
                              background-alpha
                              alpha-channel)
  (call-with-magick-wand
   (lambda (wand)
     (call-with-pixel-wand
      (lambda (background)
        (when background-color
          (PixelSetColor background background-color))
        (when background-alpha
          (PixelSetAlpha background background-alpha))
        (MagickNewImage wand width height background)))
     (when format
       (MagickSetImageFormat wand format))
     (when alpha-channel
       (MagickSetImageAlphaChannel wand alpha-channel))
     (MagickGetImageBlob wand))))

(MagickWandGenesis)