openai/image.scm

@@ -20,8 +20,10 @@
 (define-module (openai image)
   #:use-module (openai api image)
   #:use-module (openai client)
+  #:use-module (openai utils magick)
   #:use-module (ice-9 binary-ports)
   #:use-module (ice-9 match)
+  #:use-module (srfi srfi-8)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
   #:export (openai-default-image-size
@@ -48,12 +50,31 @@
   (file image-file))
 
 (define (write-image-file img)
-  (let ((data (fetch-image-data img)))
+  (let* ((raw-data (fetch-image-data img))
+         (png-rgba (magick-convert-image raw-data
+                                         #:format "PNG"
+                                         #:alpha-channel 'Activate)))
     (call-with-port (mkstemp "/tmp/guile-openai-XXXXXX")
       (lambda (port)
-        (put-bytevector port data)
+        (put-bytevector port png-rgba)
         (port-filename port)))))
 
+(define (write-transparent-mask size)
+  (receive (width height)
+      (cond ((string=? size "256x256")
+             (values 256 256))
+            ((string=? size "512x512")
+             (values 512 512))
+            ((string=? size "1024x1024")))
+    (let ((png-rgba (magick-create-image #:width width
+                                         #:height height
+                                         #:format "PNG"
+                                         #:alpha-channel 'Activate)))
+      (call-with-port (mkstemp "/tmp/guile-openai-XXXXXX")
+        (lambda (port)
+          (put-bytevector port png-rgba)
+          (port-filename port))))))
+
 (define (make-image img)
   (let ((url (image-data-url img)))
     (%make-image (if (unspecified? url) #f url)
@@ -145,11 +166,10 @@ default).  In either case, the image data will be fetched and stored
 locally for display.
 
 #:user - An optional username to associate with this request."
-  ;;; XXX: mask defaults to opaque instead of transparent
-  ;;; XXX: image must be RGBA, but openai-image gives RGB
   (let* ((image (if (image? image) (image-file image) image))
          (mask (if (image? mask) (image-file mask) mask))
          (size (parse-image-size size))
+         (mask (if (unspecified? mask) (write-transparent-mask size) mask))
          (format (parse-image-format format))
          (request (make-image-edit-request image mask prompt
                                            n size format user))

openai/utils/foreign.scm

@@ -58,6 +58,9 @@
   (wrapper c-type-wrapper)
   (unwrapper c-type-unwrapper))
 
+(define* (make-c-type name repr #:key wrap-result unwrap-args)
+  (%make-c-type name repr wrap-result unwrap-args))
+
 (define* (print-c-type type #:optional port)
   (format port "#<c-type ~a ~a>"
           (c-type-name type)
@@ -68,17 +71,17 @@
 
 (set-record-type-printer! <c-type> print-c-type)
 
-(define-syntax-rule (define-foreign-type type-name base wrapper unwrapper)
+(define-syntax-rule (define-foreign-type type-name base args ...)
   (define type-name
-    (%make-c-type (symbol->string 'type-name)
-                  (c-type-repr base)
-                  wrapper unwrapper)))
+    (make-c-type (symbol->string 'type-name)
+                 (c-type-repr base)
+                 args ...)))
 
 (define-syntax-rule (define-foreign-arg-type type-name base unwrapper)
-  (define-foreign-type type-name base #f unwrapper))
+  (define-foreign-type type-name base #:unwrap-args unwrapper))
 
 (define-syntax-rule (define-foreign-return-type type-name base wrapper)
-  (define-foreign-type type-name base wrapper #f))
+  (define-foreign-type type-name base #:wrap-result wrapper))
 
 ;;; Base types
 
@@ -99,7 +102,9 @@
 (define-syntax-rule (define-base-type type-name repr)
   (begin
     (define type-name
-      (%make-c-type (symbol->string 'type-name) repr identity identity))
+      (make-c-type (symbol->string 'type-name) repr
+                   #:wrap-result (lambda (res . _) res)
+                   #:unwrap-args (lambda (arg) arg)))
     (register-base-type! type-name)))
 
 (define-base-type int8           ffi:int8)
@@ -131,12 +136,12 @@
 ;;; Common types
 
 (define-foreign-type cstring pointer
-  ffi:pointer->string
-  ffi:string->pointer)
+  #:wrap-result (lambda (ptr . _) (ffi:pointer->string ptr))
+  #:unwrap-args ffi:string->pointer)
 
 (define-foreign-type bool int
-  (lambda (int) (not (zero? int)))
-  (lambda (bool) (if bool 1 0)))
+  #:wrap-result (lambda (int . _) (not (zero? int)))
+  #:unwrap-args (lambda (bool) (if bool 1 0)))
 
 ;;; Enum types
 
@@ -164,7 +169,8 @@
         (lambda (int)
           (and=> (vhash-assv int lookup) cdr))))
     (define-foreign-type enum-name enum-base
-      int->enumerator enumerator->int)))
+      #:wrap-result (lambda (int . _) (int->enumerator int))
+      #:unwrap-args enumerator->int)))
 
 (define-syntax %dfe-enum-symbols
   (syntax-rules (=>)
@@ -199,7 +205,8 @@
         (let ((address (ffi:pointer-address (record->pointer rec))))
           (format port "#<~a 0x~x>" 'pointer-name address))))
     (define-foreign-type pointer-name pointer
-      pointer->record record->pointer)))
+      #:wrap-result (lambda (ptr . _) (pointer->record ptr))
+      #:unwrap-args record->pointer)))
 
 ;;; Function wrappers
 
@@ -229,16 +236,9 @@
       (function-name signature ...))
     ...))
 
-(define (procedure-takes-rest? proc)
-  (caddr (procedure-minimum-arity proc)))
-
 (define* (wrapped-foreign-library-function library function-name
                                            #:key return-type arg-types)
-  (let* ((wrapper (c-type-wrapper return-type))
-         (wrap-result (if (procedure-takes-rest? wrapper)
-                          wrapper
-                          (lambda (result . args)
-                            (wrapper result))))
+  (let* ((wrap-result (c-type-wrapper return-type))
          (unwrappers (map c-type-unwrapper arg-types))
          (unwrap-args (lambda (args)
                         (map (lambda (unwrap arg)

openai/utils/magick.scm

@@ -25,7 +25,8 @@
   #:use-module (srfi srfi-9)
   #:use-module ((system foreign) #:prefix ffi:)
   #:export (magick-alpha-channel-options
-            magick-convert-image))
+            magick-convert-image
+            magick-create-image))
 
 (define-foreign-library libMagickWand %libmagickwand)
 
@@ -129,70 +130,115 @@
 (define-foreign-return-type wand-error int
   (lambda (result wand . _)
     (when (zero? result)
-      (apply error (MagickGetException wand)))))
+      (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)
-  (MagickGetException wand-ptr pointer -> cstring)
+  (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))
-
-(set! MagickGetException
-      (let ((func MagickGetException))
-        (lambda (wand)
-          (let* ((type-ptr (ffi:make-c-struct (list ffi:int) (list 0)))
-                 (message (func wand type-ptr))
-                 (type-int (car (ffi:parse-c-struct type-ptr (list ffi:int))))
-                 (type (int->exception-type type-int)))
-            (list type message)))))
-
-(set! MagickReadImageBlob
-      (let ((func MagickReadImageBlob))
-        (lambda (wand bv)
-          (let ((ptr (ffi:bytevector->pointer bv))
-                (len (bytevector-length bv)))
-            (func wand ptr len)))))
-
-(set! MagickGetImageBlob
-      (let ((func MagickGetImageBlob))
-        (lambda (wand)
-          (let* ((len-ptr (ffi:make-c-struct (list ffi:size_t) (list 0)))
-                 (data-ptr (func wand len-ptr))
-                 (data-len (car (ffi:parse-c-struct len-ptr (list ffi:size_t)))))
-            (ffi:pointer->bytevector data-ptr data-len)))))
+  (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* 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* wand bv)
+  (let ((ptr (ffi:bytevector->pointer bv))
+        (len (bytevector-length bv)))
+    (MagickReadImageBlob wand ptr len)))
+
+(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* 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-magick-wand proc)
-  (let ((wand #f))
+(define (call-with-pointer alloc free proc)
+  (let ((ptr #f))
     (dynamic-wind
       (const #t)
       (lambda ()
-        (MagickWandGenesis)
-        (set! wand (NewMagickWand))
-        (proc wand))
+        (set! ptr (alloc))
+        (proc ptr))
       (lambda ()
-        (when wand
-          (DestroyMagickWand wand))))))
+        (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)
+(define* (magick-convert-image image-bytes #:key format alpha-channel)
   (call-with-magick-wand
    (lambda (wand)
-     (MagickReadImageBlob wand image-bytes)
-     (MagickSetImageFormat wand format)
-     (MagickSetImageAlphaChannel wand alpha-channel)
-     (MagickGetImageBlob 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 "PNG")
+                              (background-color "white")
+                              (background-alpha 0.0)
+                              alpha-channel)
+  (call-with-magick-wand
+   (lambda (wand)
+     (call-with-pixel-wand
+      (lambda (background)
+        (PixelSetColor background background-color)
+        (PixelSetAlpha background background-alpha)
+        (MagickNewImage wand width height background)))
+     (when format
+       (MagickSetImageFormat wand format))
+     (when alpha-channel
+       (MagickSetImageAlphaChannel wand alpha-channel))
+     (MagickGetImageBlob* wand))))
+
+(MagickWandGenesis)