123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253 |
- ;;; 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)
|