(in-package :ccl)

#| ######################################################################

 Miscellaneous FRED hacks

Copyright © 1994-97 Michael Travers 

Permission is given to use and modify this code
as long as the copyright notice is preserved.

Send questions, comments, and fixes to mt@media.mit.edu.

-------------------------------------------------------------------------

Some of this material is copied or modified from
examples;assorted-fred-commands.lisp.

Contents:
- Key commands for font style changes
- Improved M-( 
- window changing commands (C-X O C-X N, C-X P)
- fill screen with window (C-X 1)
- eliminate ellipses in displayed pathnames
- auto-fill and fill-paragraph (improved from apple-supplied versions)
- interface to compare
- date insertion commands (C-X T)
- count lines command (C-X =)

See also: kbd-macros.lisp

History:
5/2/95 00:14:   Spiffed up for release, redid date/time insertion commands
5/29/95 11:45:  Fixed font commands for CCL3
7/2/95 16:10:   ed-font-change-plain will also set color to black.
7/2/95 20:31    fix c-x c-i to use last returned value if necessary
7/17/95 14:55   make one-window work again
8/22/95 23:31   for CCL2 -- no :color option in font-change-plain
6/3/96 19:54:   added count-lines on C-X =
7/5/97 19:54:   fix c-x n, c-x p, prepare for release

###################################################################### |#

;;; font style commands

(defmacro make-font-command (char attribute &optional (symbol (intern (concatenate 'string "ED-FONT-CHANGE-" (string attribute)))))
  `(progn
     (defmethod ,symbol ((v fred-mixin))
       (#-CCL-3 set-view-font #+CCL-3 ed-set-view-font v ,attribute))
     (comtab-set-key *comtab* ',char ',symbol)))

;;; These must be accessed with actual control key, not Command
(make-font-command (:control :meta :shift #\B) :bold)
(make-font-command (:control :meta :shift #\I) :italic)
(make-font-command (:control :meta :shift #\P) `(:plain #+CCL-3 (:color ,*black-color*)) ed-font-change-plain)

;;; M-( command and friends

;;; The built in M-) bites bigtime, this is somewhat more reasonable.
(defmethod ed-move-over-or-insert-close ((w fred-mixin))
  (let* ((buf (fred-buffer w))
         (pos (buffer-position buf)))
    (let ((kill (ed-kill-selection w)))
      (if (and (not kill)
               (not (eq pos (buffer-size buf)))
               (eq (buffer-char buf) #\)))
        (ed-forward-char w)
        (ed-insert-char w #\))))))

;;; Ditto for this (but the version in MCL3 is better)
#-CCL-3 
(defmethod ed-insert-parens ((w fred-mixin) &aux (buf (fred-buffer w)))
  (multiple-value-bind (start end) (selection-range w)
    (if (= start end)
      (progn (ed-insert-with-undo w "()")
             (move-mark buf -1))
      (ed-delimit-selection w "(" ")"))))

;(comtab-set-key *comtab* #\[ 'ed-insert-parens)
;(comtab-set-key *comtab* #\] 'ed-move-over-close-and-reindent)
;(comtab-set-key *comtab* #\( 'ed-insert-[)
;(comtab-set-key *comtab* #\) 'ed-insert-])
(comtab-set-key *comtab* #\( 'ed-insert-parens)
;(comtab-set-key *comtab* #\) 'ed-move-over-close-and-reindent)
(comtab-set-key *comtab* #\) 'ed-move-over-or-insert-close)

;;; Window changing commands

;;; From assorted-fred-commands, modified to restrict operations to fred-windows.
; C-X O moves to the next window that is not a listener.
; C-X N moves the top window to the bottom.
; C-X P moves the bottom window to the top.

(defmethod ed-other-window ((w fred-mixin))
  (setq w (view-window w))
  (if *modal-dialog-on-top*
    (ed-beep)
    (let ((other-window #'(lambda (window)
                            (unless (or (eq w window) 
                                        (typep window 'listener)
                                        (not (typep window 'fred-window)))
                              (window-select window)
                              (return-from ed-other-window window)))))
      (declare (dynamic-extent other-window))
      (map-windows other-window))))

(defmethod ed-next-window ((w fred-mixin))
  (set-window-layer (view-window w) 10000)
  (window-select (car (windows :class 'fred-window))))

(defmethod ed-previous-window ((w fred-mixin))
  (let ((last (car (last (windows :class 'fred-window)))))
    (when last
      (window-select last))))

(comtab-set-key *control-x-comtab* '(#\o) 'ed-other-window)
(comtab-set-key *control-x-comtab* '(#\n) 'ed-next-window)
(comtab-set-key *control-x-comtab* '(#\p) 'ed-previous-window)

;;; Miscellaneous commands

; C-M-W toggles line wrapping.
(defun ed-toggle-wrap-p (w)
  (setf (fred-wrap-p w) (not (fred-wrap-p w))))

(comtab-set-key *comtab* '(:control :meta #\w) 'ed-toggle-wrap-p)

(defconstant *wsp&cr* #.(let ((str (make-string 7)))
                          (set-schar str 0 #\Space)
                          (set-schar str 1 #\^I)
                          (set-schar str 2 #\^L)
                          (set-schar str 3 #\^@)
                          (set-schar str 4 #\^J)
                          (set-schar str 5 (%code-char #xCA))
                          (set-schar str 6 #\newline)
                          str))

(defmethod paragraph-bounds ((w fred-mixin))
  (multiple-value-bind (b e) (selection-range w)
    (when (eq b e)
      (let* ((buf (fred-buffer w)))
        (setq b (buffer-backward-find-char buf #\newline))
        (if b
          (loop
            (if (<= b 0) (return))
            (let ((b2 (buffer-backward-find-char buf #\newline b 0)))
              (unless b2 (return (setq b 0)))
              (unless (buffer-forward-find-not-char buf *wsp&cr* b2 b)
                (return (incf b)))
              (setq b b2)))
          (setq b 0))
        (setq e (buffer-forward-find-char buf #\newline))
        (if e
          (loop
            (if (>= e (buffer-size buf)) (return))
            (let ((e2 (buffer-forward-find-char buf #\newline e)))
              (unless e2 (return (setq e (buffer-size buf))))
              (unless (buffer-forward-find-not-char buf *wsp&cr* e e2)
                (return (decf e)))
              (setq e e2)))
          (setq e (buffer-size buf)))))
    (values b e)))

(defmethod ed-fill-paragraph ((w fred-mixin))
  (multiple-value-bind (b e) (paragraph-bounds w)
    (unless (eq b e)
      (let* ((buf (fred-buffer w))
             (margin (or (view-get w 'fill-margin) (- (point-h (view-size w)) 72)))
             (prefix (view-get w 'fill-prefix))
             (bmark (make-mark buf b t))
             (emark (make-mark buf e))
             (string (buffer-substring buf b e))
             (style (buffer-get-style buf b e))
             p last-word-end wsp-end done?)
        (unwind-protect
          (progn
            (setq e (make-mark buf e))
            (setq p b)
            (loop
              (setq p (buffer-forward-find-char buf *wsp&cr* p e))
              (if p 
                (progn
                  (setq wsp-end (buffer-forward-find-not-char buf *wsp&cr* p e)
                        p (1- p)
                        wsp-end (if wsp-end (1- wsp-end) e))
                  (buffer-delete buf p wsp-end)
                  (buffer-insert buf " " p))
                (setq p (buffer-position e) wsp-end p done? t))
              (if (> (buffer-string-width buf b p) margin)
                (progn
                  (unless last-word-end
                    (if done? (return))
                    (setq last-word-end p))
                  (buffer-delete buf last-word-end (1+ last-word-end))
                  (buffer-insert buf #\newline last-word-end)
                  (setq b (1+ last-word-end)
                        p b)
                  (if (>= p (buffer-position e)) (return))
                  (when prefix
                    (buffer-insert-with-style buf (car prefix) (cdr prefix) b)
                    (incf p (length (car prefix))))
                  (setq last-word-end nil))
                (progn
                  (setq last-word-end p)
                  (incf p)))
              (if done? (return))))
          (setup-undo w #'(lambda ()
                            (buffer-delete bmark (buffer-position bmark) (buffer-position emark))
                            (buffer-insert-with-style bmark string style)
                            (fred-update w))))))))

(comtab-set-key *comtab* '(:meta #\q) 'ed-fill-paragraph)

;;; A better auto fill than apple provides (but adapted from it).
;;; Deals with variable width fonts.
;;; Missing (because I don't care much):  fill prefix, filling to other than window size 

(defun auto-fill-or-insert (w)
  (let* ((buf (fred-buffer w))
         (margin (or (view-get w 'fill-margin) (point-h (view-size w))))
         (beg (or (ccl::buffer-backward-find-char buf #\Newline) 0))
         (here (buffer-position buf)))
    (when (> (ccl::buffer-string-width buf beg here) margin)
      (do ((break-pos here 
                      (buffer-char-pos buf ccl::*wsp&cr* :start 0 :end break-pos
                                       :from-end t)))
          ((or (null break-pos)
               (<= (ccl::buffer-string-width buf beg break-pos) margin))
           (when break-pos
             (buffer-char-replace buf #\return break-pos)
             (set-fred-hscroll w 0)
;             (ed-indent-for-lisp w (1+ break-pos))
             ))))
    (if (eql *current-character* #\space)
      (interactive-arglist w)
      (ed-self-insert w))))

; (comtab-set-key *comtab* #\Space 'auto-fill-or-insert)

;;; keyboard macros have their own file now.

(defmethod one-window ((v fred-mixin))
  (let* ((w (view-window v))
         (zoomed? (view-get w :zoomed)))
    (if zoomed?
      (progn (set-view-size w (car zoomed?))
             (set-view-position w (cdr zoomed?))
             (view-put w :zoomed nil))
      (progn
        (view-put w :zoomed (cons (view-size w) (view-position w)))
        (window-zoom-event-handler w 8)))))

(comtab-set-key *control-x-comtab* #\1 'one-window "Fill the screen with this window")

;;; Don't use annoying ellipses that elide the disk name
;;; from ccl:l1;l1-edwin
(defun pathname-to-window-title (pathname)
  (when pathname ; ??
    (let* ((name (file-namestring pathname))
           (directory (directory-namestring pathname))
           (host (pathname-host pathname))
           ;(name-len (length name))
           ;(dir-len (length directory))
           ;(total-len (+ name-len dir-len))
           )
      (when (and host (neq host :unspecific))
        (setq directory (%str-cat host ":" directory)))
      (%str-cat name " {" directory "}"))))

;;; do truename in compare, so that aliased files will work right.
(defun pathname-to-window (pathname &aux wpath)
  (setq pathname (or (probe-file pathname)
                     (probe-file (merge-pathnames pathname *.lisp-pathname*))
                     ;Default type to :unspecific, since that's what
                     ;a window-filename would have.
                     (let ((fpath (full-pathname pathname)))
                       (if (null fpath)
                         (file-namestring pathname) 
                         (merge-pathnames fpath #1P"")))))
  (dolist (w1 (windows :include-invisibles t))
    (if (and (setq wpath (window-filename w1))
             (or (equalp pathname wpath)
                 (equalp pathname (ignore-errors (truename (full-pathname wpath))))))   ; mt -- added truename
      (return w1))))

;;; from fred-additions.lisp
;;; if no sexp is available, use last returned value
#+CCL-3
(defmethod ed-info-current-sexp ((w fred-mixin))
  (multiple-value-bind (b e) (ed-current-sexp-bounds w)
    (if (eq b e)
      (inspect (symbol-value-in-process '* (window-process (view-window w))))
      (inspect (ed-current-sexp w e)))))

;;; Interface to compare

(comtab-set-key *control-x-comtab* #\D #'(lambda (w) 
                                           (require :compare)
                                           (eval-enqueue `(compare-buffer-to-file ,w)))
                "Compare top *fred-window* to selected file")

(comtab-set-key *control-x-comtab* #\d #'(lambda (w)
                                           (require :compare)
                                           (eval-enqueue `(compare-buffer-to-other-buffer ,w)))
                "Compare top *fred-window* to selected other buffer")



;;; based on AlanR code
(defmethod ed-insert-date/time ((f fred-mixin)) 
  (insert-string f (mt:date-time-string (get-universal-time))))

(defmethod ed-insert-short-date/time ((f fred-mixin))
  (insert-string f (mt:short-date-time-string (get-universal-time))))

(defmethod insert-string ((f fred-mixin) string)
  (let* ((buf (fred-buffer f))
         (start (buffer-position buf))
         end)
    (buffer-insert buf string)
    (setf end (buffer-position buf))
    (when (fred-prefix-argument f)
      (buffer-set-font-spec buf :bold start end)
      (buffer-set-font-spec buf :plain))))

(comtab-set-key *control-x-comtab* (keystroke-code '(:control #\t)) 'ed-insert-date/time)
(comtab-set-key *control-x-comtab* (keystroke-code #\t) 'ed-insert-short-date/time)



; +++ misplaced: nothing to do with FRED
#-CCL-3
(defun report-time (form thunk)
  (let* ((initial-real-time (get-internal-real-time))
         (initial-run-time (get-internal-run-time))
         (initial-gc-time (gctime))
         (initial-consed (total-bytes-allocated)))
    (multiple-value-prog1 (funcall thunk)
      (let* ((s *trace-output*)
             (bytes-consed (- (total-bytes-allocated) initial-consed))
             (elapsed-real-time (- (get-internal-real-time) initial-real-time))
             (elapsed-run-time (- (get-internal-run-time) initial-run-time))
             (elapsed-gc-time (- (gctime) initial-gc-time))
             (elapsed-mf-time (- elapsed-real-time elapsed-run-time)))
        (format s "~&~S took ~D milliseconds (~,3F seconds) to run."
                form elapsed-real-time (/ elapsed-real-time internal-time-units-per-second))
        (format s "~& (~D msec actual runtime)"
                elapsed-run-time)
        (when (> elapsed-mf-time 0)
          (format s "~%Of that, ~D milliseconds (~,3F seconds) were spent in The Cooperative Multitasking Experience."
                  elapsed-mf-time (/ elapsed-mf-time internal-time-units-per-second)))
        (unless (eql elapsed-gc-time 0)
          (format s "~%")
          (unless (> elapsed-mf-time 0)
            (format *trace-output* "Of that, "))
          (format s
                  "~D milliseconds (~,3F seconds) was spent in GC."
                  elapsed-gc-time (/ elapsed-gc-time internal-time-units-per-second)))
        (unless (eql 0 bytes-consed)
          (format s "~% ~D bytes of memory allocated." bytes-consed))
        (format s "~&")))))

(defmethod ed-count-lines ((f fred-mixin))
  (clear-mini-buffer-maybe f)
  (set-mini-buffer f "~D lines" (lines-in-buffer (fred-buffer f))))

(comtab-set-key *control-x-comtab* (keystroke-code #\=) 'ed-count-lines)