;;; -*-Emacs-Lisp-*-

;;; To do:
;; The interactive functions should check that they're in the right buffer
;; (namely, database buffer) before executing.
;; Should omit deceased brothers from some reports.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Noninteractive functions
;;;

;;; These combine several fields to give a single result.

;; This should truncate middle names to a single letter, if there's a full
;; first name there.

(defun tep-record-fullname (record database)
  (concat (record-field record 'first-name database) " "
	  (record-field record 'last-name database)
	  (let ((jr (record-field record 'jr database)))
	    (if (empty-string-p jr)
		""
	      (concat ", " jr)))))

(defun tep-record-biz-address (record database)
  (let ((title (record-field record 'biz-title database))
	(company-name (record-field record 'biz-company-name database))
	(address (record-field record 'biz-address database)))
    (if (not (empty-string-p address))
	(concat
	 (if (empty-string-p title)
	     ""
	   (concat title "\n"))
	 (if (empty-string-p company-name)
	     ""
	   (concat company-name "\n"))
	 address "\n"
	 (record-field record 'biz-city database) ", "
	 (record-field record 'biz-state database) " "
	 (record-field record 'biz-zip database)))))

(defun tep-record-home-address (record database)
  (let ((address (record-field record 'home-address database)))
    (if (not (empty-string-p address))
	(concat
	 address "\n"
	 (record-field record 'home-city database) ", "
	 (record-field record 'home-state database) " "
	 (record-field record 'home-zip database)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Change hooks
;;;

;; These should display a message admitting what they've just done.
;; (Not if they ask the user first, perhaps.)

;; Change hooks return t if the record should be redisplayed.

(setq db-after-read-hooks
      (function (lambda ()
	 (setq dbf-first-change-function 'tep-contact-date)

	 (setq dbf-reset-on-edit-list
	       '((tep-homeaddr-oldified . nil) (tep-homephone-oldified . nil)
		 (tep-bizaddr-oldified . nil) (tep-bizphone-oldified . nil)))

	 (dbf-set-change-function 'home-address 'tep-homeaddr-change-hook)
	 (dbf-set-change-function 'home-city 'tep-homeaddr-change-hook)
	 (dbf-set-change-function 'home-state 'tep-homeaddr-change-hook)
	 (dbf-set-change-function 'home-zip 'tep-homeaddr-change-hook)
	 (dbf-set-change-function 'home-phone 'tep-homephone-change-hook)

	 (dbf-set-change-function 'biz-address 'tep-bizaddr-change-hook)
	 (dbf-set-change-function 'biz-city 'tep-bizaddr-change-hook)
	 (dbf-set-change-function 'biz-state 'tep-bizaddr-change-hook)
	 (dbf-set-change-function 'biz-zip 'tep-bizaddr-change-hook)
	 (dbf-set-change-function 'biz-phone 'tep-bizphone-change-hook))

	 (setq db-after-read-hooks nil)
		))

;;;
;;; Defeat the change hooks
;;;

;; This is moot now that the user is always queried before changes are made
;; anyway.

(defun tep-fix-typo ()
  (interactive)
  "Prevent contact-date, old address fields from changing when record is edited."
  (if (not (db-format-buffer-p))
      (error "Only call tep-fix-typo in a database format buffer."))
  (setq tep-homeaddr-oldified t)
  (setq tep-homephone-oldified t)
  (setq tep-bizaddr-oldified t)
  (setq tep-bizphone-oldified t)
  ;; defeat first-change-function, at a small price if the record isn't changed
  (dbf-set-this-record-modified-p t))


;;;
;;; Contact date
;;;

(defun tep-contact-date (fieldname oldvalue newvalue)
  "Put the current date in this record's `contact date' field."
  (dbf-this-record-set-field 'contact-date
			     (let ((now (current-time-string)))
			       (concat (substring now 4 8)
				       (substring now 8 11)
				       (substring now 20)))))

;; Add "defeat" mechanisms for phone as well.

;;;
;;; Home address
;;;

;; All the obnoxious questions are asked because it's too easy to
;; accidentally knock out the old home address when making a minor edit.

(defvar tep-homeaddr-oldified nil)
(defvar tep-homephone-oldified nil)

(defun tep-homeaddr-change-hook (fieldname oldvalue newvalue)
  (if (and (not tep-homeaddr-oldified)
	   (y-or-n-p "Move previous home address to old home address fields? "))
      (progn
	(dbf-this-record-set-field 'old-home-address
				   (if (eq fieldname 'home-address)
				       oldvalue
				     (record-field dbf-this-record 'home-address
						   dbc-database)))
	(dbf-this-record-set-field 'old-home-city
				   (if (eq fieldname 'home-city)
				       oldvalue
				     (record-field dbf-this-record 'home-city
						   dbc-database)))
	(dbf-this-record-set-field 'old-home-state
				   (if (eq fieldname 'home-state)
				       oldvalue
				     (record-field dbf-this-record 'home-state
						   dbc-database)))
	(dbf-this-record-set-field 'old-home-zip
				   (if (eq fieldname 'home-record)
				       oldvalue
				     (record-field dbf-this-record 'home-zip
						   dbc-database)))
	(setq tep-homeaddr-oldified t)
	t)
    (progn
      (setq tep-homeaddr-oldified t)
      nil)))

(defun tep-homephone-change-hook (fieldname oldvalue newvalue)
  (if (and (not tep-homephone-oldified)
	   (y-or-n-p "Move previous home phone to old-home-phone field? "))
      (progn
	(dbf-this-record-set-field 'old-home-phone oldvalue)
	(setq tep-homephone-oldified t)
	t)
    (progn 
      (setq tep-homephone-oldified t)
      nil)))

;;;
;;; Business address
;;;

(defvar tep-bizaddr-oldified nil)
(defvar tep-bizphone-oldified nil)

(defun tep-bizaddr-change-hook (fieldname oldvalue newvalue)
  (if (and (not tep-bizaddr-oldified)
	   (y-or-n-p "Move previous business address to old business address fields? "))
      (progn
	(dbf-this-record-set-field 'old-biz-address
				   (if (eq fieldname 'biz-address)
				       oldvalue
				     (record-field dbf-this-record 'biz-address
						   dbc-database)))
	(dbf-this-record-set-field 'old-biz-city
				   (if (eq fieldname 'biz-city)
				       oldvalue
				     (record-field dbf-this-record 'biz-city
						   dbc-database)))
	(dbf-this-record-set-field 'old-biz-state
				   (if (eq fieldname 'biz-state)
				       oldvalue
				     (record-field dbf-this-record 'biz-state
						   dbc-database)))
	(dbf-this-record-set-field 'old-biz-zip
				   (if (eq fieldname 'biz-record)
				       oldvalue
				     (record-field dbf-this-record 'biz-zip
						   dbc-database)))
	(setq tep-bizaddr-oldified t)
	t)
    (progn
      (setq tep-bizaddr-oldified t)
      nil)))

(defun tep-bizphone-change-hook (fieldname oldvalue newvalue)
  (if (and (not tep-bizphone-oldified)
	   (y-or-n-p "Move previous business phone to old-home-phone field? "))
      (progn
	(dbf-this-record-set-field 'old-biz-phone oldvalue)
	(setq tep-bizphone-oldified t)
	t)
    (progn
      (setq tep-bizphone-oldified t)
      nil)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Reports (except labels)
;;;

(defun tep-report-directory ()
  (let ((sysname (system-name)))
    (cond ((string-member sysname '("emu" "coot" "swallow"))
	   (expand-file-name "~mernst/tep/db/report/"))
	  ;; Assume we're on athena
	  (t
	   "/mit/tep/Alumni/Database/Report/"))))

;;;
;;; All four reports
;;;

(defun tep-all-reports ()
  (interactive)

  (tep-year-report)
  (tep-firstname-report)
  (tep-nickname-report)
  ;; This is last so the database is left in a reasonable sorted order.
  (tep-address-report)
  (message "Wrote four *-report.out files.")
  )

;;;
;;; Abstraction
;;;

(defmacro tep-report (filename sort-fieldnames fixup-body)
  (` (let ((dbf-buffer (current-buffer)))
       (database-sort
	dbc-database

	(list
	 (mapcar (function (lambda (fieldname)
		    (list (fieldname->fieldnumber fieldname dbc-database))))
		  (, sort-fieldnames))))
       (dbf-finished-sorting)
       
       (db-report (concat (tep-report-directory) (, filename)))
       
       ;; We're now in the *Database Report* buffer.
       (, fixup-body)
       
       (write-file (concat (tep-report-directory) (, filename) ".out"))
       (message (concat "Wrote " (, filename) ".out"))
       
       (switch-to-buffer dbf-buffer))))


;;;
;;; Address report
;;;

(defun tep-address-report ()
  (interactive)

  ;; I should include the contact date in this report.

  (tep-report
   "address-report"
   '(last-name first-name)
   ;; I realize this is a crock.  Cut me some slack!  I'll fix it later.
   (tep-prettify-address-report)))

;; Make the address report in this buffer look nicer.
(defun tep-prettify-address-report ()
  (progn
    ;; Get rid of "Parents" (if address != "house") or "house"
    (goto-char (point-min))
    (replace-string "house\n,  \n\nPar" "Squar")
    (goto-char (point-min))
    ;; Assumes one one line in parents' address.
    (replace-regexp "Parents:\\\n.*\\\n.*\\\n.*\\\n.*\\\nBus" "Bus")
    (goto-char (point-min))
    (replace-string "Squaren" "Paren")

     (goto-char (point-min))
     (replace-string "\n\n" "\n")
     (goto-char (point-min))
     (replace-string "Business:\n,  \n-" "-")
     (goto-char (point-min))
     ;; Get rid of empty "Jr." parts of names.
     (replace-string ", \n" "\n")
     (goto-char (point-min))
     (replace-string "\n \n" "\n")
     (goto-char (point-min))
     (replace-string ",  \n" "\n")
     (goto-char (point-min))
     (replace-string "\n\n" "\n")
     (goto-char (point-min))
     (replace-string "-----" "")
     (goto-char (point-min))
     (replace-string "Business:\n\n" "")
     (goto-char (point-min))
     (replace-string "\n\n\n" "\n\n")
     ))


;;;
;;; Year report
;;;

(defun tep-year-report ()
  (interactive)

  (tep-report "year-report"
	      '(class-year last-name)
	      ;; Get rid of empty "Jr." parts of names.
	      (replace-string ",  \\\\\n" " \\\\\n")))      
  
;;;
;;; Firstname report
;;;

(defun tep-firstname-report ()
  (interactive)

  ;; (I need to ignore the middle initial in this sorting.)
  (tep-report "firstname-report"
	      '(first-name last-name)
	      nil))

;;;
;;; Nickname report
;;;

(defun tep-nickname-report ()
  (interactive)

  (tep-report "nickname-report"
	      '(nickname)
	      (progn
		;; Get rid of empty "Jr." parts of names.
		(replace-string ",  \\\\\n" " \\\\\n")
		;; Get rid of lines with no nickname.
		(goto-char (point-min))
		(delete-matching-lines "^ "))))

;;;
;;; Old code
;;;

;; (defun tep-address-report ()
;;   (interactive)
;; 
;;   ;; Sort on last name.
;;   (progn
;;     (database-sort
;;      dbc-database
;;      (list (list (list (fieldname->fieldnumber 'last-name dbc-database))
;; 		 (list (fieldname->fieldnumber 'first-name dbc-database)))))
;;     (dbf-finished-sorting))
;; 
;;   (db-report (concat tep-report-directory "address-report"))
;; 
;;   ;; We're now in the *Database Report* buffer.
;; 
;;   ;; I realize this is a crock.  Cut me some slack!
;;   (progn
;;     (goto-char (point-min))
;;     (replace-string "\n\n" "\n")
;;     (goto-char (point-min))
;;     (replace-string "Business:\n,  \n-" "-")
;;     (goto-char (point-min))
;;     (replace-string ", \n" "\n")
;;     (goto-char (point-min))
;;     (replace-string "\n \n" "\n")
;;     (goto-char (point-min))
;;     (replace-string ",  \n" "\n")
;;     (goto-char (point-min))
;;     (replace-string "\n\n" "\n")
;;     (goto-char (point-min))
;;     (replace-string "-----" "")
;;     (goto-char (point-min))
;;     (replace-string "Business:\n\n" ""))
;; 
;;   (write-file (concat tep-report-directory "address-report.out"))
;; 
;;   (switch-to-previous-buffer-other-window 2))

;; (defun tep-year-report ()
;;   (interactive)
;; 
;;   ;; Sort on year.
;;   (progn
;;     (database-sort
;;      dbc-database
;;      (list (list (list (fieldname->fieldnumber 'class-year dbc-database))
;; 		 (list (fieldname->fieldnumber 'last-name dbc-database)))))
;;     (dbf-finished-sorting))
;; 
;;   (db-report (concat tep-report-directory "year-report"))
;;   
;;   (replace-string ",  \\\\\n" " \\\\\n")
;; 
;;   (write-file (concat tep-report-directory "year-report.out"))
;; 
;;   (switch-to-previous-buffer-other-window 2))

;; (defun tep-firstname-report ()
;;   (interactive)
;; 
;;   ;; Sort on firstname, lastname.
;;   ;; (I need to ignore the middle initial in this sorting.)
;;   (progn
;;     (database-sort
;;      dbc-database
;;      (list (list (list (fieldname->fieldnumber 'first-name dbc-database))
;; 		 (list (fieldname->fieldnumber 'last-name dbc-database)))))
;;     (dbf-finished-sorting))
;; 
;;   (db-report (concat tep-report-directory "firstname-report"))
;; 
;;   (write-file (concat tep-report-directory "firstname-report.out"))
;;   
;;   (switch-to-previous-buffer-other-window 2))

;; (defun tep-nickname-report ()
;;   (interactive)
;; 
;;   ;; Sort on nickname.
;;   (progn
;;     (database-sort
;;      dbc-database
;;      (list (list (list (fieldname->fieldnumber 'nickname dbc-database)))))
;;     (dbf-finished-sorting))
;; 
;;   (db-report (concat tep-report-directory "nickname-report"))
;; 
;;   (replace-string ",  \\\\\n" " \\\\\n")
;; 
;;   (write-file (concat tep-report-directory "nickname-report.out"))
;; 
;;   (switch-to-previous-buffer-other-window 2))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Labels
;;;

;; Results go into the *TEP labels* buffer.
;; Save to a file (say, in the reports directory).
;; Run TeX (not LaTeX) on ~/tex/make-labels.tex to process the output.
;; Print make-labels.dvi.

(defun tep-labels ()
  (interactive)
  (let ((db dbc-database))
    (maprecords
     (function (lambda (record)
		 (let ((name (tep-record-fullname record dbc-database))
		       (address (if (string-equal "B" (record-field
						       record 'address-preferred
						       dbc-database))
				    (tep-record-biz-address record dbc-database)
				  (tep-record-home-address record dbc-database))))
		   ;; (message "found name %s and address %s" name)
		   (if address
		       (princ (format "%s\n%s\n\n" name address)
			      (get-buffer-create "*TEP labels*"))))))
     dbc-database)))


;; only marked records, I think
(defun tep-labels ()
  (interactive)
  (let ((db dbc-database)
	record)
    (maplinks
     (function (lambda (link)
		 (setq record (link-record link))
		 (let ((name (tep-record-fullname record dbc-database))
		       (address (if (string-equal "B" (record-field
						       record 'address-preferred
						       dbc-database))
				    (tep-record-biz-address record dbc-database)
				  (tep-record-home-address record dbc-database))))
		   ;; (message "found name %s and address %s" name)
		   (if address
		       (princ (format "%s\n%s\n\n" name address)
			      (get-buffer-create "*TEP labels*"))))))
     dbc-database
     t))
  (switch-to-buffer-other-window "*TEP labels*"))

(defun tep-local-labels ()
  (interactive)
  ;; Go to state field.
  (db-first-field)
  (db-next-field 8)
  ;; Select local alumni:  those with "MA" in the state.  (C-u M-s ma RET)
  (db-search-field "MA" t)
  (db-omit-unmarked-records)
  (db-view-mode)
  ;; Sort on class year.
  (database-sort dbc-database '(((3))))
  ;; Create labels.
  (tep-labels))

;; As of 3/23/92, the file make-labels.tex looked like this, without the
;; leading "; " on each line.
; \input labels
; \vlbls=11 \hlbls=3
; \vfirst=0pt
; \hfirst=0pt
; \vinter=0pt
; \hinter=0pt
; \vlblsize=1in
; \hlblsize=2.833in
; % \vindent
; % \hindent
; 
; % \lbloutline=0.5pt
; 
; % \erroraction=1
; 
; \font\twelverm=cmr12
; \twelverm
; 
; \message{What is the label file? }
; \read-1 to\labeldatafile
; 
; \labelfile{\labeldatafile}
; \bye