(in-package :cube-modeller)

(defun scroll-clim-stream (stream &key (x-delta 0) (y-delta 0))
  (multiple-value-bind (x y)
      (stream-cursor-position stream)
    (setf (stream-cursor-position stream)
          ;; (stream-cursor-position stream) was replaced by (cursor-position (stream-text-cursor stream))
          ;; by mgr on 20060906 as a work-around.  Seems not to be necessary anymore after an mvclim update.
          ;; (Could've been only a silly problem of a certain, old lisp-core..)
          (values (+ x x-delta)
                  (+ y y-delta)))))

(defun write-string-centered (string &optional (stream *standard-output*)
                                               (adjust 0))
  (let* ((string-width (text-size stream string))
         (stream-width (slot-value stream 'climi::current-width)))
    (scroll-clim-stream stream :x-delta (- (round (/ (- stream-width string-width)
                                                     2))
                                           adjust))
    (write-string string stream)))

(defun throw-command (command)
  (climi::throw-object-ptype
   (climi::make-menu-item "Ephremal Command" :command command)
   'menu-item))


(defun find-process-with-name (name)
  (apply #'values
         (remove-if-not (lambda (process)
                          (string= name (process-name process)))
                        (all-processes))))

(defun destroy-process-with-name (name)
  (mapcar #'destroy-process
          (multiple-value-list (find-process-with-name name))))

(defmacro define-application-starter (application-frame-name &key
                                      (function-name (intern "RUN-GUI" *package*))
                                      default-width
                                      default-height
                                      (default-process-name (format nil "~:(~s~)" application-frame-name))
                                      complain-about-existing-process
                                      (announce-to-clim-launcher t))
  `(multiple-value-prog1
    (defun ,function-name (&key new-process
                           (process-name ,default-process-name)
                           (width ,default-width)
                           (height ,default-height)
                           frame-manager-name ;; in order to test the 'clim-internals::pixie/clx-look
                           force-restart
                           (debugger #'clim-debugger:debugger))
     (when (find-process-with-name process-name)
       (if force-restart
           (destroy-process-with-name process-name)
           (when ,complain-about-existing-process
             (restart-case (error ,(format nil "There seems to be a running instance of the ~(~s~) process."
                                           application-frame-name))
               (|do-nothing| nil
                 :report "Just return without doing anything more."
                 (return-from ,function-name))
               (|don't-care| nil
                 :report "Just run the gui again and don't care about the running process." nil)
               (|destroy-process| nil
                 :report ,(format nil "Destroy old ~(~s~) process and make a new one."
                                  application-frame-name)
                 (destroy-process-with-name process-name))))))
     
     (let ((frame (if frame-manager-name
                      (make-application-frame ',application-frame-name
                                              :width width
                                              :height height
                                              :frame-manager (make-instance frame-manager-name
                                                                            :port (find-port)))
                      (make-application-frame ',application-frame-name
                                              :width width
                                              :height height)))
           (sb-ext:*invoke-debugger-hook* debugger))
       (flet ((run ()
                (run-frame-top-level frame)))
         (if new-process
             (make-process (lambda ()
                             (run)
                             (destroy-process-with-name process-name))
                           :name process-name)
             (run)))
       frame))
     (when (and ,announce-to-clim-launcher
                (find-package :clim-launcher)
                (fboundp (intern "ADD-APPLICATION" :clim-launcher)))
       (funcall (intern "ADD-APPLICATION" :clim-launcher)
                ,default-process-name
                (lambda ()
                  (funcall #',function-name :new-process t))))))