;; This is the main source code file to my first OMT Explainer prototype.
;; More information can be found at: http://www.neilvandyke.org/omt-explainer/
;; My current email address is: neil@neilvandyke.org
;;
;; This is version 1.3, GPL'd and released on 16-Jan-2002, just in case anyone
;; might find it on the Web and get some use out of skimming the code.
;;
;; Copyright 1996 Neil W. Van Dyke, All rights reserved.
;;
;; This is free software; you can redistribute it and/or modify it under the
;; terms of the GNU General Public License as published by the Free Software
;; Foundation; either version 2, or (at your option) any later version.  This
;; is distributed in the hope that it will be useful, but without any warranty;
;; without even the implied warranty of merchantability or fitness for a
;; particular purpose.  See the GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License along with
;; GNU Emacs; see the file `COPYING'.  If not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
;;
;; Original heading...

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                                                                           ;;
;;     ___  __  __ _____   _____            _       _                   _    ;;
;;    / _ \|  \/  |_   _| | ____|_  ___ __ | | __ _(_)_ __   ___ _ __  / |   ;;
;;   | | | | |\/| | | |   |  _| \ \/ / '_ \| |/ _` | | '_ \ / _ \ '__| | |   ;;
;;   | |_| | |  | | | |   | |___ >  <| |_) | | (_| | | | | |  __/ |    | |   ;;
;;    \___/|_|  |_| |_|   |_____/_/\_\ .__/|_|\__,_|_|_| |_|\___|_|    |_|   ;;
;;                                   |_|                                     ;;
;;                                                                           ;;
;;                  by Neil W. Van Dyke <nwv@cs.brown.edu>                   ;;
;;                     Final Project Prototype, Nov 1996                     ;;
;;              CS231, Human Factors and User Interface Design               ;;
;;                 Computer Science Dept., Brown University                  ;;
;;                                                                           ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; NOTES: This code is dirty and kludgey in several ways.  It was created using
;; the parsing and semantic model code of my Jomtool 1.3w package as a starting
;; point.  It is only intended as a research prototype.  See my paper, "OMT
;; Explainer: Dynamic Help for a Graphical Language."  This file was created
;; Tue 12 Nov 1996.

;;---------------------------------------------------------------- Dependencies

(require 'cl)
(require 'eieio)
(require 'time-stamp)
(if window-system (require 'faces))

;;------------------------------------------------------ Package Identification

(defconst oe1-version "1.3")
(defconst oe1-program-name "OMT Explainer")
(defconst oe1-author "Neil W. Van Dyke <nwv@neilvandyke.org>")
(defconst oe1-maintainer-address "nwv@neilvandyke.org")

;;------------------------------------------------------------ Option Variables

(defvar oe1-diagram-title-default "(unnamed)"
  "*Diagram title.
Overridable by `DiagramTitle=<string>' in the OE1 parameters sheet.")

(defvar oe1-params-sheet-regexp "^(OE1 Parameters)$"
  "*Pattern of OMTool sheet that contains OE1 parameters.
Don't change this without good reason.")

(defvar oe1-log-indent-size 4
  "*Number of spaces per level of indentation in OE1 log.")

(defvar oe1-use-head-frame nil
  "*!!!")

;;------------------------------------------------------------------- Constants

(setq oe1-install t
      ;; Adjust `oe1-install', then eval the entire `setq'.
      oe1-httpd-base-url
      "http://www.media.mit.edu/~nwv/projects/omt-explainer/new-demo/"
      oe1-httpd-index-base-fname "index.html"
      oe1-src-dir "/u/nwv/projects/omt-explainer/"
      oe1-dest-dir
      (if oe1-install
          "/mas/u/nwv/web/installed/projects/omt-explainer/new-demo/"
        oe1-src-dir)
      oe1-base-url (if oe1-install
                       oe1-httpd-base-url
                     (concat "file:" oe1-src-dir))
      oe1-defn-base-url (concat oe1-base-url "defns/")
      oe1-defn-dir (concat oe1-dest-dir "defns/")
      oe1-dgms-dir (concat oe1-dest-dir "dgms/")
      oe1-models-dir (concat oe1-src-dir "models/")
      oe1-defn-index-url (concat oe1-defn-base-url oe1-httpd-index-base-fname)
      oe1-defn-index-fname (concat oe1-defn-dir oe1-httpd-index-base-fname))

(defconst oe1-defn-frame "oe1definition")
(defconst oe1-diag-frame "oe1diagram")
(defconst oe1-expl-frame "oe1explanation")
(defconst oe1-head-frame "oe1heading")

(defconst oe1-defn-bg-color "#cceecc")
(defconst oe1-expl-bg-color "#eeeeaa")
(defconst oe1-head-bg-color "#8080a0")

(defconst oe1-log-buffer-name "*OE1 Log*")

(defconst oe1-file-modes-rw-r-r 420);; 644 octal
(defconst oe1-file-modes-rwx-rx-rx 493);; 755 octal

;;------------------------------------------------------------ Global Variables

(defvar oe1-current-model nil
  "Placeholder for current model.
Only picked up through dynamic scoping; `let', do not `setq'.")

(defvar oe1-current-model-name nil
  "Placeholder for current model name.
Only picked up through dynamic scoping; `let', do not `setq'.")

(defvar oe1-log-error-count nil
  "Count of logged errors.")

(defvar oe1-log-nesting nil
  "Depth of log message hierarchy nesting.")

(defvar oe1-log-warning-count nil
  "Count of logged warnings.")

;;-------------------------------------------------------------- Generic: Faces

(defun oe1-set-face-region (begin end face)
  (put-text-property begin end 'face face))

;;------------------------------------------------------------- Generic: String

(defun oe1-ident-as-word-list (str)
  (let ((case-fold-search nil)
        (start 0)
        (words '()))
    (while (string-match "\\([A-Z][a-z]*\\|[a-z]+\\)" str start)
      ;;(assert (= (match-beginning 1) start))
      (setq words (nconc words (list (downcase (match-string 1 str))))
            start (match-end 1)))
    words))

(defun oe1-ident-as-phrase (str)
  (let ((list (oe1-ident-as-word-list str)))
    (if list
        (mapconcat 'identity list " "))))

(defun oe1-if-nonblank (str &optional str-if-blank)
  (if (oe1-string-blank str)
      str-if-blank
    str))

(defun oe1-split-lines (str)
  (let ((len (length str))
        (list '())
        (start 0))
    (while (< start len)
      (if (string-match "\n" str start)
          (setq list (append list
                             (list (substring str start (match-beginning 0))))
                start (match-end 0))
        (setq list (append list (list (substring str start)))
              start len)))
    list))

(defun oe1-str-to-bool (str)
  (let ((s (intern (downcase (format "%s" str)))))
    (cond
     ((memq s '(yes y true t ja))   t)
     ((memq s '(no n false f nein)) nil)
     (t (oe1-error "oe1-str-to-bool: Invalid string \"%s\"." str)))))

(defun oe1-string-blank (str)
  (or (null str) (string-match "^[ \t]*$" str)))

;;--------------------------------------------------------------- Generic: Time

(defun oe1-cur-time-str ()
  (oe1-time-str (current-time)))

(defun oe1-time-str (time)
  (if (fboundp 'time-stamp-strftime)
      (time-stamp-strftime "%02H:%02M:%02S %02d-%3b-%04y %Z" time)
    (current-time-string time)))

;;------------------------------------------------------ Generic: Eieio Helpers

(defmacro oe1-oappend (object attr value)
  `(let ((oe1-oappend-object ,object))
     (oset oe1-oappend-object ,attr
           (append (oref oe1-oappend-object ,attr)
                   (list ,value)))))

(defmacro oe1-oappend-fast (object attr value)
  `(oset ,object ,attr (append (oref ,object ,attr)
                               (list ,value))))

;;------------------------------------------------------------------- Misc. Goo

(defun oe1-gen-file (fname text)
  (set-buffer (generate-new-buffer fname))
  (insert text)
  (write-file fname)
  (set-file-modes buffer-file-name oe1-file-modes-rw-r-r)
  (kill-buffer (current-buffer)))

(defun oe1-object-key-and-name (object)
  (let ((name (oref object name))
        (key (oref object key)))
    (concat key
            (if name
                (concat " (\"" name "\")")
              ""))))

(defmacro oe1-oset-munge-ident (object attr)
  `(oset ,object
         ,attr
         (oe1-munge-ident (oref ,object ,attr))))

(defun oe1-fix-array-mods (o)
  (let ((type (oref o type)))
    (if type
        (if (string-match "^\\([^\\[]*\\)\\(\\[.*\\)$" type)
            (progn
              (oset o type (match-string 1 type))
              (oset o array-mods (match-string 2 type)))))))

(defun oe1-type-and-name (o)
  (concat
   (or (oref o type) "???")
   " "
   (or (oref o name) "???")
   (or (oref o array-mods) "")))

;;-------------------------------------------------------------- Error-Handling

(defun oe1-assert (condition format-string &rest args)
  (or condition
      (apply 'oe1-error format-string args)))

(defun oe1-error (format-string &rest args)
  (apply 'error format-string args))

;;--------------------------------------------------------------------- Logging

(defun oe1-log (format &rest args)
  (save-excursion
    (switch-to-buffer oe1-log-buffer-name)
    (goto-char (point-max))
    (insert (make-string (* oe1-log-nesting oe1-log-indent-size) 32)
            (apply 'format format args)
            "\n"
            )))

(defmacro oe1-log-activity (what &rest body)
  `(let ((oe1-log-activity-what ,what))
     (oe1-log-activity-begin oe1-log-activity-what)
     (prog1 (progn ,@body)
       (oe1-log-activity-end oe1-log-activity-what t))))

(defun oe1-log-activity-begin (what)
  (oe1-assert (stringp what)
              "oe1-log-activity-begin: `what' arg not a string.")
  (message "%s..." what)
  (oe1-log "%s..." what)
  (setq oe1-log-nesting (1+ oe1-log-nesting)))

(defun oe1-log-activity-end (what &optional same)
  (message "%s...done" what)
  (setq oe1-log-nesting (max (1- oe1-log-nesting) 0))
  (if (not same)
      (oe1-log "...%s" what)))

(defun oe1-log-begin ()
  (save-excursion
    (switch-to-buffer oe1-log-buffer-name)
    (setq buffer-read-only nil
          buffer-undo-list t)
    (delete-region (point-min) (point-max))
    (insert "*** NOTE: LOG WAS NOT ENDED PROPERLY. RUN PROBABLY FAILED. ***\n"
            "Start Time:       " (oe1-cur-time-str) "\n"
            (make-string 79 ?-) "\n"))
  (setq oe1-log-error-count   0
        oe1-log-nesting       0
        oe1-log-warning-count 0))

(defun oe1-log-blank-line ()
  (oe1-log ""))

(defun oe1-log-end ()
  ;; Switch to log buffer.
  (switch-to-buffer oe1-log-buffer-name)
  ;; Add bottom line.
  (goto-char (point-max))
  (insert (make-string 79 ?-) "\n")
  ;; Delete the incomplete error line, and add more headers.
  (goto-char (point-min))
  (delete-region (point) (progn (forward-line 1) (point)))
  (forward-line 1)
  (insert "Finish Time:      " (oe1-cur-time-str) "\n"
          "Errors/Warnings:  " (format "%d / %d\n"
                                       oe1-log-error-count
                                       oe1-log-warning-count))
  ;; Fontifty.
  (if (featurep 'faces)
      (let ((header t))
        (goto-char (point-min))
        (while (not (eobp))
          (if header
              (cond
               ((looking-at "-") (setq header nil))
               ((looking-at "[ ]*\\([^:]*:\\)")
                (oe1-set-face-region (match-beginning 1)
                                     (match-end 1)
                                     'bold)))
            (if (looking-at "[ ]*\\(\\(ERROR\\|WARNING\\):\\)[ ]*\\(.*\\)$")
                (progn
                  (oe1-set-face-region (match-beginning 1)
                                       (match-end 1)
                                       'bold)
                  (oe1-set-face-region (match-beginning 3)
                                       (match-end 3)
                                       'italic))))
          (forward-line 1))))
  ;; Leave the buffer like we want it.
  (goto-char (point-min))
  (set-buffer-modified-p nil)
  (setq buffer-read-only t)
  (local-set-key "q" (function (lambda ()
                                 (interactive)
                                 (kill-buffer (current-buffer)))))
  ;; Give user a message.
  (message "Type `q' in the `%s' buffer to kill it."
           oe1-log-buffer-name))

(defun oe1-log-error (format &rest args)
  (setq oe1-log-error-count (1+ oe1-log-error-count))
  (apply 'oe1-log (concat "ERROR: " format) args))

(defun oe1-log-info (format &rest args)
  (apply 'oe1-log format args))

(defun oe1-log-warning (format &rest args)
  (setq oe1-log-warning-count (1+ oe1-log-warning-count))
  (apply 'oe1-log (concat "WARNING: " format) args))

;;------------------------------------------------------------ Class: oe1-model

(defclass oe1-model ()
  ((bad)
   (binassocs)
   (classes)
   (classes-alist)
   (diagram-title)
   (genrels)
   (hits)
   (language)
   (name)
   (package)
   (source-name)
   (start-time)
   )
  "")

(defmethod oe1-add-arc-hits ((o oe1-model) key points)
  (let (last-x last-y this-x this-y)
    (mapcar
     (function
      (lambda (n)
        (setq this-x (nth 0 n)
              this-y (nth 1 n))
        (if last-x
            (oe1-add-hit o (oe1-hit-line "" :key key :x1 last-x :y1 last-y
                                         :x2 this-x :y2 this-y)))
        (setq last-x this-x
              last-y this-y)))
     points)))

(defmethod oe1-add-hit ((o oe1-model) hit)
  (oe1-oappend-fast o hits hit))

(defmethod oe1-add-hits ((o oe1-model) hits)
  (mapcar (function (lambda (n)
                      (oe1-oappend-fast o hits hits)))
          hits))

(defmethod oe1-init ((o oe1-model))
  "Constructor for oe1-model."
  (oset o diagram-title     oe1-diagram-title-default)
  )

(defmethod oe1-add-class ((o oe1-model) class)
  (let ((key (oref class key)))
    (oe1-assert key "OMT class has no key.")
    (oe1-assert (not (assq key (oref o classes)))
                "Class %s already exists." key)
    (oe1-oappend-fast o classes class)))

(defmethod oe1-crunch ((o oe1-model))
  (oe1-log-activity
   "Crunching on model"
   ;; Build classes-alist.
   (oset o classes-alist (mapcar (function (lambda (n)
                                             (cons (oref n key) n)))
                                 (oref o classes)))
   ;; Crunch the genrels.
   (mapcar 'oe1-crunch (oref o genrels))
   ;; Crunch the classes.
   (mapcar 'oe1-crunch (oref o classes))
   ;; Crunch the binassocs.
   (mapcar 'oe1-crunch (oref o binassocs))
   ;;
   ))

(defmethod oe1-gen-diagram-html-file ((o oe1-model))
  (oe1-gen-file
   (concat (oe1-dgmout-dir) "diagram.html")
   (concat "<HTML>\n"
           (oe1-head-html "Diagram" nil)
           "<BODY BGCOLOR=\"#ffffff\">\n"
           "<BASE TARGET=\"" oe1-expl-frame "\">\n"
           ;;(oe1-boxed-head-html "Diagram")
           "<P ALIGN=\"center\">"
           "<IMG BORDER=\"0\" SRC=\"diagram.gif\" USEMAP=\"#map\">"
           "</P>\n"
           "<MAP NAME=\"map\">\n"
           (mapconcat (function (lambda (n) (oe1-area-html n)))
                      (oref o hits)
                      "")
           "</MAP>\n"
           "</BODY>\n"
           "</HTML>\n")))

(defmethod oe1-gen-explanation-html-file ((o oe1-model))
  (oe1-gen-file
   (concat (oe1-dgmout-dir) "explanation.html")
   (concat "<HTML>\n"
           (oe1-head-html "Explanation" nil)
           "<BODY BGCOLOR=\"" oe1-expl-bg-color "\" LINK=\"#000000\" "
           "VLINK=\"#000000\" ALINK=\"#ff0000\">\n"
           (oe1-boxed-head-html "Explanation")
           "<P ALIGN=\"center\"><I>"
           "Click on an item in the diagram above and view an explanation of "
           "it here."
           "</I></P>\n"
           "</BODY>\n"
           "</HTML>\n")))

(defmethod oe1-gen-heading-html-file ((o oe1-model))
  (oe1-gen-file
   (concat (oe1-dgmout-dir) "heading.html")
   (concat "<HTML>\n"
           (oe1-head-html "Heading" nil)
           "<BODY BGCOLOR=\"#8080a0\">\n"
           "<P ALIGN=\"center\"><FONT COLOR=\"#ffffff\" SIZE=\"+3\"><B><I>"
           oe1-program-name
           "</I></B></FONT><BR>\n"
           "<FONT COLOR=\"#ffffc0\">Diagram: <B>"
           (oref o diagram-title)
           "</B></FONT></P>\n"
           "</BODY>\n"
           "</HTML>\n")))

(defmethod oe1-gen-index-html-file ((o oe1-model))
  (oe1-gen-file
   (concat (oe1-dgmout-dir) oe1-httpd-index-base-fname)
   (concat "<HTML>\n"
           (oe1-head-html nil nil)
           "<FRAMESET BORDER=\"1\" ROWS=\""
           (if oe1-use-head-frame
               "75,"
             "")
           "70%,30%\">\n"
           (if oe1-use-head-frame
               (oe1-html-frame oe1-head-frame "heading.html" nil)
             "")
           (oe1-html-frame oe1-diag-frame "diagram.html" t)
           "<FRAMESET COLS=\"50%,50%\">\n"
           (oe1-html-frame oe1-expl-frame "explanation.html" t)
           (oe1-html-frame oe1-defn-frame oe1-defn-index-url t)
           "</FRAMESET>\n"
           "</FRAMESET>\n"
           "<BODY>\n"
           "<P>You really need frames to run this.</P>\n"
           "</BODY>\n"
           "</HTML>\n")))

(defmethod oe1-get-class ((o oe1-model) key)
  (or (cdr (assq key (oref o classes-alist)))
      (oe1-error "Class %s not found." key)))

;;------------------------------------------------------------ Class: oe1-class

(defclass oe1-class ()
  (
   (class-attribs)
   (class-methods)
   (class-methods-index)
   (constructors)
   (constructors-index)
   (description)
   (external)
   (imports)
   (instance-attribs)
   (instance-methods)
   (instance-methods-index)
   (is-abstract)
   (key)
   (linked-roles)
   (name)
   (orphan-methods)
   (subclasses)
   (superclass))
  "")

(defmethod oe1-crunch ((o oe1-class))
  ;; See if it's outside the package.
  (if (string-match "\\." (oref o name))
      ;; Outside the package.
      (progn
        (oe1-log-info "Not crunching external class %s"
                      (oe1-object-key-and-name o))
        (oset o external t))
    ;; Inside the package.
    (oe1-crunch-really o)))

(defmethod oe1-crunch-really ((o oe1-class))
  (oe1-log-activity
   (format "Crunching on class %s" (oe1-object-key-and-name o))
   ;; If name blank, make sure set to nil.
   (if (oe1-string-blank (oref o name))
       (oset o name nil))
   ;; Crunch on its components.
   (mapcar 'oe1-crunch (oref o constructors))
   (mapcar 'oe1-crunch (oref o class-attribs))
   (mapcar 'oe1-crunch (oref o class-methods))
   (mapcar 'oe1-crunch (oref o instance-attribs))
   (mapcar 'oe1-crunch (oref o instance-methods))
   ;; Build method indexes.
   (oset o class-methods-index (oe1-method-index (oref o class-methods)))
   (oset o constructors-index (oe1-method-index (oref o constructors)))
   (oset o instance-methods-index
         (oe1-method-index (oref o instance-methods)))
   ;;
   ))

(defmethod oe1-expl ((o oe1-class))
  (let ((name (oref o name)))
    (oe1-html-para
     (concat
      ;;
      (if (oref o is-abstract)
          (concat "An " (oe1-ref-defn "abstract class"))
        (concat "A " (oe1-ref-defn "concrete class")))
      " "
      (if name
          (concat "named " (oe1-html-ident name))
        " which does not yet have a name")
      "."
      ;;
      (let ((members
             (oe1-list-no-nils
              (list (oe1-name-list "instance attribute"
                                   (oref o instance-attribs)
                                   nil t)
                    (oe1-name-list "instance method"
                                   (oref o instance-methods)
                                   nil t)
                    (oe1-name-list "constructor"
                                   (oref o constructors)
                                   nil t)
                    (oe1-name-list "class attribute"
                                   (oref o class-attribs)
                                   nil t)
                    (oe1-name-list "class method"
                                   (oref o class-methods)
                                   nil t)
                    ))))
        (concat " It has "
                (if members
                    (oe1-and-list members)
                  "no members")
                "."))
      ;;
      ))))

(defmethod oe1-get-method ((o oe1-class) kind signature)
  (cdr (assoc signature (ecase kind
                          ('class       (oref o class-methods-index))
                          ('constructor (oref o constructors-index))
                          ('instance    (oref o instance-methods-index))))))

(defun oe1-method-index (method-list)
  (mapcar (function (lambda (n) (cons (oref n signature) n)))
          method-list))

;;----------------------------------------------------------- Class: oe1-attrib

(defclass oe1-attrib ()
  ((array-mods)
   (default)
   (is-class)
   (key)
   (name)
   (bad)
   (type))
  "")

(defmethod oe1-crunch ((o oe1-attrib))
  (oe1-log-activity
   (format "Crunching on attribute \"%s\"" (oref o name))
   ;;
   (oe1-oset-munge-ident o name)
   (oe1-oset-munge-ident o type)
   ;;
   (oe1-fix-array-mods o)
   ;;
   ))

(defmethod oe1-expl ((o oe1-attrib))
  (let ((default (oref o default))
        (name    (oref o name))
        (type    (oref o type)))
    (oe1-html-para
     (concat
      (if (oref o is-class)
          (concat "A " (oe1-ref-defn "class attribute"))
        (concat "An " (oe1-ref-defn "instance attribute")))
      " "
      (if name
          (concat "named " (oe1-html-ident name))
        " which does not yet have a name")
      (if type
          (concat ", of type " (oe1-html-ident type))
        (if name
            ", which does not yet have a type"
          " or a type."))
      (if default
          (concat ", with a default value of &quot;" default "&quot;")
        "")
      "."
      ))))

;;----------------------------------------------------------- Class: oe1-method

(defclass oe1-method ()
  ((access)
   (array-mods)
   (arglist)
   (bad)
   (body)
   (description)
   (is-abstract)
   (is-virtual)
   (key)
   (kind)
   (name)
   (orphan)
   (signature)
   (type))
  "")

(defmethod oe1-crunch ((o oe1-method))
  (oe1-log-activity
   (format "Crunching on method \"%s\"" (oref o name))
   ;; Set kind to "instance" if not set already.
   (if (null (oref o kind))
       (oset o kind 'instance))
   ;; Munge identifiers.
   (oe1-oset-munge-ident o name)
   (oe1-oset-munge-ident o type)
   ;;
   (oe1-fix-array-mods o)
   ;; Crunch arguments, and mark method as bad if any of the args are bad.
   (let ((count 0))
     (mapcar (function (lambda (n)
                         (oe1-crunch n)
                         (if (oref n bad) (setq count (1+ count)))))
             (oref o arglist)))
   ;; Generate signature.
   (oset o signature (if (oref o bad)
                         "SIGNATURE_OF_BAD_METHOD"
                       (concat (oref o name)
                               "("
                               (mapconcat
                                (function
                                 (lambda (n)
                                   (concat (or (oref n type))
                                           (or (oref n array-mods)))))
                                (oref o arglist)
                                ",")
                               ")")))))

(defmethod oe1-expl ((o oe1-method))
  (let ((name (oref o name))
        (type (oref o type)))
    (oe1-html-para
     (concat
      (ecase (oref o kind)
        ('class (concat "A " (oe1-ref-defn "class method")))
        ('constructor (concat "A " (oe1-ref-defn "constructor")))
        ('instance (concat "An " (oe1-ref-defn "instance method"))))
      " "
      (if name
          (concat "named " (oe1-html-ident name))
        " which does not yet have a name")
      (if type
          (concat ", which returns a value of type " (oe1-html-ident type))
        "")
      "."
      ))))

;;-------------------------------------------------------------- Class: oe1-arg

(defclass oe1-arg ()
  ((array-mods)
   (bad)
   (name)
   (type))
  "")

(defmethod oe1-crunch ((o oe1-arg))
  (oe1-log-activity
   (format "Crunching on argument \"%s\"" (oref o name))
   (oe1-oset-munge-ident o name)
   (oe1-oset-munge-ident o type)
   (oe1-fix-array-mods o)))

;;----------------------------------------------------------- Class: oe1-genrel

(defclass oe1-genrel ()
  ((key)
   (subclass-keys)
   (subclasses)
   (superclass-key)
   (superclass)
   )
  "")

(defmethod oe1-crunch ((o oe1-genrel))
  (oe1-log-activity
   (format "Crunching on generalization association %s" (oref o key))
   ;; Make links from subclasses to superclass.
   (let* ((superclass-key (oref o superclass-key))
          (superclass (oe1-get-class oe1-current-model
                                     superclass-key)))
     (if superclass
         (progn
           (oset o superclass superclass)
           (mapcar (function
                    (lambda (subclass-key)
                      (let ((subclass (oe1-get-class oe1-current-model
                                                     subclass-key)))
                        (if subclass
                            (progn
                              (oset subclass superclass superclass)
                              (oe1-oappend-fast o subclasses subclass))
                          (oe1-log-error "Subclass %s not defined."
                                         subclass-key)))))
                   (oref o subclass-keys)))
       (oe1-log-error "Superclass %s not defined." superclass-key)))))

(defmethod oe1-expl ((o oe1-genrel))
  (let ((subclasses (oref o subclasses)))
    (oe1-html-para
     (concat
      "A "
      (oe1-ref-defn "generalization association")
      " between "
      (oe1-ref-defn "superclass")
      " "
      (oe1-ref-desc-name (oref o superclass))
      " and "
      (oe1-ref-defn "subclass"
                    (if (= (length subclasses) 1) "subclass" "subclasses"))
      " "
      (oe1-and-list (mapcar 'oe1-ref-desc-name subclasses))
      "."))))

;;--------------------------------------------------------- Class: oe1-binassoc

(defclass oe1-binassoc ()
  ((key)
   (link-class)
   (link-class-key)
   (name)
   (role1)
   (role2))
  "")

(defmethod oe1-assembly-role ((o oe1-binassoc))
  (cond ((oref (oref o role1) is-assembly) (oref o role1))
        ((oref (oref o role2) is-assembly) (oref o role2))
        nil))

(defmethod oe1-crunch ((o oe1-binassoc))
  (oe1-log-activity
   (format "Crunching on simple binary association %s" (oref o key))
   (let ((role1 (oref o role1))
         (role2 (oref o role2)))
     ;; Resolve the link class.
     (let ((k (oref o link-class-key)))
       (if k
           (oset o link-class (oe1-get-class oe1-current-model k))))
     ;; Make inverse links from the role objects.
     (oset role1 binassoc o)
     (oset role2 binassoc o)
     ;; Crunch the role objects.
     (oe1-crunch role1)
     (oe1-crunch role2)
     ;;
     )))

(defmethod oe1-desc ((o oe1-binassoc))
  (let ((name (oref o name)))
    (concat
     "simple binary association"
     (if name (concat " \"%s\"") "")
     " between \""
     (oref (oref (oref o role1) class) name)
     "\" and \""
     (oref (oref (oref o role2) class) name)
     "\"")))


(defmethod oe1-expl ((o oe1-binassoc))
  (let ((name (oref o name))
        (assembly-role (oe1-assembly-role o))
        r1 r2)
    (if assembly-role
        (setq r1 assembly-role
              r2 (oe1-other-role o assembly-role))
      (setq r1 (oref o role1)
            r2 (oref o role2)))
    (let ((c1 (oref r1 class))
          (c2 (oref r2 class)))
      (concat
       ;;
       (oe1-html-para
        ;;
        (if (eq (oref r1 mult) 'optional) "An" "A")
        " "
        (oe1-ref-defn (concat
                       (oe1-mult-expl-include r1)
                       "-to-"
                       (oe1-mult-expl-include r2)))
        ;;
        " "
        (oe1-ref-defn (if assembly-role
                          "aggregation association"
                        "simple association"))
        (if name
            (concat " named " (oe1-html-ident name)))
        " between "
        (oe1-ref-defn "class")
        " "
        (oe1-ref-desc-name c1)
        (oe1-expl-include r2)
        " and "
        (if (eq c2 c1)
            "itself"
          (concat "class " (oe1-ref-desc-name c2)))
        (oe1-expl-include r1)
        (let ((link-class (oref o link-class)))
          (if link-class
              (concat ", implemented as class " (oe1-ref-desc-name link-class)
                      " (" (oe1-ref-defn "association as class") ")")
            ""))
        ".")
       ;;
       (let ((a-name (if name
                         (oe1-ident-as-phrase name)
                       (if assembly-role "consists of" "has")))
             (c1-name (oref c1 name))
             (c2-name (oref c2 name))
             (r1-name (oref r1 name))
             (r2-name (oref r2 name)))
         (if (and a-name c1-name c2-name)
             (progn
               (setq c1-name (oe1-ident-as-phrase c1-name))
               (setq c2-name (oe1-ident-as-phrase c2-name))
               (oe1-html-para
                "One of the directions may be read roughly as: <I>&quot;"
                (oe1-an-and-str c1-name t)
                (if (eq (oref r2 mult) 'optional)
                    " optionally"
                  "")
                (if r1-name
                    (concat " (as "
                            (oe1-ident-as-phrase r1-name)
                            ")")
                  "")
                " "
                a-name
                " "
                (if (oe1-mult-is-many r2)
                    (concat "zero or more " (oe1-pluralize c2-name))
                  (oe1-an-and-str c2-name))
                (if r2-name
                    (concat " (as "
                            (oe1-ident-as-phrase r2-name)
                            ")")
                  "")
                (let ((qualifier (oref (oe1-other-role r2) qualifier)))
                  (if qualifier
                      (concat ", identified by "
                              (oe1-ident-as-phrase (oref qualifier name)))
                    ""))
                ".&quot;</I>"))
           ""))
       ;;
       ))))

(defmethod oe1-other-role ((o oe1-binassoc) role)
  (let ((role1 (oref o role1))
        (role2 (oref o role2)))
    (if (eq role role1)
        role2
      (oe1-assert (eq role role2) "Bad role parameter.")
      role1)))

;;------------------------------------------------------------- Class: oe1-role

(defclass oe1-role ()
  ((binassoc)
   (class)
   (class-key)
   (is-arrow)
   (is-assembly)
   (is-ordered)
   (key)
   (mult)
   (name)
   (qualifier))
  "")

(defmethod oe1-crunch ((o oe1-role))
  (oe1-log-activity
   "Crunching on role"
   (let ((class (oe1-get-class oe1-current-model (oref o class-key)))
         (other-role (oe1-other-role o)))
     ;; Maybe munge role name.
     (oe1-oset-munge-ident o name)
     ;; Make link to class object based on class-key.
     (oset o class class)
     ;;
     )))

(defmethod oe1-mult-is-many ((o oe1-role))
  (or (eq (oref o mult) 'many)
      (oref (oe1-other-role o) qualifier)))

(defmethod oe1-other-role ((o oe1-role))
  (oe1-other-role (oref o binassoc) o))

(defmethod oe1-expl-include ((o oe1-role))
  (let* ((name (oref o name))
         (qual (oref o qualifier))
         (name-text (if name
                        (concat (oe1-ref-defn "role name")
                                " "
                                (oe1-html-ident name))))
         (qual-text (if qual
                        (concat (oe1-ref-defn "qualifier")
                                " "
                                (oe1-html-ident (oref qual name))))))
    (if name-text
        (if qual-text
            (concat " (with " name-text " and " qual-text ")")
          (concat " (with " name-text ")"))
      (if qual-text
          (concat " (with " qual-text ")")))))

(defmethod oe1-mult-expl-include ((o oe1-role))
  (if (oref (oe1-other-role o) qualifier)
      "many"
    (ecase (oref o mult)
      ('many     "many")
      ('one      "one")
      ('optional "optional"))))

;;-------------------------------------------------------- Class: oe1-qualifier

(defclass oe1-qualifier ()
  ((array-mods)
   (key)
   (name)
   (type))
  "")

;;-------------------------------------------------------------- Class: oe1-hit

(defclass oe1-hit ()
  ((key :initarg :key)
   )
  "")

;;--------------------------------------------------------- Class: oe1-hit-rect

(defclass oe1-hit-rect (oe1-hit)
  ((x)
   (y)
   (w)
   (h)
   )
  "")

(defmethod oe1-x2 ((o oe1-hit-rect))
  (+ (oref o x) (oref o w)))

(defmethod oe1-y2 ((o oe1-hit-rect))
  (+ (oref o y) (oref o h)))

(defmethod oe1-area-html ((o oe1-hit-rect))
  (oe1-html-area (oe1-expl-url (oref o key))
                 "RECT"
                 (concat (oref o x) "," (oref o y) ","
                         (oe1-x2 o) "," (oe1-y2 o))))

;;--------------------------------------------------------- Class: oe1-hit-line

(defclass oe1-hit-line (oe1-hit)
  ((x1 :initarg :x1)
   (y1 :initarg :y1)
   (x2 :initarg :x2)
   (y2 :initarg :y2)
   )
  "")

(defun oe1-line-to-rect-points-list (x1 y1 x2 y2)
  (if (= x1 x2)
      ;; vertical line
      (setq x1 (- x1 2)
            x2 (+ x2 2))
    ;; horizontal
    (setq y1 (- y1 2)
          y2 (+ y2 2)))
  (list (min x1 x2) (min y1 y2) (max x1 x2) (max y1 y2)))

(defmethod oe1-area-html ((o oe1-hit-line))
  (oe1-html-area (oe1-expl-url (oref o key))
                 "RECT"
                 (mapconcat 'identity
                            (oe1-line-to-rect-points-list (oref o x1)
                                                          (oref o y1)
                                                          (oref o x2)
                                                          (oref o y2))
                            ",")))

;;------------------------------------------------------ Class: oe1-hit-polygon

(defclass oe1-hit-polygon (oe1-hit)
  ((points :initarg :points)
   )
  "")

(defmethod oe1-area-html ((o oe1-hit-polygon))
  (oe1-html-area (oe1-expl-url (oref o key))
                 "POLYGON"
                 (mapconcat (function (lambda (n)
                                        (format "%s,%s" (nth 0 n) (nth 1 n))))
                            (oref o points)
                            ",")))

;;---------------------------------------------------------- Identifier Munging

;; Note: I took out all the nifty Jomtool munging code.

(defun oe1-munge-ident (ident)
  (if (oe1-string-blank ident)
      nil
    ident))

;;--------------------------------------------------------- OMTool File Parsing

(defmacro oe1-forms-parse (forms &rest conds)
  `(mapcar
    (function
     (lambda (n)
       (case (car n)
         ,@conds
         (t (oe1-log-warning "Construct \"%s\" not recognized." (car n)))
         )))
    ,forms))

(defun oe1-parse (d)
  (oe1-log-activity
   "Parsing module"
   (let (o name)
     (oe1-forms-parse
      (cdr d)
      ('anno)
      ('fcode_max)
      ('key)
      ('language)
      ('name (setq name (oe1-parse-strval (nth 1 n))))
      ('omt_image (progn
                    (oe1-assert o "Got image before model.")
                    (oe1-parse-image o n)))
      ('omt_model (setq o (oe1-parse-model n))))
     (oe1-assert o "No \"omt_model\" found.")
     (oset o name name)
     o)))

(defun oe1-parse-arg (d)
  (let ((o (oe1-arg "")))
    ;;
    (oe1-forms-parse
     (cdr d)
     ('default)
     ('key)
     ('name (oset o name (oe1-parse-ident (nth 1 n))))
     ('type (oset o type (oe1-parse-type n))))
    o))

(defun oe1-parse-attrib (d)
  (let ((o (oe1-attrib "")))
    (oe1-forms-parse
     (cdr d)
     ('anno)
     ('default (oset o default (oe1-parse-strval (nth 1 n))))
     ('is_class (oset o is-class t))
     ('key (oset o key (oe1-parse-keyval (nth 1 n))))
     ('name (oset o name (oe1-parse-ident (nth 1 n))))
     ('type (oset o type (oe1-parse-type n))))
    ;;
    o))

(defun oe1-parse-binassoc (d)
  (oe1-log-activity
   "Parsing simple binary association"
   (let ((o (oe1-binassoc "")))
     (oe1-forms-parse
      (cdr d)
      ('anno
       (ecase (nth 1 n)
         ('cxx_role1_access)
         ('cxx_role2_access)
         ('role1_is_class)
         ('role2_is_class)
         ('cxx_assoc_impl)
         ('cxx_embed_link_class)
         ('description)
         ))
      ('key (oset o key (oe1-parse-keyval (nth 1 n))))
      ('link_class_key (oset o link-class-key (oe1-parse-keyval (nth 1 n))))
      ('name (oset o name (oe1-parse-ident (nth 1 n))))
      ('role (let ((role (oe1-parse-role n)))
               (if (oref o role1)
                   (oset o role2 role)
                 (oset o role1 role))))
      )
     o)))

(defun oe1-parse-binrelarc (model d)
  (oe1-log-activity
   "Parsing binary relation arc"
   (let (points key)
     ;; Parse.
     (oe1-forms-parse
      (cdr d)
      ('anno)
      ('arc_label);;!!!
      ('boxes)
      ('key)
      ('label)
      ('link_box);;!!!
      ('points (setq points (cdr n)))
      ('qualifier);;!!!
      ('represents (setq key (oe1-parse-keyval (nth 1 n))))
      )
     ;; Add hit regions to model.
     (oe1-add-arc-hits model key points))))

(defun oe1-parse-class (d)
  (let ((o (oe1-class ""))
        (class-name nil))
    ;;
    (oe1-log-activity-begin "Parsing class")
    ;; Parse the class data.
    (oe1-forms-parse
     (cdr d)
     ('anno
      (ecase (nth 1 n)
        ('abstract_class (oset o is-abstract t))
        ('abstract_method)
        ('const)
        ('cxx_postclass_pattern)
        ('cxx_postmember_pattern)
        ('cxx_preclass_pattern)
        ('cxx_premember_pattern)
        ('description (oset o description (oe1-parse-descval (nth 2 n))))
        ('unique_fields)
        ('unique_methods)
        ('virtual_method)
        ))
     ('field (let ((attrib (oe1-parse-attrib n)))
               (if (oref attrib is-class)
                   (oe1-oappend-fast o class-attribs attrib)
                 (oe1-oappend-fast o instance-attribs attrib))))
     ('key (oset o key (oe1-parse-keyval (nth 1 n))))
     ('method (let* ((method (oe1-parse-method n))
                     (name (oref method name)))
                (cond
                 ;; Constructor.
                 ((or (string= (downcase name) "constructor")
                      (and class-name
                           (string= (downcase name) (downcase class-name))))
                  (oset method name class-name)
                  (oset method kind 'constructor)
                  (oe1-oappend-fast o constructors method))
                 ;; Class method.
                 ((eq (oref method kind) 'class)
                  (oe1-oappend-fast o class-methods method))
                 ;; Instance method.
                 (t (oe1-oappend-fast o instance-methods method)))))
     ('name (progn
              (setq class-name (oe1-parse-ident (nth 1 n)))
              (oset o name class-name))))
    ;; Output status message.
    (oe1-log-activity-end (format "Parsing class %s"
                                  (oe1-object-key-and-name o)))
    ;; Return class object.
    o))

(defun oe1-parse-classbox (model d)
  (oe1-log-activity
   "Parsing class box"
   (let (hit key)
     (oe1-forms-parse
      (cdr d)
      ('anno)
      ('frame (setq hit (oe1-parse-frame n)))
      ('key)
      ('represents (setq key (oe1-parse-keyval (nth 1 n))))
      )
     ;;
     (oset hit key key)
     (oe1-add-hit model hit))))

(defun oe1-parse-comment (model d)
  (oe1-log-activity
   "Parsing comment"
   (oe1-forms-parse
    (cdr d)
    ('key)
    ('loc)
    ('text
     (let ((text (nth 1 n)))
       (if (string-match "^[ \t]*\\([a-zA-Z]+\\)[ \t]*=[ \t]*\\([^ \t].*\\)"
                         text)
           (let ((name (intern (match-string 1 text)))
                 (value (car (read-from-string (match-string 2 text)))))
             (ecase name
               ('DiagramTitle    (oset model diagram-title value))
               (t (oe1-log-warning "Invalid OE1 parameter name \"%s\"."
                                   name))))
         (oe1-log-warning "Invalid OE1 parameter \"%s\"." text)))))))

(defun oe1-parse-descval (d)
  (oe1-split-lines (oe1-parse-strval d)))

(defun oe1-parse-frame (d)
  (oe1-log-activity
   "Parsing frame"
   (let ((o (oe1-hit-rect "")))
     (oe1-forms-parse
      (cdr d)
      ('dimensions (oset o w (oe1-parse-intval (nth 1 n)))
                   (oset o h (oe1-parse-intval (nth 2 n))))
      ('loc (oset o x (oe1-parse-intval (nth 1 n)))
            (oset o y (oe1-parse-intval (nth 2 n))))
      )
     o)))

(defun oe1-parse-genrel (d)
  (oe1-log-activity
   "Parsing generalization association"
   (let ((o (oe1-genrel "")))
     (oe1-forms-parse
      (cdr d)
      ('anno)
      ('key (oset o key (oe1-parse-keyval (nth 1 n))))
      ('subclasses (oset o subclass-keys (cdr n)))
      ('superclass (oset o superclass-key (oe1-parse-keyval (nth 1 n))))
      )
     o)))

(defun oe1-parse-genrelarc (model d)
  (oe1-log-activity
   "Parsing generalization relation arc"
   (let (key super-points sub-points-list)
     ;; Parse.
     (oe1-forms-parse
      (cdr d)
      ('key)
      ('represents (setq key (oe1-parse-keyval (nth 1 n))))
      ('subclass
       (setq sub-points-list (nconc sub-points-list (list (cdr (cdr n))))))
      ('superclass (setq super-points (cdr (cdr n))))
      )
     ;;
     (oe1-add-arc-hits model key super-points)
     (let* ((sup       (car (last super-points)))
            (horiz-x1  (nth 0 sup))
            (horiz-x2  horiz-x1)
            (horiz-y   (1+ (nth 1 sup)))
            (vertex-pt (nth 1 super-points))
            (tri-x     (nth 0 vertex-pt))
            (tri-y     (nth 1 vertex-pt)))
       (oe1-add-hit model
                    (oe1-hit-polygon "" :key key
                                     :points (list vertex-pt
                                                   (list (+ tri-x 10) horiz-y)
                                                   (list (- tri-x 10) horiz-y)
                                                   vertex-pt)))
       (mapcar (function (lambda (n)
                           (oe1-add-arc-hits model key n)
                           (let ((x (nth 0 (car (last n)))))
                             (setq horiz-x1 (min horiz-x1 x)
                                   horiz-x2 (max horiz-x2 x)))))
               sub-points-list)
       (oe1-add-hit model
                    (oe1-hit-line "" :key key :x1 horiz-x1 :y1 horiz-y
                                  :x2 horiz-x2 :y2 horiz-y))))))

(defun oe1-parse-ident (d)
  (oe1-if-nonblank (oe1-parse-strval d)))

(defun oe1-parse-image (model d)
  (oe1-log-activity
   "Parsing image"
   (oe1-forms-parse
    (cdr d)
    ('sheet (oe1-parse-sheet model n))
    )))

(defun oe1-parse-intval (d)
  (string-to-number (oe1-parse-strval d)))

(defun oe1-parse-keyval (d)
  d)

(defun oe1-parse-method (d)
  (let ((o (oe1-method "")))
    (oset o access 'public)
    (oe1-forms-parse
     (cdr d)
     ('anno
      (ecase (nth 1 n)
        ('abstract_method (oset o is-abstract t))
        ('const)
        ('cxx_method_access (oset o access (nth 2 n)))
        ('description (oset o description (oe1-parse-descval (nth 2 n))))
        ('virtual_method (oset o is-virtual t))))
     ('arglist
      (oset o arglist
            (mapcar (function
                     (lambda (a)
                       (oe1-assert (eq (car a) 'arg) "Non-arg in arglist.")
                       (oe1-parse-arg a)))
                    (cdr n))))
     ('default)
     ('genfile)
     ('genheader)
     ('genstatus)
     ('fcode)
     ('is_class (oset o kind 'class))
     ('key (oset o key (oe1-parse-keyval (nth 1 n))))
     ('name (oset o name (oe1-parse-ident (nth 1 n))))
     ('type (oset o type (oe1-parse-type n))))
    o))

(defun oe1-parse-model (d)
  (oe1-log-activity
   "Parsing model"
   (let ((o (oe1-model "")))
     (oe1-init o)
     (oe1-forms-parse
      (cdr d)
      ('binary_association
       (oe1-oappend-fast o binassocs (oe1-parse-binassoc n)))
      ('binary_constraint)
      ('generalization_order)
      ('generalization_relation
       (oe1-oappend-fast o genrels (oe1-parse-genrel n)))
      ('omt_class (oe1-add-class o (oe1-parse-class n)))
      )
     o)))

(defun oe1-parse-mult (d)
  (ecase (nth 1 d)
    ('0 (if (eq (nth 2 d) '2) 'optional 'many))
    ('1 (if (eq (nth 2 d) '2) 'one 'many))
    (t 'many)))

(defun oe1-parse-qualifier (d)
  (oe1-log-activity
   "Parsing qualifier"
   (let ((o (oe1-qualifier "")))
     (oe1-forms-parse
      (cdr d)
      ('key (oset o key (oe1-parse-keyval (nth 1 n))))
      ('name (oset o name (oe1-parse-ident (nth 1 n))))
      ('type (oset o type (oe1-parse-type n)))
      )
     o)))

(defun oe1-parse-role (d)
  (oe1-log-activity
   "Parsing role"
   (let ((o (oe1-role "")))
     (oe1-forms-parse
      (cdr d)
      ('anno
       (ecase (nth 1 n)
         ('pattern)
         ))
      ('class (oset o class-key (oe1-parse-keyval (nth 1 n))))
      ('is_arrow (oset o is-arrow t))
      ('is_assembly (oset o is-assembly t))
      ('key (oset o key (oe1-parse-keyval (nth 1 n))))
      ('mult (oset o mult (oe1-parse-mult n)))
      ('ordered (oset o is-ordered t))
      ('qualifier (oset o qualifier (oe1-parse-qualifier n)))
      ('rolename (oset o name (oe1-parse-ident (nth 1 n))))
      )
     o)))

(defun oe1-parse-sheet (model d)
  (oe1-log-activity
   "Parsing sheet"
   (let (params-sheet)
     (oe1-forms-parse
      (cdr d)
      ('anno)
      ('binary_rel_arc (oe1-parse-binrelarc model n))
      ('class_box (oe1-parse-classbox model n))
      ('constraint_arc)
      ('gen_rel_arc (oe1-parse-genrelarc model n))
      ('height)
      ('key)
      ('name (if (string-match oe1-params-sheet-regexp
                               (oe1-parse-strval (nth 1 n)))
                 (setq params-sheet t)))
      ('sheet_comment (if params-sheet (oe1-parse-comment model n)))
      ('width)
      ))))

(defun oe1-parse-strval (d)
  (if (stringp d)
      d
    (format "%s" d)))

(defun oe1-parse-type (d)
  (oe1-assert (eq (car d) 'type) "That's not an OMTool type construct!")
  (oe1-if-nonblank (mapconcat 'oe1-parse-ident (cdr d) "")))

;;--------------------------------------------------------- File Names and URLs

(defun oe1-dgmout-dir ()
  (concat oe1-dgms-dir oe1-current-model-name "/"))

(defun oe1-defn-base-fname (term)
  (concat
   (mapconcat (function (lambda (c)
                          (if (= c 32)
                              "-"
                            (char-to-string c))))
              term
              "")
   ".html"))

(defun oe1-defn-fname (term)
  (concat oe1-defn-dir (oe1-defn-base-fname term)))

(defun oe1-defn-url (term)
  (concat oe1-defn-base-url (oe1-defn-base-fname (downcase term))))

(defun oe1-expl-fname (key)
  (concat (oe1-dgmout-dir) key ".html"))

(defun oe1-expl-url (key)
  (concat key ".html"))

(defun oe1-cgi-url-arg-encode (str)
  ;; Borrowed from my webjump.el package.
  (mapconcat '(lambda (c)
                (cond ((= c 32) "+")
                      ((or (and (>= c ?a) (<= c ?z))
                           (and (>= c ?A) (<= c ?Z))
                           (and (>= c ?0) (<= c ?9)))
                       (char-to-string c))
                      (t (upcase (format "%%%02x" c)))))
             str
             ""))

(defun oe1-cgi-url-encode (cgi arg)
  (concat cgi "?" (oe1-cgi-url-arg-encode arg)))

;;---------------------------------------------------------------- Generic HTML

(defun oe1-html-area (url shape coords)
  (concat "<AREA SHAPE=\"" shape "\" COORDS=\"" coords "\" HREF=\"" url
          "\">\n"))

(defun oe1-html-frame (name src scrolling)
  (concat "<FRAME NAME=\"" name "\" SRC=\"" src "\" SCROLLING=\""
          (if scrolling "auto" "no") "\">\n"))

(defun oe1-html-href (url text &optional target)
  (concat "<A HREF=\"" url "\""
          (if target (concat " TARGET=\"" target "\"") "")
          ">" text "</A>"))

(defun oe1-html-ident (text)
  (concat "<B>" text "</B>"))

(defun oe1-html-para (&rest rest)
  (concat "<P>" (apply 'concat rest) "</P>\n"))

;;----------------------------------------------------------- App-Specific HTML

(defun oe1-head-html (title-part key)
  (concat "<!-- Generated by " oe1-program-name " " oe1-version " -->\n"
          "<!-- Software by " oe1-author " -->\n"
          "<!-- Generated At: " (oe1-cur-time-str) " -->\n"
          (if key
              (concat "<!-- Describes Object: " key " -->\n")
            "")
          "<HEAD>\n"
          "<TITLE>"
          oe1-program-name
          (if oe1-current-model
              (concat ": " (oref oe1-current-model diagram-title))
            "")
          (if title-part
              (concat ": " title-part)
            "")
          "</TITLE>\n"
          "<META NAME=\"robots\" CONTENT=\"noindex,nofollow\">"
          "</HEAD>\n"))

(defun oe1-ref-defn (term &optional text)
  (oe1-html-href (oe1-defn-url term) (or text term) oe1-defn-frame))

(defun oe1-ref-defn-plural (term &optional text)
  (oe1-ref-defn term (oe1-pluralize (or text term))))

(defun oe1-ref-desc (key text)
  (oe1-html-href (oe1-expl-url key) text))

(defun oe1-ref-desc-name (o)
  (let ((name (oref o name))
        (key  (oref o key)))
    (oe1-ref-desc key
                  (if name
                      (oe1-html-ident name)
                    (concat "#" key)))))

(defun oe1-boxed-head-html (text)
  (concat

   ;;"<P>"
   ;;"<TABLE BORDERS=\"0\" CELLPADDING=\"0\" CELLSPACING=\"0\" WIDTH=\"100%\">"
   ;;"<TR><TD ALIGN=\"center\" BGCOLOR=\"" oe1-head-bg-color "\">"
   ;;"<B><I><FONT COLOR=\"#ffffff\">"
   ;;(upcase text)
   ;;"</FONT></I></B>"
   ;;"</TD></TR>"
   ;;"</TABLE>"
   ;;"</P>\n"

   "<P ALIGN=\"center\">"
   "<B><I><FONT COLOR=\"red\" FACE=\"Comic Sans MS\" SIZE=\"+1\">"
   (upcase text)
   "</FONT></I></B>"
   "</P>\n"

   ))

;;---------------------------------------------------------- Phrasing Utilities

(defun oe1-an (needs-an &optional cap)
  (if cap
      (if needs-an "An" "A")
    (if needs-an "an" "a")))

(defun oe1-an-and-str (str &optional cap)
  (concat (oe1-an (oe1-needs-an str) cap) " " str))

(defun oe1-and-list (list)
  (let ((length (length list))
        (num 0))
    (ecase length
      (0 nil)
      (1 (car list))
      (2 (concat (nth 0 list) " and " (nth 1 list)))
      (t (mapconcat (function (lambda (n)
                                (setq num (1+ num))
                                (concat (cond ((= num 1) "")
                                              ((= num length) ", and ")
                                              (t ", "))
                                        n)))
                    list
                    "")))))

(defun oe1-name-list (what list say-no link-what)
  (if list
      (concat (oe1-quantity (length list) what link-what)
              " ("
              (oe1-and-list (mapcar 'oe1-ref-desc-name list))
              ")")
    (if say-no
        (oe1-quantity 0 what link-what))))

(defun oe1-needs-an (text)
  ;;!!! make this smarter.
  (string-match "^[aeiouAEIOU]" text))

(defun oe1-quantity (count what &optional link-what)
  (concat (oe1-integer-as-word count)
          " "
          (let ((w (if (= count 1)
                       what
                     (oe1-pluralize what))))
            (if link-what (oe1-ref-defn what w) w))))

(defun oe1-integer-as-word (n)
  (ecase n
    (0 "zero")
    (1 "one")
    (2 "two")
    (3 "three")
    (4 "four")
    (5 "five")
    (6 "six")
    (7 "seven")
    (8 "eight")
    (9 "nine")
    (10 "ten")
    (t (format "%d" n))))

(defun oe1-pluralize (str)
  (cond
   ((string-match "^\\(.*\\)y$" str) (concat (match-string 1 str) "ies"))
   ((string-match "[sS]$" str) (concat str "es"))
   (t (concat str "s"))))

(defun oe1-list-no-nils (list)
  (let (new-list)
    (mapcar (function
             (lambda (n)
               (if n
                   (setq new-list (append new-list (list n))))))
            list)
    new-list))

;;----------------------------------------------------------------- Explanation

(defun oe1-gen-expl-file (o)
  (oe1-gen-file
   (oe1-expl-fname (oref o key))
   (concat "<HTML>\n"
           (oe1-head-html (concat "Explanation: " (oref o key)) (oref o key))
           "<BODY BGCOLOR=\"" oe1-expl-bg-color "\" LINK=\"#000000\" "
           "VLINK=\"#000000\" ALINK=\"#ff0000\">\n"
           (oe1-boxed-head-html "Explanation")
           (oe1-expl o)
           "</BODY>\n"
           "</HTML>\n")))

(defun oe1-gen-expl-files (list)
  (mapcar (function (lambda (n) (oe1-gen-expl-file n)))
          list))

;;----------------------------------------------------------------- Definitions

(defun oe1-defns-gen (defn-list)
  (oe1-defns-gen-defn-index defn-list)
  (mapcar 'oe1-defns-gen-defn defn-list))

(defun oe1-defns-gen-defn (defn)
  (let ((term    (aref defn 0))
        (section (aref defn 1))
        (text    (aref defn 2)))
    (oe1-gen-file
     (oe1-defn-fname term)
     (oe1-defns-defn-html defn))))

(defun oe1-defns-gen-defn-index (defn-list)
  (oe1-gen-file
   oe1-defn-index-fname
   (oe1-defns-defn-index-html defn-list)))

(defun oe1-defns-defn-html (defn)
  (let ((term    (aref defn 0))
        (section (aref defn 1))
        (text    (aref defn 2)))
    (concat
     "<HTML>\n"
     (let ((oe1-current-model nil))
       (oe1-head-html (concat "Definition: " term) nil))
     "<BODY BGCOLOR=\""
     oe1-defn-bg-color
     "\" LINK=\"#000000\" VLINK=\"#000000\" ALINK=\"#ff0000\">\n"
     (oe1-boxed-head-html "Definition")
     "<P>" text "</P>\n"
     (if section
         (concat "<P ALIGN=\"center\"><I>See section <B>"
                 section
                 "</B> of the textbook.</I></P>\n")
       "")
     "</BODY>\n"
     "</HTML>\n")))

(defun oe1-defns-defn-index-html (defn-list)
  (concat
   "<HTML>\n"
   (oe1-head-html "Definitions" nil)
   "<BODY BGCOLOR=\""
   oe1-defn-bg-color
   "\" LINK=\"#000000\" VLINK=\"#000000\" ALINK=\"#ff0000\">\n"
   (oe1-boxed-head-html "Definition")
   "<P><I>Definitions are available for the terms "
   (oe1-and-list
    (mapcar (function (lambda (defn)
                        (oe1-ref-defn (aref defn 0))))
            defn-list))
   ".</I></P>\n"
   "</BODY>\n"))

(defun oe1-defns-gen-PROOF (defn-list)
  (oe1-gen-file
   (concat oe1-dest-dir "defns.html")
   (concat
    "<HTML>\n"
    (let ((oe1-current-model nil))
      (oe1-head-html "Definitions Proof" nil))
    "<BODY>\n"
    (mapconcat (function
                (lambda (defn)
                  (let ((term    (aref defn 0))
                        (section (aref defn 1))
                        (text    (aref defn 2)))
                    (concat
                     "<H2>" term " (" section ")</H2>\n"
                     "<P>" text "</P>\n"))))
               defn-list
               "")
    "</BODY>\n"
    "</HTML>\n")))

(defun oe1-mult-str (mult &optional cap)
  (ecase mult
    ('many     (if cap "Many"     "many"))
    ('one      (if cap "One"      "one"))
    ('optional (if cap "Optional" "optional"))))

(defun oe1-mult-str-defn (m1 m2)
  (let ((name (format "%s-to-%s" m1 m2)))
    (vector name
            nil
            (concat "<B>"
                    (oe1-mult-str m1 t)
                    "-to-"
                    (oe1-mult-str m2 nil)
                    "</B>, when describing the "
                    (oe1-ref-defn "multiplicity")
                    " of an "
                    (oe1-ref-defn "association")
                    " between "
                    (oe1-ref-defn-plural "class")
                    " <I>A</I> and <I>B</I>, means that "
                    (oe1-mult-str-defn-read "A" "B" m2)
                    ", and "
                    (oe1-mult-str-defn-read "B" "A" m1)
                    "."))))

(defun oe1-mult-str-defn-read (n1 n2 n2-mult)
  (concat "for every <I>" n1 "</I> there "
          (ecase n2-mult
            ('many "are zero or more")
            ('one "is exactly one")
            ('optional "is zero or one"))
          " "
          "<I>" n2 "</I>"
          (if (eq n2-mult 'many) "'s" "")))

(defun oe1-mult-str-defns ()
  (let ((mults '(many one optional))
        (list ()))
    (mapcar
     (function
      (lambda (m1)
        (mapcar
         (function
          (lambda (m2)
            (setq list (nconc list (list (oe1-mult-str-defn m1 m2))))))
         mults)))
     mults)
    list))

;;----------------------------------------------------------------- Definitions

(defun oe1-defns ()
  (interactive)
  (oe1-defns-gen
   (nconc
    (oe1-mult-str-defns)
    (list

     (vector "abstract class" "4.2"
             (concat
              "An <B>abstract class</B> is a "
              (oe1-ref-defn "class")
              " which <I>cannot</I> have any direct "
              (oe1-ref-defn-plural "instance")
              ", (although "
              (oe1-ref-defn-plural "subclass")
              " of it which are "
              (oe1-ref-defn-plural "concrete class")
              " <I>can</I> have instances)."))

     (vector "abstract method" "4.2"
             (concat
              "An <B>abstract method</B> is a &quot;place-holder&quot; "
              (oe1-ref-defn "method")
              " in an "
              (oe1-ref-defn "abstract class")
              " which must be defined in a "
              (oe1-ref-defn "subclass")
              "."))

     (vector "aggregation association" "3.3.6"
             (concat
              "An <B>aggregation association</B> is a special kind of "
              (oe1-ref-defn "association")
              ", in which a &quot;part-whole&quot; relationship exists "
              "between "
              (oe1-ref-defn-plural "object")
              ". The diamond notation indicates the &quot;whole&quot; end."))

     (vector "association" "3.2"
             (concat
              "An <B>association</B> is a relationship between "
              (oe1-ref-defn-plural "class")
              ". Instances of <B>associations</B> are called "
              (oe1-ref-defn-plural "link")
              "."))

     (vector "association as class" "3.3.2"
             (concat
              "An <B>association as class</B> is a special kind of "
              (oe1-ref-defn "association")
              ", in which the association itself can be thought of as a "
              (oe1-ref-defn "class")
              " with its own "
              (oe1-ref-defn-plural "attribute")
              ", "
              (oe1-ref-defn-plural "method")
              ", and associations with other classes."))

     (vector "attribute" "3.1.4"
             (concat
              "An <B>attribute</B> is a data value, usually of some "
              "&quot;primitive&quot; type such as boolean, integer, or "
              "string. There are "
              (oe1-ref-defn-plural "instance attribute")
              " and "
              (oe1-ref-defn-plural "class attribute")
              "."))

     (vector "class" "3.1.2"
             (concat
              "A <B>class</B> is a type with "
              (oe1-ref-defn-plural "attribute")
              " and "
              (oe1-ref-defn-plural "method")
              " methods that apply to "
              (oe1-ref-defn-plural "instance")
              " of the <B>class</B> and sometimes to the <B>class</B> itself. "
              "Instances are called "
              (oe1-ref-defn-plural "object")
              "."))

     (vector "class attribute" "4.5.2"
             (concat
              "A <B>class attribute</B> is an "
              (oe1-ref-defn "attribute")
              " that is shared by all "
              (oe1-ref-defn-plural "instance")
              " of a "
              (oe1-ref-defn "class")
              "."))

     (vector "class method" "4.5.2"
             (concat
              "A <B>class method</B> is a "
              (oe1-ref-defn "method")
              " that operates on a "
              (oe1-ref-defn "class")
              " itself, as opposed to an "
              (oe1-ref-defn "instance method")
              ", which operates on "
              (oe1-ref-defn-plural "instance")
              " of the class."))

     (vector "concrete class" "4.2"
             (concat
              "A <B>concrete class</B> is a "
              (oe1-ref-defn "class")
              " which can have direct "
              (oe1-ref-defn-plural "instance")
              ", as opposed to an "
              (oe1-ref-defn "abstract class")
              ", which cannot have direct instances."))

     (vector "constructor" nil
             (concat
              "A <B>constructor</B> is a special kind of "
              (oe1-ref-defn "class method")
              " that is used to create and initialize "
              (oe1-ref-defn-plural "instance")
              " of a "
              (oe1-ref-defn "class")
              "."))

     (vector "generalization association" "3.4"
             (concat
              "A <B>generalization association</B> shows a "
              "&quot;kind-of&quot; relationship between a "
              (oe1-ref-defn "superclass")
              " and its "
              (oe1-ref-defn-plural "subclass")
              ". Subclasses inherit the "
              (oe1-ref-defn-plural "attribute")
              ", "
              (oe1-ref-defn-plural "method")
              ", and "
              (oe1-ref-defn "associations")
              " of the superclass, and "
              (oe1-ref-defn-plural "instance")
              " of the subclass can be treated as instances of the "
              "superclass."))

     (vector "instance" nil
             (concat
              "An <B>instance</B> of a "
              (oe1-ref-defn "class")
              " is called an "
              (oe1-ref-defn "object")
              ", and an <B>instance</B> of an "
              (oe1-ref-defn "association")
              " is called a "
              (oe1-ref-defn "link")
              "."))

     (vector "instance attribute" "3.1.4"
             (concat
              "An <B>instance attribute</B> is an "
              (oe1-ref-defn "attribute")
              " that each "
              (oe1-ref-defn "instance")
              " of a "
              (oe1-ref-defn "class")
              " gets its own copy of."))

     (vector "instance method" "3.1.5"
             (concat
              "An <B>instance method</B> is a "
              (oe1-ref-defn "method")
              " that operates on an  "
              (oe1-ref-defn "instance")
              " of a "
              (oe1-ref-defn "class")
              ", as opposed to a "
              (oe1-ref-defn "class method")
              ", which operates on the class itself."))

     (vector "link" nil
             (concat
              "A <B>link</B> is an "
              (oe1-ref-defn "instance")
              " of an "
              (oe1-ref-defn "association")
              ", just as an "
              (oe1-ref-defn "object")
              " is an instance of a "
              (oe1-ref-defn "class")
              "."))

     (vector "member" nil
             (concat
              "A <B>member</B> of a class is an "
              (oe1-ref-defn "attribute")
              " or "
              (oe1-ref-defn "method")
              "."))

     (vector "method" "3.1.5"
             (concat
              "A <B>method</B> implements an operation that may performed on "
              "an "
              (oe1-ref-defn "object")
              " or (much less commonly) a "
              (oe1-ref-defn "class")
              ". The former kind are "
              (oe1-ref-defn-plural "instance method")
              " and the latter are "
              (oe1-ref-defn-plural "class method")
              "."))

     (vector "multiplicity" "3.2.2"
             (concat
              "<B>Multiplicity</B> here refers to the number of "
              (oe1-ref-defn-plural "object")
              " that can participate in an "
              (oe1-ref-defn "association")
              " with another object.  Possible kinds include "
              "&quot;exactly one&quot; (1), "
              "&quot;optional&quot; (0 or 1), and "
              "&quot;many&quot; (0 or more)."))

     (vector "object" "3.1.1"
             (concat
              "An <B>object</B> is an "
              (oe1-ref-defn "instance")
              " of a "
              (oe1-ref-defn "class")
              "."))

     (vector "qualifier" "3.3.5"
             (concat
              "A <B>qualifier</B> qualifies the &quot;many&quot; "
              (oe1-ref-defn "multiplicity")
              " of a "
              (oe1-ref-defn "class")
              "' participation in an "
              (oe1-ref-defn "association")
              " with a key that uniquely identifies each of the many "
              (oe1-ref-defn-plural "object")
              "."))

     (vector "role name" "3.3.3"
             (concat
              "A <B>role name</B> identifies the &quot;role&quot; the class "
              "plays in an "
              (oe1-ref-defn "association")
              ".  Association names are usually redundant if "
              "<B>role names</B> are provided."))

     (vector "simple association" "3.2.1"
             (concat
              "A <B>simple association</B> is an "
              (oe1-ref-defn "association")
              " that is not a special kind such as "
              (oe1-ref-defn "aggregation association" "aggregation")
              ", "
              (oe1-ref-defn "generalization association" "generalization")
              ", or "
              (oe1-ref-defn "association as class")
              "."))

     (vector "subclass" "3.4.1"
             (concat
              "A <B>subclass</B> in a "
              (oe1-ref-defn "generalization association")
              "."))

     (vector "superclass" "3.4.1"
             (concat
              "A <B>superclass</B> in a "
              (oe1-ref-defn "generalization association")
              "."))

     ))))

;;------------------------------------------------------------------- Front-End

(defun oe1-buffer-rawdata ()
  (oe1-log-activity
   "Reading data"
   (save-excursion
     (goto-char (point-min))
     (or (re-search-forward "^(omt_module\\>" nil t)
         (oe1-error "No \"omt_module\" found in buffer."))
     (goto-char (match-beginning 0))
     (read (current-buffer)))))

(defun oe1 (model-name)
  (interactive "sOE1 model name: ")
  (let* ((oe1-current-model-name model-name))
    (find-file (concat oe1-models-dir oe1-current-model-name ".omt"))
    (oe1-log-begin)
    (save-excursion
      (let ((model (oe1-parse (oe1-buffer-rawdata)))
            (start-time (current-time)))
        (oset model source-name (or (buffer-file-name) (buffer-name)))
        (oset model start-time start-time)
        ;;
        ;; Prepare target directory.
        (let ((dir (oe1-dgmout-dir)))
          (if (file-exists-p dir)
              (progn
                (oe1-log-info "Cleaning out \"%s\"." dir)
                (mapcar (function (lambda (fname)
                                    (or (string= fname ".")
                                        (string= fname "..")
                                        (delete-file (concat dir fname)))))
                        (directory-files (oe1-dgmout-dir) nil nil t)))
            (oe1-log-info "Creating \"%s\"." dir)
            (make-directory dir))
          (set-file-modes dir oe1-file-modes-rwx-rx-rx))
        ;;
        (let ((oe1-current-model model))
          (oe1-crunch model)
          (if (oref model bad)
              (oe1-log-warning "Not doing OE1 for model.")
            ;;
            (oe1-gen-diagram-html-file model)
            (oe1-gen-explanation-html-file model)
            (oe1-gen-heading-html-file model)
            (oe1-gen-index-html-file model)
            ;;
            (oe1-gen-expl-files (oref model genrels))
            (mapcar (function
                     (lambda (n)
                       (oe1-gen-expl-file n)
                       (oe1-gen-expl-files (oref n constructors))
                       (oe1-gen-expl-files (oref n class-attribs))
                       (oe1-gen-expl-files (oref n instance-attribs))
                       (oe1-gen-expl-files (oref n class-methods))
                       (oe1-gen-expl-files (oref n instance-methods))))
                    (oref model classes))
            (oe1-gen-expl-files (oref model binassocs))
            ;;
            ;; Copy over the diagram GIF file.
            (let ((src-fname (concat oe1-models-dir oe1-current-model-name
                                     ".gif"))
                  (new-fname (concat (oe1-dgmout-dir) "diagram.gif")))
              (if (file-exists-p src-fname)
                  (progn
                    (oe1-log-info "Copying diagram GIF file.")
                    (copy-file src-fname new-fname)
                    (set-file-modes new-fname oe1-file-modes-rw-r-r))
                (oe1-log-warning "File \"%s\" doesn't exist." src-fname)))
            ;;
            ))))
    (oe1-log-end)))

;;-----------------------------------------------------------------------------

(provide 'oe1)

;;EOF