;;; -*- Mode: Emacs-Lisp -*- 

;;; Customizations for genealogy files...


;;; These functions provide customizations to EDB for datafiles for
;;; the geneal program.

(require 'db-tagged)
(provide 'geneal)




;; Really only want these locally in format buffers showing geneal data bases
;; Eventually we'll do that with our own map and make these not be C-C prefix
;; in that map...
(define-key database-view-mode-map "\C-cp" 'goto-parent)
(define-key database-view-mode-map "\C-ch" 'goto-husband)
(define-key database-view-mode-map "\C-cw" 'goto-wife)
(define-key database-view-mode-map "\C-cm" 'goto-marriage)
(define-key database-view-mode-map "\C-cc" 'goto-child)
(define-key database-view-mode-map "\C-cg" 'geneal-goto-reference)
(define-key database-view-mode-map "\C-cn" 'geneal-renumber-record)
(define-key database-view-mode-map "\C-cd" 'geneal-set-description)


;;;; Setup the database description...


;;; Kludge to avoid a duplication bug somewhere in base EDB...
(defvar geneal-setup-done nil)
(make-variable-buffer-local 'geneal-setup-done)

;;; This function should be called once as the database file is set up
;;; to do all the local setup.
(defun geneal-setup ()
  (if geneal-setup-done
      (message "Genealogical database setup reentered.")
    (setq geneal-setup-done t)
    ;; General setup
    (db-tagged-setup geneal-field-specs)

    (database-make-local 'geneal-index-obarray database (make-vector 511 0))

    ;; Set formatting for geneal databases...
    (database-set-local 'db-tagged-separator-regexp database ":")
    (database-set-local 'db-tagged-separator-output database ":")
    (database-set-local 'db-tagged-continuation-regexp database "\\+")
    (database-set-local 'db-tagged-continuation-output database "+")
    (database-set-local 'db-tagged-tag-chars database "A-Z.")
    (dbf-set-summary-format "\\index\t\t\\record-description")

    ;; hang various functions on various hooks...
    (setq dbf-alternate-format-names geneal-alternate-format-names)
    (setq dbf-before-display-record-function 'geneal-set-format-from-data)
    (setq dbf-first-change-function 'geneal-set-edited-date)

    ;; Special hooks to handle the initial line
    (database-set-local 'db-tagged-rrfr-hooks database 'geneal-rrfr)
    (database-set-local 'db-tagged-wrfr-before-hooks database 'geneal-wrfr)
    ))
;;;; Field definitions...


(defconst geneal-field-specs '(
   ;; Information in all records, not really data...
   ((index . record-index) () "The identifying index for this record")
   (record-description ()
		"A name that may refer to the record (really a short comment)")
   ((type . record-type) "T" "Record type, one of: IFAR")
   ;; Name specification
   (name "N" "Name")
   (prefix-name "PN" "Prefix name (e.g. \"Dr.\")")
   (first-name "FN" "First Name")
   (middle-name "MN" "Middle name")
   (nickname "NN" "Nickname")
   (last-name "LN" "Last Name")
   (last-name-a "LN.A" "Adopted last name (i.e. by marriage)")
   (suffix-name "SN" "Suffix name (e.g. K.B.E.)")
   ;; landmarks...
   (date-of-birth "B" "Date of Birth")
   (birth-place "BP" "Place of Birth")
   ((sex . sex) "SX" "Sex, either F or M")
   (date-of-death "D" "Date of death")
   (place-of-death "DP" "Place of death")
   (buried "BUR" "Location of burial")
   (date-married "M" "Date married")
   (place-married "MP" "Place married")
   (marriage-end-date "MD" "Date marriage ended (e.g. by divorce)")
   (marriage-end-place "MDP" "Place marriage ended")
   ;; Cross references
   ((parents . record-ref) "P" "Parent family record")
   ((husband . record-ref) "H" "Husband of the marriage")
   ((wife . record-ref) "W" "Wife of the marriage")
   ((children . record-ref-list) "C" "List of children of this marriage")
   ((marriage . record-ref-list) "S" "Marriage record(s)")
   ;; Miscellaneous typed data
   ;;((addr . string) "ADDR"
   ;; "Used both for pointer to A type record and as the actual address")
   (addr "ADDR"
    "Used both for pointer to A type record and as the actual address")
   ((addr-ptr . record-ref) () "Reference to A record with address")
   (phone "PHONE" "")
   ((who . record-ref-list) "WHO" "Who this address belongs to")
   ;; Fields to hold additional descriptive text
   (gen "GEN" "General info??")
   (com "COM" "Comment")
   (comments "" "Comment")
   (tgen "TGEN" "Some kind of general notes")
   (tnote "TNOTE" "Some kind of notes")
   ;; Administrative fields
   (source "SOURCE" "Source of the info in this record")
   (edited "EDITED" "When the record was last edited")
   ))
;;;; General helper functions...

; This started out intending to be general purpose, it only got used one place
; and that really wanted different functionality...
;;  (defun geneal-lookup (ref db)
;;    "Takes a reference to another record and locates and returns that record.
;;  Returns NIL if no relevant record exists (for now only lookup on index)."
;;    (if (not (integerp ref))
;;        ref
;;      (let ((result nil))
;;        (maprecords (function
;;  		   (lambda (record)
;;  		     (if (= ref (record-field record 'index db))
;;  			 (setq result (cons record result)))))
;;  		  db)
;;        (cond ((null result) nil)
;;  	    ((null (cdr result)) (car result))
;;  	    (t				;Eventually not an error?
;;  	     (error "Multiple matches"))))))

(defun geneal-lookup (ref db)
  "Takes a record-ref and returns the relevant record, accepts ref as a
hard link to record, an integer, or a string representation of an int (or nil).
It returns the referenced record or NIL if no relevant record exists."
  (if (null ref)
      nil
    (if (vectorp ref)			;Actually want "recordp"
	ref
      (if (integerp ref) (setq ref (integer->string ref)))
      (if (not (stringp ref))
	  (error "Invalid genealogy reference type: %s" ref)
	(let ((sym (intern-soft ref
			(database-get-local 'geneal-index-obarray db))))
	  (if (boundp sym)
	      (symbol-value sym)
	    nil))))))

(defun geneal-set-edited-date (&optional fld old new)
  "Update the \"EDITED\" field in this record.  Called automatically when any
other field is updated."
  (dbf-this-record-set-field 'edited
			     (let ((now (current-time-string)))
			       (concat (substring now 8 10)
				       "-"
				       (substring now 4 7)
				       "-"
				       (substring now 20)))))


(defun db-jump-to-record-internal (r)
  "Function to jump to a given record in the database.
Takes the actual record as an arg, no movement if record not found."
  ;; Shouldn't it either error on not found or return a success/failure status??
  (dbf-goto-record-internal
    (maplinks-macro
     (if (eq r (link-record maplinks-link))
	 (progn
	   (dbc-set-index maplinks-index)
	   (setq dbc-link maplinks-link)
	   (maplinks-break)))
     dbc-database nil)))
;;;;	General function to follow a reference


(defun geneal-follow-reference (code inv typ arg)
  "Follow the reference from the current record in field CODE.  If a new
record is made to be the target of the reference, the back pointer should
be in the field INV and the record should be of type TYP.  Fourth argument
ARG is interactive prefix arg from original command, NIL (normal) means never
create a new record, also used to indicate which element of a list reference
should be followed (1 based).

Returns T if a new record was created, NIL otherwise.  This is so that
the caller can know to fill in fields that can be deduced."
  (let ((r (dbf-displayed-record-field code)))
    (cond ((null r)
	   (if (null arg)
	       (error "Reference not given in this record."))
	   ;; Make a new record of the right type
	   (setq r (make-default-record dbc-database))
	   (record-set-field r 'type dbc-database typ)
	   ;; Pick an index ...
	   (let ((idx (1+ (dbf-displayed-record-field 'index))))
	     (while (geneal-lookup idx dbc-database)
	       (setq idx (1+ idx)))
	     (record-set-field r 'index dbc-database idx)
	     ;; Set the pointer we were going to follow
	     (dbf-displayed-record-set-field code r)
	     ;; And the inverse pointer
	     (record-set-field r inv dbc-database dbf-this-record-original)
	     ;; Now install it in DB
	     (let* ((ob (database-get-local 'geneal-index-obarray dbc-database))
		    (sym (intern (integer->string idx) ob)))
	       (if (boundp sym) (error "Duplicate index %d" idx))
	       (set sym r))
	     (database-add-record r dbc-database (1+ dbc-index))
	     (db-jump-to-record-internal r)
	     t))
	  ((listp r)
	   (if (and (null arg) (= (length r) 1)) (setq arg 1))
	   (if (null arg) (error "Reference is a list, must give arg..."))
	   (if (listp arg) (setq arg (car arg)))
	   ;;user arg one based...nth is zero based
	   (setq r (nth (1- arg) r))
	   (if (integerp r) (error "Referenced record not in database."))
	   (if (null r) (error "Not that many references in list."))
	   (db-jump-to-record-internal r)
	   nil)
	  ((integerp r) (error "Referenced record not in database."))
	  (t
	   (db-jump-to-record-internal r)
	   nil)
	  )))
;;;; Special commands...

(defun goto-parent (arg)
  "Show parent's marriage entry."
  (interactive "P")
  (geneal-follow-reference 'parents 'children 'family arg))

(defun goto-husband (arg)
  "Show husband."
  (interactive "P")
  (if (geneal-follow-reference 'husband 'marriage 'individual arg)
      (dbf-displayed-record-set-field 'sex 'male))
  (dbf-redisplay-entire-record-maybe))

(defun goto-wife (arg)
  "Show wife."
  (interactive "P")
  (if (geneal-follow-reference 'wife 'marriage 'individual arg)
      (dbf-displayed-record-set-field 'sex 'female))
  (dbf-redisplay-entire-record-maybe))

(defun goto-marriage (arg)
  "Show marriage."
  (interactive "P")
  (geneal-follow-reference 'marriage
			   (if (eq (dbf-displayed-record-field 'sex) 'male)
			       'wife 'husband)
			   'family arg))

(defun goto-child (arg)
  "Show child."
  (interactive "P")
  (geneal-follow-reference 'children 'parents 'individual arg))

(defun geneal-goto-reference (n)
  "Goto the genealogy record with index N (can be given as prefix or prompted for)."
  (interactive "NGoto reference number:")
  (let ((r (geneal-lookup n dbc-database)))
    (if (null r) (error "Record not in database."))
    (db-jump-to-record-internal r)))

(defun geneal-renumber-record (n)
  "Change the index number of this record (as prefix or prompted for).
All linked records will record the change as well."
  (interactive "NNew reference number:")
  (let* ((ob (database-get-local 'geneal-index-obarray dbc-database))
	 (old-sym (intern (integer->string (dbf-displayed-record-field 'index))
			  ob))
	 (new-sym (intern (integer->string n) ob)))
    (if (boundp new-sym) (error "Index already used in database."))
    (if (not (eq (symbol-value old-sym) (dbf-displayed-record)))
	(error "Bad index table!"))
    (set new-sym (symbol-value old-sym))
    (makunbound old-sym)
    (dbf-displayed-record-set-field 'index n)
    (dbf-redisplay-entire-record-maybe)))
;;;; Automagic description setting ...


(defun geneal-set-description ()
  "Set the summary description of this record from data in the record."
  (interactive)
  (let* ((val "")
	 (rcd (dbf-displayed-record))
	 (typ (record-field rcd 'type dbc-database))
	 tmp)
    (cond ((eq typ 'individual) (setq val (geneal-individual-description rcd)))
	  ((eq typ 'family) (setq val (geneal-family-description rcd)))
	  ;;Also consider 'address and 'reference
	  (t (error "Can't automatically generate description of %s records"
		    typ))
	  )
    (dbf-displayed-record-set-field 'record-description (substring val 1))
    (dbf-redisplay-entire-record-maybe)))

(defun field-maybe (pfx fld sfx rcd db)
  ;; Only useful for below
  (let ((tmp (record-field rcd fld db)))
    (and tmp (not (string-equal tmp "")) (concat pfx tmp sfx))))

(defun geneal-individual-description (rcd)
  (concat
   (field-maybe " "  'prefix-name ""  rcd dbc-database)
   (field-maybe " "  'first-name  ""  rcd dbc-database)
   (field-maybe " "  'middle-name ""  rcd dbc-database)
   (field-maybe " (" 'nickname    ")" rcd dbc-database)
   (field-maybe " "  'last-name   ""  rcd dbc-database)
   (field-maybe " [" 'last-name-a "]" rcd dbc-database)
   (field-maybe ", " 'suffix-name ""  rcd dbc-database)
   (let ((b (record-field rcd 'date-of-birth dbc-database))
	 (d (record-field rcd 'date-of-death dbc-database)))
     (if b
	 (if (string-equal b "")
	     (setq b nil)
	   (if (string-match
		"^\\([-0-9a-z]+-\\)?\\([12]?[0-9][0-9][0-9]\\)\\((.+)\\)?$" b)
	       (setq b (match-string 2 b)))))
     (if d
	 (if (string-equal d "")
	     (setq d nil)
	   (if (string-match
		"^\\([-0-9a-z]+-\\)?\\([12]?[0-9][0-9][0-9]\\)\\((.+)\\)?$" d)
	       (setq d (match-string 2 d)))))
     (if b
	 (if d
	     (concat " (" b "-" d ")")
	   (concat " (b: " b ")"))
       (if d
	   (concat " (d: " d ")"))))
   ))

(defun geneal-family-description (rcd)
  (concat
   " "
   (if (setq tmp (record-field rcd 'husband dbc-database))
       (concat(record-field tmp 'first-name dbc-database)
	      " "
	      (record-field tmp 'last-name dbc-database))
     "???")
   "\tand\t"
   (if (setq tmp (record-field rcd 'wife dbc-database))
       (concat(record-field tmp 'first-name dbc-database)
	      " "
	      (record-field tmp 'last-name dbc-database))
     "???")))
;;;; Basic datatype record-index

;;; This is used for the actual ID# of the record.  It's a little
;;; kludgy because it's actually converted on initial read, not when
;;; the converters are normally called, but they get called anyway, so
;;; we make it just like integer except that when converting from a
;;; external to internal form, we check if already an int and then we
;;; don't convert...

(define-recordfieldtype-from-recordfieldspec 'record-index
  (let ((rs (make-recordfieldspec)))
    (recordfieldspec-set-type rs 'record-index)
    (recordfieldspec-set-default-value rs nil)
    (recordfieldspec-set-actual->stored rs (function integer->string))
    (recordfieldspec-set-stored->actual rs (function string->record-index))
    (recordfieldspec-set-order-fn rs (function integer-order))
    (recordfieldspec-set-sort-fn rs (function <))
    (recordfieldspec-set-match-function rs (function =))
    (recordfieldspec-set-help-info rs "The index of a record in the database.")
    rs))

(define-displaytype-from-displayspec 'record-index
  (let ((fs (make-displayspec)))
    (displayspec-set-indent fs nil)
    (displayspec-set-reachablep fs nil)
    (displayspec-set-actual->display fs (function integer->string))
    (displayspec-set-display->actual fs (function string->record-index))
    fs))

(defun string->record-index (str)
  (cond ((integerp str)
	 str)
	(t
	 (string->integer str))
	))
;;;; Basic datatype record-ref

(define-recordfieldtype-from-recordfieldspec 'record-ref
  (let ((rs (make-recordfieldspec)))
    (recordfieldspec-set-type rs 'record-ref)
    (recordfieldspec-set-default-value rs nil)
    (recordfieldspec-set-actual->stored rs (function record-ref->stored))
    (recordfieldspec-set-stored->actual rs (function stored->record-ref))
    (recordfieldspec-set-order-fn rs (function record-ref-order))
    (recordfieldspec-set-sort-fn rs (function record-ref-<))
    (recordfieldspec-set-match-function rs (function record-ref-=))
    (recordfieldspec-set-help-info rs
			"A reference to another record in the database.")
    rs))

(defun record-ref-order (a b)
  "Returns -1, 0, or 1 depending on whether the record A comes before B,
is the same record as B, or comes after B.
A nil reference always comes \"before\" any other."
  (cond ((and a b)
	 ;; A and B both have some value, let's coerce to an int...
	 (if (not (integerp a))
	     (setq a (record-field a 'index dbc-database)))
	 (if (not (integerp b))
	     (setq b (record-field b 'index dbc-database)))
	 ;; Now compare the indices
	 (cond ((= a b) 0)
	       ((< a b) -1)
	       (t 1)))
	(a 1)
	(b -1)
	(t 0)))
(defun record-ref-= (a b)
  "Returns T if the records A and B are the same, NIL otherwise."
  (= (record-ref-order a b) 0))
(defun record-ref-< (a b)
  "Returns T if the record A comes before B, NIL otherwise.
A nil reference always comes \"before\" any other."
  (< (record-ref-order a b) 0))

(defun record-ref->stored (ref)
  (cond ((integerp ref) (integer->string ref))
	(ref (integer->string (record-field ref 'index dbc-database)))
	(t nil)))
(defun stored->record-ref (str)
  (cond ((null str)
	 nil)
	((integerp str)
	 str)
	((or (string-equal str "unknown")
	     (string-equal str ""))
	 nil)
	(t
	 (geneal-lookup (string->integer str) dbc-database))
	))
;;;; Display types related to datatype record-ref

;;; Base display type just shows number...and allows update
(define-displaytype-from-displayspec 'record-ref
  (let ((fs (make-displayspec)))
    (displayspec-set-indent fs nil)
    (displayspec-set-actual->display fs (function record-ref->string))
    (displayspec-set-display->actual fs (function string->record-ref))
    fs))
(defun record-ref->string (ref)
  (cond ((integerp ref) (integer->string ref))
	(ref (integer->string (record-field ref 'index
					   dbc-database)))
	(t "Unknown")))
(defun string->record-ref (str)
  (cond ((null str)
	 nil)
	((or (string-equal str "unknown")
	     (string-equal str ""))
	 nil)
	((integerp str)
	 str)
	(t
	 ;; get the integer and see if we can look it up
	 (setq str (string->integer str))
	 (if (not (integerp str))
	     nil
	   (let ((rcd (geneal-lookup ref dbc-database)))
	     (or rcd
		 str))
	   ))
	))

;;; Generic function to indirect through a reference
(defun record-ref->value-generic (ref fld)
  (if (null ref)
      ""
    (if (integerp ref) (setq ref (geneal-lookup ref dbc-database)))
    (if (null ref)
	"[[[ No record in database ]]]"
      (record-field ref fld dbc-database))))
(defmacro define-geneal-record-ref-display (typ fld)
  (` (define-displaytype-from-displayspec (, typ)
       (let ((fs (make-displayspec)))
	 (displayspec-set-indent fs t)
	 (displayspec-set-max-height fs nil)
	 (displayspec-set-reachablep fs nil)
	 (displayspec-set-actual->display fs
	    (function (lambda (ref) (record-ref->value-generic ref (, fld)))))
	 (displayspec-set-display->actual fs 'geneal-no-edit)
	 fs))))

;;; Show the name of the referenced record
(define-geneal-record-ref-display 'record-ref-name 'record-description)
;;; Show the address from the referenced record
(define-geneal-record-ref-display 'record-ref-addr 'addr)
;;;; Basic datatype record-ref-list

;;; A list of record-refs (int, nil or actual record), single elements
;;; are allowed to be represented without list...

(define-recordfieldtype-from-recordfieldspec 'record-ref-list
  (let ((rs (make-recordfieldspec)))
    (recordfieldspec-set-type rs 'record-ref-list)
    (recordfieldspec-set-default-value rs nil)
    (recordfieldspec-set-actual->stored rs (function record-ref-list->stored))
    (recordfieldspec-set-stored->actual rs (function stored->record-ref-list))
    (recordfieldspec-set-help-info rs
		"A list of references to other records in the database.")
    rs))

(defun record-ref-list->stored (ref)
  (cond ((null ref) nil)
	((listp ref)
	 (mapconcat (function record-ref->stored) ref ","))
	(t (record-ref->stored ref))))
(defun stored->record-ref-list (str)
  (cond ((null str)
	 nil)
	((integerp str)
	 str)
	((or (string-equal str "unknown")
	     (string-equal str ""))
	 nil)
	(t
	 (let ((lis ())
	       tmp)
	   (while (not (empty-string-p str))
	     (setq tmp (string-split-first-word str ","))
	     (setq str (cadr tmp))
	     (setq lis (cons (stored->record-ref (car tmp)) lis)))
	   (nreverse lis)
	   ))
	))


(define-displaytype-from-displayspec 'record-ref-list
  (let ((fs (make-displayspec)))
    ;; For now you can't edit this directly
    (displayspec-set-indent fs t)
    (displayspec-set-max-height fs nil)
    (displayspec-set-reachablep fs nil)
    (displayspec-set-actual->display fs (function record-ref-list->string))
    (displayspec-set-display->actual fs (function string->record-ref-list))
    fs))
(defun record-ref-list->string (ref)
  (if (and ref (listp ref))
      (let ((idx 0))
	(mapconcat (function
		    (lambda (r)
		      (concat (integer->string (setq idx (1+ idx)))
			      ": "
			      (record-ref->string r)
			      "\t"
			      (record-ref->value-generic r 'record-description)
			      )))
		   ref "\n"))
    (concat (record-ref->string ref)
	    "\t"
	    (record-ref->value-generic ref 'record-description)
	    )))
;;;; Datatype Record-type and related stuff


(defvar geneal-record-types '((individual "Individual")
			      (family "Family")
			      (address "Address")
			      (reference "Reference")))
(define-displaytype-from-displayspec 'record-type
  (let ((fs (make-displayspec)))
    (displayspec-set-indent fs nil)
    (displayspec-set-reachablep fs nil)
    (displayspec-set-actual->display fs (function record-type->string))
    (displayspec-set-display->actual fs (function string->record-type))
    fs))
(define-recordfieldtype-from-recordfieldspec 'record-type
  (let ((rs (make-recordfieldspec)))
    (recordfieldspec-set-type rs 'record-type)
    (recordfieldspec-set-default-value rs nil)
    (recordfieldspec-set-actual->stored rs (function record-type->stored))
    (recordfieldspec-set-stored->actual rs (function stored->record-type))
    (recordfieldspec-set-order-fn rs (function record-type-order))
    (recordfieldspec-set-match-function rs (function eq))
    (recordfieldspec-set-help-info rs "The type of a genealogy record.")
    rs))
(defun record-type->string (key)
  (if (null key)
      "Unspecified"
    (let ((l geneal-record-types)
	  (r nil))
      (while l
	(if (eq key (car (car l)))
	    (setq r (cadr (car l))))
	(setq l (cdr l)))
      r)))
(defun string->record-type (key)
  (let ((l geneal-record-types)
	(r nil))
    (while l
      ;; Really want "initial substring..."
      (if (string-equal key (cadr (car l)))
	  (setq r (car (car l))))
      (setq l (cdr l)))
    r))
(defun record-type->stored (key)
  (and key
       (let ((l geneal-record-types)
	     (r nil))
	 (while l
	   (if (eq key (car (car l)))
	       (setq r (cadr (car l))))
	   (setq l (cdr l)))
	 (substring r 0 1))))
(defun stored->record-type (key)
  (let ((l geneal-record-types)
	(r nil))
    (while l
      (if (string-equal key (substring (cadr (car l)) 0 1))
	  (setq r (car (car l))))
      (setq l (cdr l)))
    r))
(defun record-type-order (a b)
  (cond ((eq a b) 0)
	((eq a 'individual) -1)
	((eq a 'family) (if (eq b 'individual) 1 -1))
	((eq a 'address) (if (eq b 'reference) -1 1))
	((eq a 'reference) 1)))
;;;; Datatype sex

;;; The "sex" field can have three values, nil means unknown, and symbols
;;; male and female represent the obvious meanings...

(defvar geneal-sex-alist '((male "Male")(female "Female" )))

(define-displaytype-from-displayspec 'sex
  (let ((fs (make-displayspec)))
    (displayspec-set-indent fs nil)
    (displayspec-set-actual->display fs (function sex->string))
    (displayspec-set-display->actual fs (function string->sex))
    fs))
(define-recordfieldtype-from-recordfieldspec 'sex
  (let ((rs (make-recordfieldspec)))
    (recordfieldspec-set-type rs 'sex)
    (recordfieldspec-set-default-value rs nil)
    (recordfieldspec-set-actual->stored rs (function sex->stored))
    (recordfieldspec-set-stored->actual rs (function stored->sex))
    (recordfieldspec-set-order-fn rs (function sex-order))
    (recordfieldspec-set-match-function rs (function eq))
    (recordfieldspec-set-help-info rs "The type of a genealogy record.")
    rs))
(defun sex->string (key)
  (if (null key)
      "Unspecified"
    (let ((l geneal-sex-alist)
	  (r nil))
      (while l
	(if (eq key (car (car l)))
	    (setq r (cadr (car l))))
	(setq l (cdr l)))
      r)))
(defun string->sex (key)
  (let ((l geneal-sex-alist)
	(r nil))
    (while l
      ;; Really want "initial substring..."
      (if (string-equal key (cadr (car l)))
	  (setq r (car (car l))))
      (setq l (cdr l)))
    r))
(defun sex->stored (key)
  (and key
       (let ((l geneal-sex-alist)
	     (r nil))
	 (while l
	   (if (eq key (car (car l)))
	       (setq r (cadr (car l))))
	   (setq l (cdr l)))
	 (substring r 0 1))))
(defun stored->sex (key)
  (let ((l geneal-sex-alist)
	(r nil))
    (while l
      (if (string-equal key (substring (cadr (car l)) 0 1))
	  (setq r (car (car l))))
      (setq l (cdr l)))
    r))
(defun sex-order (a b)
  (cond ((eq a b) 0)
	((eq a 'male) -1)
	((eq a 'female) 1)))
;;;; Global format stuff.

(setq geneal-alternate-format-names
      '(("individual" . "individual.fmt")
	("family" . "family.fmt")
	("address" . "address.fmt")
	("reference" . "reference.fmt")
	("general" . "geneal.fmt")))


;; Automatically choose the appropriate format for the current record.
;; Hackishly, we also cross set some fields...
(defun geneal-set-format-from-data (record)
  (let* ((typ (record-field record 'type dbc-database))
	 (nm (cond ((eq typ 'individual)
		    (geneal-update-addr-ptr)
		    "individual")
		   ((eq typ 'family)
		    (geneal-update-addr-ptr)
		    "family")
		   ((eq typ 'address) "address")
		   ((eq typ 'reference) "reference")
		   (t "general"))))
    (db-alternate-format nm)))

(defun geneal-update-addr-ptr ()
  (and (null (record-field record 'addr-ptr dbc-database))
       (record-field record 'addr dbc-database)
       (not (string-equal (record-field record 'addr dbc-database) ""))
       (record-set-field record 'addr-ptr dbc-database
			 (string->integer
			  (record-field record 'addr dbc-database)
			  ))))



(defun geneal-wrfr ()
  (insert (integer->string (record-field record 'index database))
	  "\t"
	  (record-field record 'record-description database)
	  "\n"))
(defun geneal-rrfr ()
  (goto-char (point-min))
  (cond ((looking-at "^\\([0-9]+\\)[ \t]*\\(.*\\)$")
	 (let* ((x (point-max))
		;; Order matters here since calling string->integer resets match
		(name (match-string 2))
		(idx-str (match-string 1))
		(idx (string->integer idx-str)))
	   (if (= idx 0) (database-set-print-name database name))
	   (record-set-field result-record 'record-description database name)
	   (record-set-field result-record 'index database idx)
	   (let ((sym (intern idx-str
			(database-get-local 'geneal-index-obarray database))))
	     (if (boundp sym)
		 (message "Duplicate index %d, second won't get links" idx)
	       (set sym result-record)))
	   (forward-line 1)
	   ;;(widen)
	   (narrow-to-region (point) x)))
	(t
	 (error "Genealogy record does not start with ID# line"))
	))