;;; dragbox-test.el --- dragbox - draw a bounding box interactively

;;; Commentary:
;; draw a bounding box on an image.
;; needs an Emacs with svg support compiled in.

;; Author: Joakim Verona, (C) FSF 2009, GPL

;;; History:
;; 

(require 'image-mode)
(require 'xml)

(if (not (image-type-available-p 'svg))
    (error "No svg available!"))


;;arbitrary image size, for testing
;;; Code:
(setq dragbox-image-width 744)
(setq dragbox-image-height 1052)

;;initial bounding box
(setq dragbox-x1y1 '(0 . 0))
(setq dragbox-x2y2 '(100 . 100))

(setq dragbox-image-url "")

(defun dragbox-start (image-file)
  "Start here with an IMAGE-FILE suitable for svg embedding."
  (interactive "fImage file:")
  
  (get-buffer-create "*dragbox*")
  (switch-to-buffer  "*dragbox*")
  (setq dragbox-image-url (concat "file://" (expand-file-name image-file)))
  (dragbox-update-box-from-state))


(defun dragbox-make-svg-data (x y width height image-url)
  "Return svg describing a image file with a bounding box ontop.
X Y WIDTH HEIGHT describes the box, IMAGE-URL which image to draw on."
  `((svg
         ((xmlns:dc . "http://purl.org/dc/elements/1.1/")
          (xmlns:cc . "http://creativecommons.org/ns#")
          (xmlns:rdf . "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
          (xmlns:svg . "http://www.w3.org/2000/svg")
          (xmlns:xlink . "http://www.w3.org/1999/xlink")
          (xmlns . "http://www.w3.org/2000/svg")
          (width . ,(number-to-string dragbox-image-width))
          (height . ,(number-to-string dragbox-image-height))
          (id . "svg2"))
         (g
          ((id . "layer1"))
          (rect
           ((style . "fill:#cfcfcf;fill-opacity:1")
            (width . ,(number-to-string dragbox-image-width))
            (height . ,(number-to-string dragbox-image-height))
            (x . "0")
            (y . "0")))
          (image ((y . "0")
                  (x . "0")
                  (width . ,(number-to-string dragbox-image-width))
                  (height . ,(number-to-string dragbox-image-height))
                  (xlink:href . ,image-url)
                 ))
          (rect
           ((style . "color:#000000;fill:#000000;fill-opacity:0.5;fill-rule:nonzero;stroke:#000000;stroke-width:1;marker:none;visibility:visible;display:inline;overflow:visible;enable-background:accumulate;stroke-opacity:0.5")
            (id . "dragbox")
            (width . , (number-to-string width) )
            (height . ,(number-to-string height))
            (x . ,(number-to-string x))
            (y . ,(number-to-string y))))
          ))))

(defun dragbox-lmb-click-handler ()
  "Set upper left coords for bounding box."
            (interactive)
            (setq dragbox-x1y1 (dragbox-extract-event-coords last-input-event))
            (dragbox-update-box-from-state)
            )

(defun dragbox-rmb-click-handler ()
  "Set lower right coords for bounding box."
            (interactive)
            (setq dragbox-x2y2 (dragbox-extract-event-coords last-input-event))
            (dragbox-update-box-from-state)
            )

(defun dragbox-extract-event-coords (event)
  "Get the coordinates from click EVENT."
   (caddr(cadr last-input-event))
  )

;;bind the handlers to lmb and rmb
(define-key image-mode-map [down-mouse-1] 'dragbox-lmb-click-handler)
(define-key image-mode-map [down-mouse-2] 'dragbox-rmb-click-handler)


(defun dragbox-update-box (x y width height)
  "Redraw the bounding box, given X Y WIDTH and HEIGHT ontop of the image."
  ;;this implementation doest seem very efficient
  (fundamental-mode)
  (erase-buffer)
  (xml-print (dragbox-make-svg-data x y width height dragbox-image-url))
  (image-mode)
    )

(defun dragbox-update-box-from-state ()
  "Redraw bounding box from global state ontop of image."
  (let*
      ((x1 (car dragbox-x1y1))
       (y1 (cdr dragbox-x1y1))
       (x2 (car dragbox-x2y2))
       (y2 (cdr dragbox-x2y2))
       (w (- x2 x1))
       (h (- y2 y1)))
    (message "(%d %d) (%d %d) w:%d h:%d" x1 y1 x2 y2 w h)
    (dragbox-update-box
     x1
     y1
     w
     h)))

                      


(provide 'dragbox-test)

;;; dragbox-test.el ends here