(defpackage :simulation (:use :clim :clim-lisp))
(in-package :simulation)

(defvar *places* (make-hash-table :test #'equal))
(defvar *arcs*   (make-hash-table :test #'equal))



(defclass graphical-view (view)
  ())

(defparameter +graphical-view+ (make-instance 'graphical-view))

(defclass place ()
  ((name :initarg :name :accessor name-of)
   (point :initarg :point :accessor point-of
	  :initform (make-point 156 68))
   (container :initarg :container :accessor container-of
	      :initform 0)))

(defun make-place (name x y &optional container)
  (let ((place (make-instance 'place :name name
			      :point (make-point x y))))
    (when container
      (setf (container-of place) container))
    place))

(defclass arc ()
  ((name :initarg :name :accessor name-of)
   (start :initarg :start :accessor start-of
	  :initform nil)
   (end :initarg :end :accessor end-of
	  :initform nil)
   (count :initarg :count :accessor count-of
	  :initform 0)))

(define-application-frame simulation ()
  ()
  (:panes (place  :application
		  :display-function #'draw-simulation
		  :default-view +graphical-view+
		  :incremental-redisplay t)
	  (interactor :interactor :height 163
		      :scroll-bars t))
  (:layouts (default-default (vertically () place interactor))))

(define-presentation-to-command-translator move-place-translator
    (place com-move-place simulation
	   :documentation "Move the place")
    (presentation x y)
  (list presentation x y))

(defmethod update-arrows (place stream x1 y1 x y draw)
  (setf (point-of (presentation-object place)) (make-point x y))
  (repaint-sheet (find-pane-named *application-frame* 'place) +everywhere+))

(define-simulation-command (com-move-place)
    ((place 'place) (x 'real) (y 'real))
  (erase-output-record place *standard-output*)
  (setf x y) ;; ignore x y
  
  (drag-output-record *standard-output* place 
		      :finish-on-release t
		      :feedback #'update-arrows )
      (repaint-sheet *standard-output* place))

  

(defun draw-simulation (frame pane)
  (declare (ignore frame))
  (maphash (lambda (key val)
	     (declare (ignore key))
	     (present val 'place :stream pane))
	   *places*)
  (maphash (lambda (key val)
	     (declare (ignore key))
	     (present val 'arc :stream pane))
	   *arcs*))


(define-presentation-method present (place (type place) stream
					   (view graphical-view) &key)
  (clim:draw-circle stream
                    (point-of place)
                    10
                    :ink +black+ :filled (plusp (container-of place)))
  (clim:draw-circle stream
                    (point-of place)
                    15
                    :ink +black+ :filled nil))


(define-presentation-method present (arc (type arc) stream
					 (view graphical-view) &key)
  (with-slots (start end) arc
    (when (and start end)
      (clim:draw-arrow  stream 
			(point-of start)
			(point-of end)
			:ink +black+))))



(define-simulation-command (com-quit :name t :menu t ;; show in menu
				     :keystroke (#\q :meta)) ;; a keystroke
    ()
  (frame-exit *application-frame*))


(let ((foo (make-place "foo" 50 50))
      (bar (make-place "bar" 100 100)))
  
  (setf (gethash "foo" *places*) foo
	(gethash "bar" *places*) bar
	(gethash "arc1" *arcs*)	(make-instance  'arc :name "The arc"
						:start foo
						:end  bar)))

(defun start-sim ()
  (clim:run-frame-top-level (clim:make-application-frame 'simulation)))