home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / edb / db-two-dbs.el < prev    next >
Encoding:
Text File  |  1993-06-13  |  11.5 KB  |  321 lines
  1. ;;; db-two-dbs.el --- part of EDB, the Emacs database
  2.  
  3. ;; See database.el for copyright notice, distribution conditions, etc.
  4.  
  5. ;; Author: Michael Ernst <mernst@theory.lcs.mit.edu>
  6. ;; Keywords: EDB
  7.  
  8. ;;; Commentary:
  9.  
  10. ;; Support for actions on two databases.
  11.  
  12. ;;; Code:
  13.  
  14.  
  15. (provide 'db-two-dbs)
  16.  
  17.  
  18. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  19. ;;; Process two databases
  20. ;;;
  21.  
  22. ;;;###autoload
  23. (defun db-process-two-databases (db1 db2
  24.                      process-lone-record-db1
  25.                      process-lone-record-db2
  26.                      process-corresponding-records
  27.                      &optional orderer)
  28.   (db-debug-message "db-process-two-databases:  before with-orderer, dbf-field-priorities = %s" dbf-field-priorities)
  29.   (with-orderer db1
  30.     (db-debug-message "db-process-two-databases:  orderer = %s" orderer)
  31.     (db-debug-message "db-process-two-databases:  process-corresponding-records = %s"
  32.          process-corresponding-records)
  33.     (if (not (database-ordered-p db1 orderer))
  34.     (progn
  35.       (db-message "db-process-two-databases:  sorting %s."
  36.            (database-print-name db1))
  37.       (database-sort db1 orderer)))
  38.     (if (not (database-ordered-p db2 orderer))
  39.     (progn
  40.       (db-message "db-process-two-databases:  sorting %s."
  41.            (database-print-name db2))
  42.       (database-sort db2 orderer)))
  43.  
  44.     ;; Perhaps check for identical keys here.
  45.  
  46.     (db-message "Databases are properly ordered.")
  47.     (let* ((db1-first-link (database-first-link db1))
  48.        (db1-link db1-first-link)
  49.        (db2-first-link (database-first-link db2))
  50.        (db2-link db2-first-link)
  51.        record1 record2 record-order
  52.        (done1 (database-empty-p db1))
  53.        (done2 (database-empty-p db2)))
  54.       (db-debug-message "db-process-two-databases:  entering while loop")
  55.       (while (not (or done1 done2))
  56.     (setq record1 (link-record db1-link)
  57.           record2 (link-record db2-link)
  58.           record-order (funcall orderer record1 record2))
  59.     ;; (db-debug-message "two records:  %s %s" record1 record2)
  60.     (cond ((= -1 record-order)
  61.            ;; (db-debug-message "< %s %s" record1 record2)
  62.            (funcall process-lone-record-db1 record1)
  63.            (setq db1-link (link-next db1-link))
  64.            (if (eq db1-link db1-first-link) (setq done1 t)))
  65.           ((= 1 record-order)
  66.            ;; (db-debug-message "> %s %s" record1 record2)
  67.            (funcall process-lone-record-db2 record2)
  68.            (setq db2-link (link-next db2-link))
  69.            (if (eq db2-link db2-first-link) (setq done2 t)))
  70.           ((= 0 record-order)
  71.            ;; (db-debug-message "= %s %s" record1 record2)
  72.            (funcall process-corresponding-records record1 record2)
  73.            (setq db1-link (link-next db1-link)
  74.              db2-link (link-next db2-link))
  75.            (if (eq db1-link db1-first-link) (setq done1 t))
  76.            (if (eq db2-link db2-first-link) (setq done2 t))
  77.            ;; (db-debug-message "coresponding records processed")
  78.            )
  79.           (t
  80.            (error "Bad result %s from orderer." record-order))))
  81.       (while (not done1)
  82.     (funcall process-lone-record-db1 (link-record db1-link))
  83.     (setq db1-link (link-next db1-link))
  84.     (if (eq db1-link db1-first-link) (setq done1 t)))
  85.       (while (not done2)
  86.     (funcall process-lone-record-db2 (link-record db2-link))
  87.     (setq db2-link (link-next db2-link))
  88.     (if (eq db2-link db2-first-link) (setq done2 t)))
  89.       nil
  90.       )))
  91.  
  92. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  93. ;;; Merge
  94. ;;;
  95.  
  96. ; Want to display both records in full and, for each differing field, ask how
  97. ; to set the merged database:  from one, from the other, or by entering
  98. ; something particular.  It should also be possible to edit the merged record
  99. ; before proceeding to the next one.
  100.  
  101. ;; Should check for the consistency of the two databases.  Should permit
  102. ;; conversion for one or both databases as part of this procedure.
  103.  
  104. ;; Should permit specification of db3 info, or specification of db3 itself.
  105.  
  106. ; I'd like to pass in some buffers (probably three) as well.
  107.  
  108. ;; Ought to pass just two arguments, each a database or format.
  109.  
  110. ;; Return a third database.
  111. (defun db-merge-internal (db1 db2 db3 buffer1 buffer2 buffer3)
  112.  
  113.   (delete-other-windows)
  114.   (switch-to-buffer buffer1)
  115.   (split-window-vertically (/ (window-height) 2))
  116.   (other-window 1)
  117.   (switch-to-buffer buffer2)
  118.   (split-window-vertically)
  119.   (other-window 1)
  120.   (switch-to-buffer buffer3)
  121.   (set-buffer buffer1)
  122.  
  123.   (db-process-two-databases
  124.    db1 db2
  125.    (function (lambda (record) (database-add-record record db3)))
  126.    (function (lambda (record) (database-add-record record db3)))
  127.    (function (lambda (record1 record2)
  128.            (database-add-record (db-merge-records record1 record2 db3
  129.                               buffer1 buffer2 buffer3)
  130.                     db3))))
  131.   )
  132.  
  133.  
  134. ;;;###autoload
  135. (defun db-merge ()
  136.   "Merge two databases chosen with completion among read-in databases."
  137.   (interactive)
  138.  
  139.   (let ((databases-alist (mapcar (function (lambda (database)
  140.                        (cons (database-print-name database)
  141.                      database)))
  142.                  db-databases))
  143.     db1 db2 db3 db1-buffer db2-buffer db3-buffer)
  144.     (cond ((< (length databases-alist) 2)
  145.        (error "db-merge requires there to be at least two read-in databases."))
  146.       ((= 2 (length databases-alist))
  147.        (setq db1 (car db-databases)
  148.          db2 (car (cdr db-databases))))
  149.       (t
  150.        ;; Could check that a data display buffer exists.
  151.        (setq db1 (assoc (completing-read
  152.                  "First database to merge?  [? for options] "
  153.                  databases-alist nil t nil)
  154.                 databases-alist))
  155.        (setq databases-alist (delq db1 databases-alist))
  156.        (setq db1 (cdr db1))
  157.        ;; could check for compatibility, or remove incompatible databases
  158.        ;; (and warn if none are left).
  159.       
  160.        (setq db2 (cdr (assoc (completing-read
  161.                   "Second database to merge?  [? for options] "
  162.                   databases-alist nil t nil)
  163.                  databases-alist)))))
  164.     (setq db1-buffer (car (database-clean-data-display-buffers db1))
  165.       db2-buffer (car (database-clean-data-display-buffers db2)))
  166.     (db-debug-message "db-merge:  about to create db3")
  167.     (setq db3 (make-similar-database db1)
  168.       db3-buffer (car (database-clean-data-display-buffers db3)))
  169.     (database-set-print-name db3
  170.       (concat "Merge of `" (database-print-name db1)
  171.           "' and `" (database-print-name db2) "'"))
  172.     (db-debug-message "db-merge:  created db3.")
  173.     (let ((db1-index (in-buffer db1-buffer dbc-index))
  174.       (db2-index (in-buffer db2-buffer dbc-index)))      
  175.       (db-merge-internal db1 db2 db3 db1-buffer db2-buffer db3-buffer)
  176.       (in-buffer db1-buffer (db-jump-to-record db1-index))
  177.       (in-buffer db2-buffer (db-jump-to-record db2-index))
  178.       (in-buffer db3-buffer (db-jump-to-record 1))))
  179.   (message "Done merging."))
  180.    
  181.  
  182. ;; The three buffers should already be visible.
  183.  
  184. ;; The displayspecs should be identical, I think.
  185.  
  186. (defun db-merge-records (record1 record2 database buffer1 buffer2 buffer3)
  187.   (db-debug-message "db-merge-records called on %s %s" record1 record2)
  188.  
  189.   (if (equal record1 record2)
  190.       record1
  191.     (progn
  192.       ;; (db-debug-message "db-merge-records:  unequal records")
  193.       (set-buffer buffer1)
  194.       (display-record record1 t)
  195.       (set-buffer buffer2)
  196.       (display-record record2 t)
  197.       (set-buffer buffer3)
  198.       (let ((record3 (make-record database))
  199.         (fieldno 0)
  200.         contents1
  201.         contents2
  202.         (db1-displayspecs (in-buffer buffer1 dbf-displayspecs))
  203.         db1-displayspec
  204.         (db2-displayspecs (in-buffer buffer2 dbf-displayspecs))
  205.         db2-displayspec
  206.         recordfieldspec)
  207.     ;; (db-debug-message "db-merge-records:  in let")
  208.     (while (< fieldno (database-no-of-fields database))
  209.       (setq db1-displayspec (aref db1-displayspecs fieldno)
  210.         db2-displayspec (aref db2-displayspecs fieldno)
  211.         recordfieldspec (database-recordfieldspec database fieldno)
  212.         contents1 (funcall-maybe (recordfieldspec-common-form-function
  213.                       recordfieldspec)
  214.                      (aref record1 fieldno))
  215.         contents2 (funcall-maybe (recordfieldspec-common-form-function
  216.                       recordfieldspec)
  217.                      (aref record2 fieldno)))
  218.       ;; I should make an attempt at consolidating them.
  219.       (if (equal contents1 contents2)
  220.           (progn
  221.         ;; (db-debug-message "merge-records equal values %s" contents1)
  222.         ;; Does no constraint checking; is this the right thing to do?
  223.         (record-set-field-from-index record3 fieldno contents1 nil))
  224.         (let ((fieldname (fieldnumber->fieldname fieldno database)))
  225.           ;; (db-debug-message "merge-records unequal values %s %s" contents1 contents2)
  226.           ;; Actually, I only want to display the filled-in-so-far fields.
  227.           ;; Problem is that nil might not be valid in some places.
  228.           ;; For now, ignore that.
  229.           (display-record record3 t fieldno)
  230.           ;; Does no constraint checking; is this the right thing to do?
  231.           ;; Help for one-char-question is not entirely satisfactory here.
  232.           (record-set-field-from-index
  233.            record3 fieldno
  234.            (choose-value contents1 contents2
  235.                  (fieldnumber->fieldname fieldno database)
  236.                  db1-displayspec db2-displayspec)
  237.            nil)))
  238.       (setq fieldno (1+ fieldno)))
  239.     record3
  240.     ))))
  241.  
  242. ;; Don't need the whole displayspec here, just actual->display,
  243. ;; display->actual, and fieldname.
  244. (defun choose-value (contents1 contents2 fieldname displayspec1 displayspec2)
  245.   (cond ((y-or-n-p (format "Use first value for %s field? [%s] "
  246.                fieldname
  247.                (actual->display-call
  248.                 (displayspec-actual->display displayspec1)
  249.                 contents1
  250.                 nil nil)))
  251.      contents1)
  252.     ((y-or-n-p (format "Use second value for %s field? [%s] "
  253.                fieldname
  254.                (actual->display-call
  255.                 (displayspec-actual->display displayspec2)
  256.                 contents2
  257.                 nil nil)))
  258.      contents2)
  259.     (t
  260.      (if (equal (displayspec-display->actual displayspec1)
  261.             (displayspec-display->actual displayspec2))
  262.          (read-fieldvalue-from-minibuffer fieldname displayspec1)
  263.        (error "displayspecs have different display->actual")))))
  264.  
  265. (defun read-fieldvalue-from-minibuffer (fieldname displayspec)
  266.   (display->actual-call
  267.    (displayspec-display->actual displayspec)
  268.    (read-from-minibuffer
  269.     (format "Enter value for %s field: " fieldname))
  270.    nil nil nil))
  271.  
  272. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  273. ;;; Compare
  274. ;;;
  275.  
  276. ;;;###autoload
  277. (defun databases-compatible (db1 db2)
  278.   "Return t if the database records have the same field names and type, nil otherwise."
  279.   ;; Should eventually check types as well.
  280.   (recordfieldspecs-compatible db1 db2))
  281.  
  282. ;; This can probably be just a call to process-two-databases.  (Should I
  283. ;; provide some abstraction as well?  I dunno.  That's why this is called a
  284. ;; hack.)
  285.  
  286. (defun database-compare-hack (db1 db2)
  287.   ;; Check that fieldnames and types are the same.
  288.   (if (not (databases-compatible db1 db2))
  289.       (error "Incompatible databases."))
  290.   (let* ((name1 (or (database-print-name db1) "First Database"))
  291.      (name2 (or (database-print-name db2) "Second Database"))
  292.      (loners1 (get-buffer-create (concat "Loners for " name1)))
  293.      (loners2 (get-buffer-create (concat "Loners for " name2)))
  294.      (discrep (get-buffer-create (concat "Discrepancies between "
  295.                          name1 "and " name2))))
  296.     (in-buffer loners1
  297.       (erase-buffer))
  298.     (in-buffer loners2
  299.       (erase-buffer))
  300.     (in-buffer discrep
  301.       (erase-buffer))
  302.    
  303.     (db-process-two-databases
  304.      db1 db2
  305.      (function (lambda (record)
  306.          (in-buffer loners1
  307.            (print-record record db1))))
  308.      (function (lambda (record)
  309.          (in-buffer loners2
  310.            (print-record record db2))))
  311.      (function (lambda (record1 record2)
  312.          ;; We already know that order-function considers the two
  313.          ;; records the same; now we need to check whether any of
  314.          ;; their fields differ and if so, report it.
  315.          (if (not (equal record1 record2))
  316.              (in-buffer discrep
  317.                (print-compare-records record1 record2 db1))))))))
  318.  
  319.  
  320. ;;; db-two-dbs.el ends here
  321.