;;;;
;;;; image.stk                  -- GTK Image Widget
;;;;
;;;; Copyright © 2000-2023 Erick Gallesio <eg@stklos.net>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program 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 General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 13-Oct-2000 17:15 (eg)
;;;;

;;;
;;; GTK bindings
;;;
(define-gtk gtk-image-new-from-file (#:string) #:pointer       "gtk_image_new_from_file")
(define-gtk gtk-image-new-from-icon (#:string :long) #:pointer "gtk_image_new_from_icon_name")
(define-gtk gtk-image-get-pixbuf (#:pointer) #:pointer         "gtk_image_get_pixbuf")


(%compile-time-define %guess-pathname)  ; to avoid a warning


;; See https://developer.gnome.org/gtk3/stable/gtk3-Themeable-Stock-Images.html#GtkIconSize
(define (size->int sz)
  (let ((sz (if (string? sz) (string->symbol sz) sz)))
    (case sz
      ((small)   1)   ; 16px
      ((medium)  3)   ; 24px
      ((large)   5)   ; 32px
      ((huge)    6)   ; 48px
      (else (error "bad size specification: ~s" sz)))))

(define (int->size v)
  (case v
    ((3)     'medium)
    ((5)     'large)
    ((6)     'huge)
    (else    'small)))

;; ----------------------------------------------------------------------
;;                          Images Utilities
;;----------------------------------------------------------------------

(define *image-suffixes* '("xpm" "jpg" "jpeg" "gif" "png"))

(define *image-path*
  (let ((user-path (build-path-from-shell-variable "STKLOS_IMAGE_PATH")))
    (if (null? user-path)
        (list "."
              (string-append (%library-prefix)
                             "/share/stklos/"
                             (version)
                             "/images"))
        user-path)))

(define (find-image fn)
  (%guess-pathname fn (image-path) *image-suffixes*))


(define image-path
  (make-parameter *image-path*
                  (lambda (path)
                    (for-each (lambda (x)
                                (unless (string? x)
                                  (error 'image-path "bad directory ~S" x)))
                              path)
                    path)))


;;;; ======================================================================
;;;;
;;;;                Class <image>
;;;;
;;;; ======================================================================
(define-class <image> (<gtk-misc>)
  ((file-name   #:accessor      file-name
                #:init-keyword  #:file-name
                #:allocation    #:virtual
                #:slot-ref      (lambda (o)
                                  (%gtk-get-property (slot-ref o 'wid)
                                                     "file"))
                #:slot-set!     (lambda (o v)
                                  (%gtk-set-property! (slot-ref o 'wid)
                                                       "file"
                                                       (find-image v))))
   (icon-name   #:allocation    #:gtk-property
                #:accessor      icon-name
                #:init-keyword  #:icon-name)
   (icon-size   #:allocation    #:virtual
                #:accessor      icon-size
                #:init-keyword  #:icon-size
                #:slot-ref      (lambda (o)
                                  (int->size (%gtk-get-property (slot-ref o 'wid)
                                                                "icon-size")))
                #:slot-set!     (lambda (o v)
                                  (%gtk-set-property! (slot-ref o 'wid)
                                                      "icon-size"
                                                      (size->int v))))))


(define-method realize-widget ((self <image>) initargs)
  (let* ((icon (key-get initargs #:icon-name #f))
         (sz   (key-get initargs #:icon-size 'medium))
         (file (key-get initargs #:file-name #f))
         (img  (cond
                (icon (gtk-image-new-from-icon
                           icon
                           (size->int sz)))
                (file (gtk-image-new-from-file
                       (or (find-image file) file)))
                (else (error "file or icon name exptected")))))
    (cpointer-type-set! img 'gtk-image)
    (slot-set! self 'wid img)))

(define-method get-image-pixbuf ((self <image>))
  (let ((pix (gtk-image-get-pixbuf (slot-ref self 'wid))))
    (cond
     ((eq? pix (void)) #f)
     (else (cpointer-type-set! pix 'image-pixbuf)
           pix))))

;;;
;;; Exports
;;;
(export image-path
        <image> file-name icon-name icon-size
        get-image-pixbuf)
