;; ;; $Id: family-tree.el,v 1.5 1994/09/12 00:45:50 qjb Exp $ ;; $Source: /home/qjb/elisp/q/RCS/family-tree.el,v $ ;; $Author: qjb $ ;; ;; Family tree editing major mode ;; (defvar ft-mode-map () "Keymap used for editing family trees.") (if ft-mode-map nil (setq ft-mode-map (make-sparse-keymap)) (define-key ft-mode-map "\e\C-n" 'ft-next-segment) (define-key ft-mode-map "\e\C-p" 'ft-previous-segment) (define-key ft-mode-map "\e\C-a" 'ft-beginning-of-segment) (define-key ft-mode-map "\e\C-e" 'ft-end-of-segment) (define-key ft-mode-map "\C-c\C-t" 'ft-add-template) (define-key ft-mode-map "\C-c\C-s" 'ft-add-spouse) (define-key ft-mode-map "\C-c\C-n" 'ft-add-sibling) (define-key ft-mode-map "\C-c\C-c" 'ft-add-child) (define-key ft-mode-map "\C-c\C-d" 'ft-insert-date) (define-key ft-mode-map "\C-c\C-f\C-c" 'ft-find-child) (define-key ft-mode-map "\C-c\C-f\C-p" 'ft-find-parent) (define-key ft-mode-map "\C-c\C-f\C-i" 'ft-find-id) ) (defvar ft-mode-syntax-table nil "Syntax table in use in family-tree-mode buffers.") (if ft-mode-syntax-table () (setq ft-mode-syntax-table (make-syntax-table)) (modify-syntax-entry ?% "<" ft-mode-syntax-table) (modify-syntax-entry ?\n "> " ft-mode-syntax-table) (modify-syntax-entry ?? "w" ft-mode-syntax-table) (modify-syntax-entry ?: "." ft-mode-syntax-table) (modify-syntax-entry ?- "." ft-mode-syntax-table) (modify-syntax-entry ?# "." ft-mode-syntax-table)) (defun family-tree-mode () "Major mode for editing family tree files. The following key bindings exist: \\[ft-next-segment]: Next segment. Move the point to the beginning of the next segment. \\[ft-previous-segment]: Previous segment. Move the point to the beginning of the previous segment. \\[ft-beginning-of-segment]: Beginning of segment. Move the point to the top of the current segment. \\[ft-end-of-segment]: End of segment. Move the point to the bottom of the current segment. \\[ft-add-template]: Add template. Insert a blank template, prompting user for the id number. Cursor must be at the end of the file or on a segment border. \\[ft-add-spouse]: Add spouse. Insert blank spouse area for the current segment leader. Fills in the id number and handles placement automatically. \\[ft-add-sibling]: Add sibling. Insert blank segment for a sibling to the current segment leader. Fills in the id number and handles placement automatically. \\[ft-add-child]: Add child. Insert blank child segment for the current segment leader. Fills in the id number and handles placement automatically. Point must be on a line containing the id of the parent who is not the segment leader unless the child is \"out of marriage\". \\[ft-insert-date]: Insert date. Insert blank date at the point. \\[ft-find-child]: Find child. Find the first child of the id on the current line. The cursor must be positioned on a line containing an id number. If the cursor is on the id of a segment leader, a child by any marriage will be found. Otherwise, a child by the specific marriage on the line with the cursor will be found. \\[ft-find-parent]: Find parent. Find the parent of the id on the current line. The cursor must be positioned on a line containing an id number. \\[ft-find-id]: Find id. Find the defining segment of the id on the current line. This is useful for following links or resolving id-containing comments." (interactive) (use-local-map ft-mode-map) (set-syntax-table ft-mode-syntax-table) (make-local-variable 'comment-start) (setq comment-start "% ") (make-local-variable 'comment-end) (setq comment-end "") (make-local-variable 'comment-column) (setq comment-column 0) (make-local-variable 'comment-start-skip) (setq comment-start-skip "% +") (setq major-mode 'family-tree-mode) (setq mode-name "Family Tree") (run-hooks 'family-tree-mode-hook)) ;; Regular expressions (setq ft-segstart-regexp "^\\*\\*\\*" ft-num-regexp "[0-9][0-9]*" ft-gen-regexp (concat ft-num-regexp "-" ft-num-regexp) ft-id-regexp (concat "#" ft-gen-regexp "\\(/" ft-gen-regexp "\\)*") ) ;; General constants (setq ft-id-less-than -1 ft-id-equal 0 ft-id-greater-than 1) (defun ft-valid-idstring (idstring) (and (string-match ft-id-regexp idstring) (= (match-beginning 0) 0) (= (match-end 0) (length idstring)))) (defun ft-parse-id (idstring) "Convert a text id string into a list of cons cells. The order of the cons cells is the reverse of the order of the componenets of the id string so that the cdr of a parsed id is its parent. For example, #1-2/3-4/5-6 would become ((5 . 6) (3 . 4) (1 .2 ))." (let (id genstring child spouse) (if (not (ft-valid-idstring idstring)) (error "Invalid id string: %s" idstring)) (setq idstring (substring idstring 1 (length idstring))) (while (string-match ft-gen-regexp idstring) (setq genstring (substring idstring (match-beginning 0) (match-end 0))) (setq idstring (substring idstring (match-end 0) (length idstring))) (string-match (concat "\\(" ft-num-regexp "\\)-\\(" ft-num-regexp "\\)") genstring) (setq child (substring genstring (match-beginning 1) (match-end 1))) (setq spouse (substring genstring (match-beginning 2) (match-end 2))) (setq id (cons (cons (string-to-int child) (string-to-int spouse)) id))) id)) (defun ft-unparse-id (id) "Convert a list of cons cells as described in ft-parse-id back to an id string." (let (idstring gen) (while (setq gen (car id)) (setq id (cdr id)) (setq idstring (concat (if (car id) "/" "#") (int-to-string (car gen)) "-" (int-to-string (cdr gen)) idstring))) idstring)) (defun ft-id-of-current-line () "Return the first id number on the current line" (save-excursion (let (eol idstring) (beginning-of-line) (setq eol (save-excursion (end-of-line) (point))) (if (not (re-search-forward ft-id-regexp eol t)) (error "No id on this line.")) (ft-parse-id (buffer-substring (match-beginning 0) (match-end 0)))))) (defun ft-segment-leader-id () "Return the id number of the segment leader" (save-excursion (if (not (re-search-backward ft-segstart-regexp 0 t)) (error "Not currently in a segment.")) (forward-line 2) (ft-id-of-current-line))) (defun ft-insert-blank-segment (idstring) "Insert template for a blank segment with idstring given. Must be on a segment separator or at the end of the file." (interactive) (if (= (point) (point-max)) (insert "\n***\n\n") (if (save-excursion (beginning-of-line) (looking-at ft-segstart-regexp)) (progn (beginning-of-line) (insert "\n") (forward-line -1) (insert "***\n\n")) (error "Must be at a segment divider of at the end of the file"))) (insert idstring) (insert "\n::::: ????-??-??, ????-??-??\n") (beginning-of-line) (forward-line -1)) (defun ft-convert-id-to-cmp-id (id) "Convert ids to a form easier for comparison. Each id is represented as a list of numbers from top-level child down to bottom-level spouse. For example, #1-2/3-4/5-6 would be (1 2 3 4 5 6)." (let (cmp-id) (while id (setq cmp-id (append (list (car (car id)) (cdr (car id))) cmp-id)) (setq id (cdr id))) cmp-id )) (defun ft-compare-ids (id1 id2) "Return ft-id-less-than if id1 < id2, ft-id-equal if id1 = id2, or ft-id-greater than if id1 > id2. If two ids have the different first numerical components (top-level child number), the one with the greater child number is greater. Otherwise, if two ids have different lengths, the longer one is greater. If they have the same length and the same top-level child number, then their numerical components are compared with earlier generations receiving higher precedence than later and with child numbers receiving higher precedence than spouse numbers. For example, the following segments are listed in order: #1-0 #1-1/1-0 #1-1/1-1 #1-1/2-1 #1-2/1-0 #1-1/1-1/1-0 #2-0" (let (id1-cmp id2-cmp result) (setq id1-cmp (ft-convert-id-to-cmp-id id1)) (setq id2-cmp (ft-convert-id-to-cmp-id id2)) (cond ((< (car id1-cmp) (car id2-cmp)) (setq result ft-id-less-than)) ((> (car id1-cmp) (car id2-cmp)) (setq result ft-id-greater-than)) (t (cond ((< (length id1-cmp) (length id2-cmp)) (setq result ft-id-less-than)) ((> (length id1-cmp) (length id2-cmp)) (setq result ft-id-greater-than)) (t (while (not (setq result (cond ((null id1-cmp) ft-id-equal) ((< (car id1-cmp) (car id2-cmp)) ft-id-less-than) ((> (car id1-cmp) (car id2-cmp)) ft-id-greater-than) (t (setq id1-cmp (cdr id1-cmp)) (setq id2-cmp (cdr id2-cmp)) nil))))))))) result)) (defun ft-next-segment (failnil) "Move to the next segment. Pass failnil (arg) to re-search-forward as third argument." (interactive "P") ;; Make sure only t means t for arg (setq failnil (equal t failnil)) (if (re-search-forward ft-segstart-regexp (point-max) failnil) (progn (beginning-of-line) (forward-line 2)) nil)) (defun ft-previous-segment (failnil) "Move to the previous segment. Pass failnil (arg) to re-search-backward as third argument." (interactive "P") ;; Make sure only t means t for arg (setq failnil (equal t failnil)) (if (re-search-backward ft-segstart-regexp 0 failnil 2) (forward-line 2) nil)) (defun ft-end-of-segment () "Move to the end of the current segment." (interactive) (if (re-search-forward ft-segstart-regexp (point-max) 1) (progn (beginning-of-line) (forward-line -2)))) (defun ft-beginning-of-segment () "Move to the beginning of the current segment." (interactive) (if (re-search-backward ft-segstart-regexp 0 1) (forward-line 2) nil)) (defun ft-find-place-for-child (id) "Find a place in the tree to insert a child with the given id." ;; ;; Note: The current implementation of this routine is very inefficient. ;; We start with the current segment. ;; Until found ;; If the id of the leader of this segment is < id and ;; the leader of the next segement is > id ;; position point at the border between the two segments ;; else ;; advance to the next segment ;; If EOF is encountered, position the point at the end of the file. ;; (let (this-id next-id result1 result2 found) (ft-beginning-of-segment) ;; Inside the loop, set this-id to next-id and find-next id. ;; To start off, set next-id to this id... (setq next-id (ft-id-of-current-line)) (while (not found) (setq this-id next-id) (save-excursion (ft-next-segment t) (setq next-id (ft-id-of-current-line))) (setq result1 (ft-compare-ids id this-id)) (setq result2 (ft-compare-ids id next-id)) (if (or (= result1 0) (= result2 0)) (error "ft-find-place-for-child called with id already in tree.")) (if (and (= result1 1) (= result2 -1)) (progn (ft-end-of-segment) (forward-line 2) (setq found t))) (if (not found) (if (not (ft-next-segment t)) (progn (ft-end-of-segment) (forward-line 2) (setq found t))))))) (defun ft-find-parent () "Move to the definition for the parent of the current id." (interactive) (let (parent parentstring) (setq parent (cdr (ft-id-of-current-line))) (if (null parent) (error "Top-level ids do not have parents in the tree.")) (setq parentstring (ft-unparse-id parent)) (goto-char (save-excursion (goto-char (point-min)) (if (not (re-search-forward (concat "^" (regexp-quote parentstring)) (point-max) t)) (error "Parent (%s) not found in tree." parentstring)) (point))) (beginning-of-line))) (defun ft-find-child () "Move to the definition for the first of the current id." (interactive) (let (id lastgen childstring) (setq id (ft-id-of-current-line)) (setq lastgen (car id)) ;; Generate id string for child (if (= (cdr lastgen) 0) ;; If spouse is 0, look for children by any marriage (setq childstring (concat (regexp-quote (concat (if (cdr id) (concat (ft-unparse-id (cdr id)) "/") "#") (int-to-string (car lastgen)) "-")) ft-num-regexp)) ;; Otherwise, look for children only by this marriage (setq childstring (regexp-quote (ft-unparse-id id)))) (setq childstring (concat "^" childstring "/")) (goto-char (save-excursion (goto-char (point-min)) (if (not (re-search-forward childstring (point-max) t)) (error "Child not found in tree.")) (point))) (beginning-of-line))) (defun ft-find-id () "Find the definition of the id on this line. This function is useful for following links or resolving id-containing comments." (interactive) (let (idstring) (setq idstring (concat "^" (regexp-quote (ft-unparse-id (ft-id-of-current-line))))) (goto-char (save-excursion (goto-char (point-min)) (if (not (re-search-forward idstring (point-max) t)) (error "Id not found in tree.")) (point))) (beginning-of-line))) (defun ft-add-template () "Insert template for a blank segment prompting user for id string. Must be on a segment separator or at the end of the file." (interactive) (if (not (or (= (point) (point-max)) (save-excursion (beginning-of-line) (looking-at ft-segstart-regexp)))) (error "Must be at a segment divider of at the end of the file")) (ft-insert-blank-segment (read-string "Enter ID number (with leading #): "))) (defun ft-add-spouse () "Add another spouse to this segment" (interactive) (let (id lastgen) ;; Find the beginning of this segment (re-search-backward ft-segstart-regexp) ;; Skip to the leader (forward-line 2) ;; Find the first double newline (if (search-forward "\n\n" (point-max) 1) ;; Move up one line to place where new spouse will be added (forward-line -1)) ;; Find id of previous spouse or leader (save-excursion (re-search-backward (concat "^" ft-id-regexp)) (setq id (ft-id-of-current-line))) ;; Increment spouse (setq lastgen (car id)) (setq lastgen (cons (car lastgen) (1+ (cdr lastgen)))) (setq id (cons lastgen (cdr id))) ;; Insert new spouse id (insert (ft-unparse-id id)) (insert "\n::::: ????-??-??, ????-??-??\n????-??-??\n") ;; Move to name area for this spouse (forward-line -2) )) (defun ft-add-sibling () "Add a sibling to the leader of this segment" (interactive) (let (sibstring id lastgen) ;; Find regexp for this leader and its siblings (setq id (ft-segment-leader-id)) (if (null (cdr id)) (error "Can't add a sibling of a top-level id.")) (setq sibstring (concat "^" (regexp-quote (ft-unparse-id (cdr id))) "/" ft-num-regexp "-0$")) ;; Find the last sibling (goto-char (point-max)) ;; no error checking necessary here since we will at least find ;; ourselves in our search... (re-search-backward sibstring) ;; Get the id of this sibling (setq id (ft-segment-leader-id)) ;; Increment sibling (setq lastgen (car id)) (setq lastgen (cons (1+ (car lastgen)) (cdr lastgen))) (setq id (cons lastgen (cdr id))) ;; Move to end of segment (re-search-forward ft-segstart-regexp (point-max) 1) ;; Insert new segment with new id (ft-insert-blank-segment (ft-unparse-id id))) ) (defun ft-add-child () "Add a child to the current id" (interactive) (let (id childstring childpoint) ;; Determine whether this id already has children (setq id (ft-id-of-current-line)) (setq childstring (concat "^" (regexp-quote (ft-unparse-id id)) "/" ft-num-regexp "-0$")) (if (setq childpoint (save-excursion (goto-char (point-max)) (if (re-search-backward childstring 0 t) (point) nil))) ;; Case I: This segment already has children (progn ;; Go to the child and add a sibling (goto-char childpoint) (ft-add-sibling) ) ;; Case II: This segment does not already have children ;; Generate id for child (setq id (cons (cons 1 0) id)) ;; Find place for child to be inserted (ft-find-place-for-child id) ;; Insert the child (ft-insert-blank-segment (ft-unparse-id id)) ) )) (defun ft-insert-date () "Insert an empty date at the point" (interactive) (insert "????-??-??"))