100 lines
5 KiB
Common Lisp
100 lines
5 KiB
Common Lisp
;;;; iip-project.lisp
|
|
;;;; Copyright 2024 Petar Kapriš
|
|
;;;;
|
|
;;;; 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 3 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, see <http://www.gnu.org/licenses/>.
|
|
|
|
(in-package #:iip-project)
|
|
|
|
(gtk:define-application (:name iip-project
|
|
:id "org.kayprish.iip-project")
|
|
(cffi:defcallback open-file-callback :void ((file-dialog :pointer)
|
|
(result :pointer)
|
|
; data now contains (img-original *img-new*)
|
|
(data :pointer))
|
|
(let* ((file-dialog (gobj:pointer-object file-dialog 'gtk:file-dialog))
|
|
(data (glib::get-object (cffi:pointer-address data)))
|
|
(img-original (first data))
|
|
(*img-new* (second data)))
|
|
(funcall
|
|
(gtk::attach-restarts
|
|
(lambda ()
|
|
(alexandria:when-let ((gfile (ignore-errors (gtk:file-dialog-open-finish file-dialog result))))
|
|
(setf *pixbuf-original* (gdk-pixbuf:pixbuf-add-alpha (gdk-pixbuf:make-pixbuf :filename
|
|
(gio:file-path gfile))
|
|
nil 0 0 0))
|
|
(setf *pixbuf-new* (gdk-pixbuf:pixbuf-copy *pixbuf-original*))
|
|
(setf (gtk:image-from-pixbuf img-original) *pixbuf-original*)
|
|
(setf (gtk:image-from-pixbuf *img-new*) *pixbuf-new*)))))))
|
|
|
|
(gtk:define-main-window (window (gtk:make-application-window :application gtk:*application*))
|
|
(setf (gtk:window-title window) "Image editor")
|
|
(let ((grid (gtk:make-grid))
|
|
(title (gtk:make-label :str "Kaprishev имаге едиторс"))
|
|
(img-original (gtk:make-image))
|
|
(file-button (gtk:make-button :label "Učitaj datoteku"))
|
|
|
|
(button-box (gtk:make-box :orientation gtk:+orientation-vertical+ :spacing 5)))
|
|
(setf *img-new* (gtk:make-image)) ; FIXME: temporary workaround
|
|
(let ((font-desc (pango:pango_font_description_new)))
|
|
(pango:pango_font_description_set_size font-desc (* 36 pango:pango_scale))
|
|
(let ((attr (pango:pango_attr_font_desc_new font-desc))
|
|
(attr-list (pango:pango_attr_list_new)))
|
|
(pango:pango_attr_list_insert attr-list attr)
|
|
(setf (gtk:label-attributes title) attr-list)))
|
|
|
|
(setf (gtk:widget-halign title) gtk:+align-center+)
|
|
(setf (gtk:widget-hexpand-p title) t)
|
|
|
|
(setf (gtk:widget-size-request img-original) '(200 200))
|
|
(setf (gtk:widget-size-request *img-new*) '(200 200))
|
|
(setf (gtk:widget-hexpand-p img-original) t
|
|
(gtk:widget-vexpand-p img-original) t)
|
|
(setf (gtk:widget-hexpand-p *img-new*) t
|
|
(gtk:widget-vexpand-p *img-new*) t)
|
|
|
|
(gtk:connect file-button "clicked"
|
|
(lambda (button)
|
|
(declare (ignore button))
|
|
(let ((file-chooser (gtk:make-file-dialog))
|
|
(image-filter (gtk:make-file-filter)))
|
|
(gtk:file-filter-add-mime-type image-filter "image/*")
|
|
(setf (gtk:file-dialog-default-filter file-chooser) image-filter)
|
|
(gtk:file-dialog-open file-chooser
|
|
window
|
|
nil
|
|
(cffi:callback open-file-callback)
|
|
; since we want to make modifications to the parent
|
|
; window we will pass it to the callback as user-data
|
|
; (list img-original *img-new*)
|
|
(cffi:make-pointer (glib::put-object (list img-original *img-new*)))))))
|
|
|
|
(dolist (item *function-alist*)
|
|
(let ((button (gtk:make-button :label (car item))))
|
|
(gtk:connect button "clicked" (cdr item))
|
|
(gtk:box-append button-box button)))
|
|
|
|
(setf (gtk:window-child window) grid)
|
|
|
|
; TODO: add buttons with dynamic list ()
|
|
|
|
(gtk:grid-attach grid title 0 0 3 1)
|
|
(gtk:grid-attach grid img-original 0 1 1 1)
|
|
(gtk:grid-attach grid file-button 0 2 1 1)
|
|
|
|
(gtk:grid-attach grid *img-new* 2 1 1 1)
|
|
|
|
(gtk:grid-attach grid button-box 1 1 1 1))
|
|
(unless (gtk:widget-visible-p window)
|
|
(gtk:window-present window))))
|