;;; -*- Mode:Lisp; Package:GMACS; Base:10; -*-

;;;		LastEditDate =  21:01:56  Sat, 08-Apr-89  -- Mark Boggs

(in-package :GMACS)

(if (not (boundp 'user::*stuff-loaded*))
   (if (probe-file "c:\\jesus\\dypar\\stuff.lsp")
	(load "stuff")))

(defun #:noise ())
(def-x-key     #\Z      'scroll-down)
(def-x-key     #\c-Z    'scroll-up)
(def-x-key     #\N      'other-window)
(def-x-key     #\c-N    'message-form)
(def-key       #\F5     'copy-line)
(def-key       #\F6     'copy-region) 	; also on m-w
(def-key       #\m-1    'line-to-top-of-window)
(def-key       #\m-0    'load-me)

;;; keyboard patches to repair the damage caused by a poor driver.
(def-key       #\c-m-3  'insert-sharp-sign)
(def-key       #\c-m-2  'insert-at-sign)
(def-key       #\c-m-5  'insert-upcaret)
(def-key       #\c-m-6  'insert-tilde)
(def-key       #\c-m-1  'insert-vertical-bar)
(def-key       #\c-m-\' 'insert-left-curly-bracket)
(def-key       #\c-m-/  'insert-right-curly-bracket)
(def-key       #\c-m-+  'insert-left-square-bracket)
(def-key       #\c-m-=  'insert-right-square-bracket)
(def-key       #\c-m-\\	'insert-backslash)

;;; Because of the brain-damaged behaviour of the gmacs keyboard we need
;;; to add these functions to allow us to insert our favorite ascii
;;; characters.  These functions are bound (see above) to the c-m
;;; positions they occupy on the keyboard with the exception of 
;;; left-square-bracket (shifted right-square-bracket)  and upcaret (c-m-5)
;;; The `Alt Gr' key serves as the control-meta prefix.
;;; NOTE: version Beta 3 FIXES the keyboard so it is no longer possible to
;;; enter accented characters with the old two stroke method!!!!

(defun insert-sharp-sign ()
  (insert-string "#"))   
(defun insert-tilde ()
  (insert-string "~"))
(defun insert-at-sign ()
  (insert-string "@"))
(defun insert-vertical-bar ()
  (insert-string "|"))
(defun insert-backslash ()
  (insert-string "\\"))
(defun insert-upcaret ()
  (insert-string "^"))
(defun insert-left-curly-bracket ()
  (insert-string "{"))
(defun insert-right-curly-bracket ()
  (insert-string "}"))
(defun insert-left-square-bracket ()
  (insert-string "["))
(defun insert-right-square-bracket ()
  (insert-string "]"))

;;; Finally we add a function which allows us to enter arbitrary characters
;;; If the user enters a non-integer we display the current character set.
(defcom insert-character
	(:any-arg :ignore)
	()
  (edx-msg "ASCII character code: ")
  (let ((arg (read)))
    (if (numberp arg)
	(insert-string (princ-to-string (int-char arg)))
        (type-out (format nil "Available ASCII characters and their codes")
	  (do ((n 33 (+ n 12)))
	      ((>= n 296))
;	    (if (= n 69) (setq n 91))
;	    (if (= n 103) (setq n 123))
	    (format t " ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~
		        ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A~&"
		    n (int-char n)
		    (+ n 1) (int-char (+ n 1))
		    (+ n 2) (int-char (+ n 2))
		    (+ n 3) (int-char (+ n 3))
		    (+ n 4) (int-char (+ n 4))
		    (+ n 5) (int-char (+ n 5))
		    (+ n 6) (int-char (+ n 6))
		    (+ n 7) (int-char (+ n 7))
		    (+ n 8) (int-char (+ n 8))
		    (+ n 9) (int-char (+ n 9))
		    (+ n 10) (int-char (+ n 10))
		    (+ n 11) (int-char (+ n 11))))))))

;(dotimes (x 255) (princ x) (princ (int-char x)))
;;; This is where gmacs thinks the characters are.  This mapping does not
;;; agree with the behaviour in the interpreter or in DOS
;;; 32   33 ! 34 " 35 # 36 $ 37 % 38 & 39 ' 40 ( 41 ) 42 * 43 + 44 , 45 -
;;; 46 . 47 / 48 0 49 1 50 2 51 3 52 4 53 5 54 6 55 7 56 8 57 9 58 : 59 ;
;;; 60 < 61 = 62 > 63 ? 64 @ 65 A 90 Z 91 [ 92 \ 93 ] 94 ^ 95 _ 96 ` 97 a
;;; 122 z 123 { 124 | 125 } 126 ~ 127  128 � 129 � 130 � 131 � 132 � 133 �
;;; 134 � 135 � 136 � 137 � 138 � 139 � 140 � 141 � 142 � 143 � 144 � 145 �
;;; 146 � 147 � 148 � 149 � 150 � 151 � 152 � 153 � 154 � 155 � 156 � 157 �
;;; 158 � 159 � 160 � 161 � 162 � 163 � 164 � 165 � 166 � 167 � 168 � 169 �
;;; 170 � 171 � 172 � 173 � 174 � 175 � 176 � 177 � 178 � 179 � 180 � 181 �
;;; 182 � 183 � 184 � 185 � 186 � 187 � 188 � 189 � 190 � 191 � 192 � 193 �
;;; 194 � 195 � 196 � 197 � 198 � 199 � 200 � 201 � 202 � 203 � 204 � 205 �
;;; 206 � 207 � 208 � 209 � 210 � 211 � 212 � 213 � 214 � 215 � 216 � 217 �
;;; 218 � 219 � 220 � 221 � 222 � 223 � 224 � 225 � 226 � 227 � 228 � 229 �
;;; 230 � 231 � 232 � 233 � 234 � 235 � 236 � 237 � 238 � 239 � 240 � 241 �
;;; 242 � 243 � 244 � 245 � 246 � 247 � 248 � 249 � 250 � 251 � 252 � 253 �
;;; 254 �

(defun message-form ()
  (insert-string "(add-message '
  :english 
  :spanish 
  )"))


(pushindent 'typeout '(1 1))
(pushindent 'format '(2 1))

(if (not (find-package "DYPAR"))
    (make-package "DYPAR")
    (progn
      ;(defindent funl lambda)
      (pushindent 'dypar::funl '(1 1))
      ;(defindent dlet let)
      (pushindent 'dypar::dlet '(1 1))
      ;(defindent def-op defun)
      (pushindent 'dypar::def-op '(4 1))))

;(defun load-me (&aux (file (namestring (send *THIS-BUFFER*
;					     :buffer-pathname))))
;  (when (send *THIS-BUFFER* :modified-p)
;    (send *THIS-BUFFER* :save-file))
;  (format t " Loading ~A ..." file)
;  (load file))

;;; Save and load the current buffer.
(defcom load-me
        (:any-arg :ignore)
        (&aux (file (namestring (send *THIS-BUFFER* :buffer-pathname))))
  (when (send *THIS-BUFFER* :modified-p)
    (send *THIS-BUFFER* :save-file))
  (type-out (format nil " Loading ~A ..." file)
    (load file)))

;;; FROM gcl3_1\gmacs\0858\gmacsini.smp

(def-key     #\M-*      'whats-the-time)

;;; Defines a keychord with the "Control-X prefix".
(def-x-key   #\U        'undo-definition)
(def-x-key   #\M-U      'find-unbalanced-parens)

;;;; Editor Variables.

;;;; Some sample user-defined hooks.
;;;  Some are variables containing functions to be funcalled.

;;; Fn to call before current buffer is DeSelected.
;;; The function is passed one argument: the current buffer object.
(defglobal '*BUFFER-DESELECT-HOOK* nil)

;;; Fn to call after new buffer is Selected.
;;; The function is passed one argument: the newly selected buffer object.
(defglobal '*BUFFER-SELECT-HOOK* 'update-edit-line2)

(defun filt-apropos-loc (symbol &optional package (test #'fboundp) inherited)
  (let ((pkg (and package (find-package package)))
	(lst))
    (if (null pkg)
	(dolist (sym (apropos-list symbol))
	  (and (or (null test)
		   (funcall test sym))
	       (push sym lst)))
	(if inherited
	    (dolist (sym (apropos-list symbol pkg))
	      (and (or (null test)
		       (funcall test sym))
		   (push sym lst)))
	    (dolist (sym (apropos-list symbol pkg))
	      (if (eql (symbol-package sym) pkg)
		  (and (or (null test)
			   (funcall test sym))
		       (push sym lst))))))
    (sort lst #'string-lessp)))

(defcom local-apropos
	(:any-arg :ignore)
	()
  (edx-msg "Apropos string: ")
  (let ((arg (read)))
    (edx-msg "Apropos package: ")
    (let ((arg2 (read)))
      (type-out
;	  (format nil "  Package: ~S   Symbol: ~S" arg2 arg)
	  (format nil "~{~S~%~}" (filt-apropos-loc arg arg2))))))

(defcom update-edit-line
        (:any-arg :ignore)
        (&aux (file (namestring (send *THIS-BUFFER* :buffer-pathname))))
  (beginning-of-buffer)
  (if (progn (ignore-errors (forward-search "LastEdit"))
	     (and (eql (current-right-char) #\D) (or (forward-char) t)
		  (eql (current-right-char) #\a) (or (forward-char) t)
		  (eql (current-right-char) #\t) (or (forward-char) t)
		  (eql (current-right-char) #\e) (or (forward-char) t)
		  (eql (current-right-char) #\space) (or (forward-char) t)
		  (eql (current-right-char) #\=) (or (forward-char) t)
		  (eql (current-right-char) #\space) (or (forward-char) t)))
      (kill-line)
      (progn
	(beginning-of-buffer)
	(next-line)
	(insert-string (format nil "~&\;\;\;		LastEditDate = ~&"))
	(backward-char)))
  (multiple-value-bind (datestring day month year)
      (readable-dos-date)
    (insert-string (format nil " ~A ~A, ~A -- Mark Boggs"
		     (readable-dos-time)
		     (day-of-week day month (+ year 1900))
		     datestring)))
  (unmodify-buffer))

(defun update-edit-line2 (&rest args)
  (beginning-of-buffer)
  (if (progn (ignore-errors (forward-search "LastEdit"))
	     (and (eql (current-right-char) #\D) (or (forward-char) t)
		  (eql (current-right-char) #\a) (or (forward-char) t)
		  (eql (current-right-char) #\t) (or (forward-char) t)
		  (eql (current-right-char) #\e) (or (forward-char) t)
		  (eql (current-right-char) #\space) (or (forward-char) t)
		  (eql (current-right-char) #\=) (or (forward-char) t)
		  (eql (current-right-char) #\space) (or (forward-char) t)))
      (kill-line)
      (progn
	(beginning-of-buffer)
	(next-line)
	(insert-string (format nil "~&\;\;\;		LastEditDate = ~&"))
	(backward-char)))
  (multiple-value-bind (datestring day month year)
      (readable-dos-date)
    (insert-string (format nil " ~A ~A, ~A -- Mark Boggs"
		     (readable-dos-time)
		     (day-of-week day month (+ year 1900))
		     datestring)))
  (unmodify-buffer))

;(setf (symbol-function 'LISP-MODE-ENTER-HOOK)
;      'update-edit-line2)
;      (symbol-function 'update-edit-line2))

;;;; An example of changing the indentation of forms

;;; Use this if you prefer this indentation style of IF:
;;;   (if test
;;;       then
;;;       else)
(PUSHINDENT 'IF nil)

;;; Use this if you prefer this indentation style of IF:
;;;   (if test
;;;       then
;;;     else)
; (PUSHINDENT 'IF '(2 1))

;;;; Some sample user-defined commands.

;;; Useful for message to user.
(defcom whats-the-time
        (:any-arg :ignore)
        ()
  (multiple-value-bind (datestring day month year)
      (readable-dos-date)
    (edx-msg "It is now ~Aon ~A, ~A" (readable-dos-time)
             (day-of-week day month (+ year 1900))
             datestring)))

;;; A useful command
(defcom indent-region
	(:any-arg :ignore)
	()
  ;; REGION-LINES:  MACRO, binds L1 to first line in the region, and L2
  ;; to the last one.
  (region-lines
    (l1 l2)
    ;; RETURNING-HERE: MACRO, comes back to this point when done
    (returning-here
      ;; LINES-FROM:  MACRO, iterates LINE over lines from L1 to L2
      (setf *curix* 0.) 		; go to column 0.
      (lines-from (line l1 l2)
	(setf *curln* line) 		; make LINE the current line
	(indent-line))))) 		; indent it

;;;; A couple of commands for finding the lines in a buffer that are
;;;  too long.  If a numeric argument is supplied, then find lines
;;;  longer than that length.  Otherwise, assume the width of the
;;;  GMACS screen.

(defcom find-long-line
	(:any-arg :implicit)
	(&aux (line *curln*)
	      (size *gmacs-window-width*) (forwardp t))
  (when (numberp *num-arg*)
    (setq size (abs *num-arg*))
    (setq forwardp (plusp *num-arg*)))
  (unless (next *curln*) 		; go back if at EOB
    (setq forwardp nil))
  (loop
    (when (>= (gline-length line) size)
      (setf *curln* line)
      (if (= size (gline-length *curln*))
	  (end-of-line)
	(setf *curix* size))
      (edx-msg (format nil "Found line of size ~d (> ~d)"
		       (gline-length *curln*) size))
      (return nil))
    (unless (setf line (if forwardp (next line) (prev line)))
      (edx-msg (format nil "No long line found (> ~d)" size))
      (return nil))))

;;; This command will go to the longest line in the buffer.
;;; If a numeric arg is supplied, it will only search from point to EOB.

(defcom longest-line
	(:any-arg :implicit)
	()
  (let ((max 0.)
	(thislen 0.)
	(maxline nil))
    (lines-from (line (if *num-arg* *curln* (bufstr-top *curln*))
		      (bufstr-end *curln*))
      (when (> (setq thislen (gline-length line)) max)
	(setq maxline line max thislen)))
    (set-pop-mark)
    (setq *curln* maxline)
    (end-of-line)))

;;; End.