(in-package :clim-user)

;; Draggable presentations

(defclass draggable-presentation (standard-presentation) ())  

(define-application-frame draggable-presentation-demo () ()
  (:pane (make-pane 'application-pane
		    :width :compute
		    :height :compute
		    :display-function 'generate-graph
		    :display-time t)))

(defun generate-graph (frame pane)
  (format-graph-from-roots
   (list (find-class 'number))
   (lambda (object stream)
     (present (clim-mop:class-name object)
	      (presentation-type-of object)
	      :stream stream
	      :record-type 'draggable-presentation))
   #'clim-mop:class-direct-subclasses
   :stream pane))

(define-draggable-presentation-demo-command (com-drag-record)
  ((record t)
   (x 'real)
   (y 'real))
  (multiple-value-bind (px py) (output-record-position record)   
    (let ((parent (output-record-parent record))	
	  (x-offset (- x px))
	  (y-offset (- y py)))
      (erase-output-record record *standard-output*)
      (multiple-value-bind (final-x final-y)
	  (drag-output-record *standard-output* record
			      :erase-final t
			      :finish-on-release t)
	(setf (output-record-position record)
	      (values (- final-x x-offset) (- final-y y-offset)))
	(add-output-record record parent)
	(repaint-sheet *standard-output* record)))))
         
(define-presentation-to-command-translator record-dragging-translator
  (t com-drag-record draggable-presentation-demo
     :tester ((presentation)
	      (typep presentation 'draggable-presentation)))
  (presentation x y)
  (list presentation x y))