;;###########################################################################
;; author.lsp
;; contains code to implement guidetools for authoring guidemaps, 
;; the graphical hypertext-hypercode system for guiding data analysts.
;; Copyright (c) 1992-95 by Forrest W. Young
;;###########################################################################

(require "vista" (strcat *vista-dir-name* "vista"))

;;###########################################################################
;;define functions that are used by author menu items
;;###########################################################################

(defun copyitem (item)
  (let ((old-selected-icon (send *expertmap* :selected-icon))
        (xy (send *expertmap* :locate-new-icon))
        )
    (send *expertmap* :add-icon 
          *expertmap* (select xy 0) (select xy 1) 
                                    (string-right-trim " ..." item) 6)))
  
(defun make-flow-icon (title)
  (let ((old-selected-icon (send *expertmap* :selected-icon))
        (xy (send *expertmap* :locate-new-icon))
        )
    (send *expertmap* :add-icon 
          *expertmap* (select xy 0) (select xy 1) title 7)))

(defun and-icon () (make-flow-icon " "))

(defun auto-link-icon ()
  (let ((name (get-string-dialog "Name of GuideMap Linked To ...")))
    (when (and name (> (length name) 0)) 
          (make-flow-icon (strcat "Link:" name)))))

(defun auto-return-icon () (make-flow-icon "Return"))

(defun goto-button ()
  (let ((result (goto-dialog)))
    (case (first result)
      (0 (copyitem "GoTo:New Data"))
      (1 (copyitem "GoTo:Model"))
      (2 (if (equal "" (second result)) 
             (error-message 
              "You must specify a name for the named data object.")
             (copyitem (strcat "GoTo:" (second result))))))))

(defun goto-dialog ()
  (let* ((box-text-item (send text-item-proto :new
                              "Choose GoTo Button for going to:"))
         (choice-item (send choice-item-proto :new (list
                           "Most Recently Created Data Object"
                           "Most Recently Created Model Object"
                           "Data Object Named:")
                           :value 0))
         (text-item (send edit-text-item-proto :new "" :text-length 7
                          :location (list 165 78)))
         (ok-button (send modal-button-proto :new "OK"
                         :action #'(lambda ()
                                     (let ((dialog (send ok-button :dialog)))
                                       (list (send choice-item :value)
                                             (send text-item :text))))))

         (cancel-button (send modal-button-proto :new "Cancel"))
                 
         (dialog (send modal-dialog-proto :new 
                       (list box-text-item
                             (list choice-item
                                   text-item)
                             (list ok-button cancel-button))
                       :default-button ok-button)))
    (send dialog :modal-dialog)
    ))

(defun return-button ()
  (copyitem "Return"))

(defun link-button ()
  (let ((name (get-string-dialog "Name of GuideMap Linked To ...")))
    (when (and name (> (length name) 0)) 
          (copyitem (strcat "Link:" name)))))

(defun connect-objects ()
  (let* ((in-icon-num (send *expertmap* :selected-icon))
         (in-icon (select (send *expertmap* :icon-list) in-icon-num))
         )
    (send *expertmap* :connect-icons 
          (send *expertmap* :previously-selected-icon) in-icon-num :new t)
    (when (= 7 (send in-icon :icon-type))
          (send in-icon :num-in-connections 
                (+ (send in-icon :num-in-connections) 1)))))

(defmeth workmap-proto :initial-button ()
  (let ((ab-list (send self :active-button-list))
        (sel-icon (send self :selected-icon)))
    (if (not ab-list)
        (send *expertmap* :active-button-list (list sel-icon))
        (send *expertmap* :active-button-list (combine ab-list sel-icon)))))

(defun author (&optional (logical nil set) &key new)
"Args: (&optional logical &key new)
Enables the authoring of guidemaps.
With no arguments, reports whether ViSta is in author mode (t) or not (nil). Places system in author mode when optional argument of t is used, and switches system out of author mode when optional argument of nil is used. When keyword argument :new is used with a value of t, a new, blank, author guidemap is created.  Without :new (or when used with value nil) an existing guidemap is used if one exists."
  (if set (send *vista* :expert logical))
  (when set (cond 
              ((send *vista* :expert)
               (when (or new (not *expertmap*))
                     (when (author) (author nil))
                     (send *vista* :expert t)
                     (setf *expertmap* (workmap))
                     (send *expertmap* :title "Author's WorkBench")
                     (apply #'send *expertmap* :size 
                            (send *vista* :guide-window-size))
                     (apply #'send *expertmap* :location 
                            (send *vista* :guide-window-location))
                     (defmeth-expert-connect-icons)
                     (send *expertmap* :has-h-scroll nil)
                     (send *expertmap* :has-v-scroll nil)
                     (defmeth *expertmap* :close () 
                       (author nil)
#+macintosh            (send *workmap* :size 490 280)
#+msdos                (send *workmap* :size 500 280))
                     )
               (send *expertmap* :gui t)
#+macintosh    (send *workmap* :size 243 280)
#-macintosh    (send *workmap* :size 246 280)
               (send *expert-menu* :install))
              ((when *expertmap*)
#-msdos        (send *workmap* :size 490 280)
#+msdos        (send *workmap* :size 500 280)
               (send *expertmap* :gui nil)
               (send *expert-menu* :remove))))
  (send *vista* :expert))

(defun defmeth-expert-connect-icons ()
(defmeth *expertmap* :connect-icons (icon-number-out icon-number-in 
                                                       &key new)
  (let* ((icon-out (select (send self :icon-list) icon-number-out))
         (x-out (send icon-out :x))
         (y-out (send icon-out :y))
         (icon-in  (select (send self :icon-list) icon-number-in))
         (x-in  (send icon-in  :x))
         (y-in  (send icon-in  :y))
         (center-out (ceiling (/ (send icon-out :width) 2)))
         (center-in  (ceiling (/ (send icon-in  :width) 2)))
         (below-out  (send icon-out :height))
         (constant   10)
         (right-move (- (+ x-in (* 2 center-in) constant) 
                        (+ x-out center-out)))
         (top-move   (- y-in y-out below-out 16))
         (left-move (+ center-in constant))
         )
    (when (> right-move 0) 
          (setf right-move (- x-in constant (+ x-out center-out)))
          (setf left-move (- left-move)))
    (when (<  (+ y-out below-out 15) y-in)
          (setf right-move (- right-move left-move))
          (setf left-move 0))
    (send self :frame-poly 
          (list
           (list (+ x-out center-out) 
                 (+ y-out below-out))
           '(0 10)
           (list right-move 0) 
           (list 0 top-move)
           (list (- left-move)  0)
           '(0 5) '(-3 -3) '(6 0) '(-3 3)) nil)
    (when new 
          (let ((to-list 
                 (select (send self :connection-list) icon-number-out))
                )
            (setf to-list (remove 'nil (combine to-list icon-number-in)))
            (setf (select (send self :connection-list) icon-number-out)
                  to-list))))))


;;###########################################################################
;;define save-dialog and save-workmap methods for workmap proto so that 
;;author workmap can be saved. Used only by author menu items.
;;###########################################################################

(defmeth workmap-proto :save-dialog ()
  (let* ((dialog-text (send text-item-proto :new "SAVE GUIDEMAP ..."))
         (file-text (send text-item-proto :new "in Guidance Folder as File:"))
         (title-text (send text-item-proto :new "with Title:"))
#+macintosh (tl 14)
#-macintosh (tl 24)
         (file  (send edit-text-item-proto :new "" :text-length tl))
         (title (send edit-text-item-proto :new "" :text-length tl))
         (cancel (send modal-button-proto :new "Cancel"))
         (ok     (send modal-button-proto :new "OK" :action #'(lambda ()
                       (list (send file  :text)
                             (send title :text)))))
         )
    (send modal-dialog-proto :new
          (list dialog-text
                file-text
                file
                title-text
                title
                (list ok cancel))
         :default-button ok))) 

(defmeth workmap-proto :save-workmap ()
"Args: none
A dialog is presented to obtain the name of the file to save the workmap in, and the title of the window the guidemap will be shown in.  The workmap is written in the file in a form suitable for use by the guidemap proto."
  (let ((dialog-values (send (send self :save-dialog) :modal-dialog))
        )
  (when dialog-values
        (let ((file (string-downcase (first dialog-values)))
              (title (second dialog-values))
              )
          (when (= (length file) 0)
                (error "You must specify a file name."))
          (when (= (length title) 0) (setf title "GuideMap"))
          (when (and (> (length file) 3)
                     (string= ".lsp" file
                              :start2 (- (length file) 4)))
                (setf file (string-right-trim "lsp" file))
                (setf file (string-right-trim "." file)))
          (format t "; saving ~s~%" file)
          (let* ((f (open (strcat *guide-dir-name* file ".lsp")
                          :direction :output))
                 (name (intern (string-upcase (strcat "*" file "*"))))
                 (oldbreak *breakenable*)
                 )
          (setq *breakenable* nil)
          (unwind-protect
           (princ "(let " f)
           (print `((,name *hidden-guidemap*)) f)
           (print `(send ,name :title ,title) f)
           (print `(send ,name :num-icons 
                         ,(send self :num-icons)) f)
           (print `(send ,name :connection-list 
                        ',(send self :connection-list)) f)
           (print `(send ,name :x ',(send self :x)) f)
           (print `(send ,name :y ',(send self :y)) f)
           (print `(send ,name :icon-type 
                        ',(send self :icon-type)) f)
           (print `(send ,name :icon-title 
                        ',(send self :icon-title)) f)
           (print `(send ,name :icon-number-list 
                        ',(send self :icon-number-list)) f)
           (print `(send ,name :redraw-order 
                        ',(send self :redraw-order)) f)
           (print `(send ,name :selected-icon 
                         ,(send self :selected-icon)) f)
           (print `(send ,name :toolbar t) f) 
           (print `(send ,name :num-data-icons 
                         ,(send self :num-data-icons)) f)
           (print `(send ,name :num-model-icons 
                         ,(send self :num-model-icons)) f)
           (print `(send ,name :data-icon-number-list 
                        ',(send self :data-icon-number-list)) f)
           (print `(send ,name :model-icon-number-list 
                        ',(send self :model-icon-number-list)) f)
           (print `(send ,name :selected-data-icon 
                         ,(send self :selected-data-icon)) f)
           (print `(send ,name :previously-selected-data-icon 
                         ,(send self :previously-selected-data-icon)) f)
           (print `(send ,name :num-data-menu-items 
                         ,(send self :num-data-menu-items)) f)
           (print `(send ,name :num-model-menu-items
                         ,(send self :num-model-menu-items)) f)
           (print `(send ,name :active-button-list
                        ',(send self :active-button-list)) f)
           (print `(let ((n ',(send self :num-icons))
                         (x ',(send self :x))
                         (y ',(send self :y))
                         (icon-title ',(send self :icon-title))
                         (icon-type  ',(send self :icon-type ))
                         (icon-list nil)
                         )
                     (dotimes (i n)
                         (setf icon-list (combine icon-list
                           (make-icon ,name 
                              (select x i) (select y i)
                              (select icon-title i) (select icon-type  i)
                              )))
                         (send ,name :icon-list (rest icon-list))))
                  f)
           (print `(send ,name :data-icon-list 
                         (select (send ,name :icon-list) 
                                 (send ,name :data-icon-number-list)))
                  f)
           (print `(send ,name :model-icon-list 
                         (select (send ,name :icon-list) 
                                 (send ,name :model-icon-number-list)))
                  f)
           (let ((icon-type-7 (which (= 7 (send self :icon-type))))
                 )
             (when icon-type-7
              (dolist 
               (i icon-type-7)
               (print `(send (select (send ,name :icon-list) ,i)
                             :num-in-connections
                             ,(send (select (send self :icon-list) i)
                                    :num-in-connections)) f)
               (print `(send (select (send ,name :icon-list) ,i)
                             :num-in-connected-now 0) f))))
           (princ ")" f)
           )
          (setq *breakenable* oldbreak)
          (close f)
          (format t "; finished saving ~s~%" file)
          f)))))
