;; -*- coding: utf-8-unix; -*-

;;;; Copyright (C) 2015 José Ronquillo Rivera <josrr@ymail.com>
;;;;
;;;; This library 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 library 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 library.  If not, see <http://www.gnu.org/licenses/>.

(ql:quickload 'mcclim)
(ql:quickload 'mcclim-freetype)
(ql:quickload 'mcclim-gif-bitmaps)

(defpackage #:display-image
  (:use #:clim
	#:clim-lisp))

(in-package #:display-image)

(define-application-frame img-viewer ()
  ((img-pattern :initform 'nil))
  (:panes
   (int-pane (make-clim-interactor-pane :name 'interactor))
   (canvas-pane (make-clim-application-pane
		 :name 'canvas
		 :scroll-bars t
		 :display-time :command-loop
		 :display-function #'draw-image)))
  (:layouts
   (default
       (vertically (:min-height 650 :max-height 800)
	 (3/4 (labelling (:label "Image") canvas-pane))
	 (1/4 int-pane))))
  (:menu-bar t))

(defmethod draw-image ((frame img-viewer) stream)
  (with-slots (img-pattern) *application-frame*
    (if img-pattern
	(draw-pattern* stream img-pattern
		       (/ (- (bounding-rectangle-width stream)
			     (pattern-width img-pattern)) 2)
		       0))))

(define-img-viewer-command (com-quit :name t :menu t) ()
  (frame-exit *application-frame*))

(define-img-viewer-command (com-change-img :name t :menu t)
    ((img-pathname 'pathname
		   :default (user-homedir-pathname)
		   :insert-default t))
  (if (and (probe-file img-pathname)
	   (string= "GIF"
		    (string-upcase (pathname-type img-pathname))))
      (with-slots (img-pattern) *application-frame*
	(setf img-pattern
	      (make-pattern-from-bitmap-file img-pathname
					     :format :gif)))))


(swank:create-server :port 4005 :style :spawn :dont-close t)
(run-frame-top-level (make-application-frame 'img-viewer))