;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: conversions.lsp
;;;;    System: dte
;;;;   Version: 2.0
;;;;    Author: mostek
;;;;   Created: February 16, 1999 11:51:26
;;;;   Purpose: 
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Sunday, November 5, 2000 at 22:14:02 by forbus
;;;; ---------------------------------------------------------------------------

;;;;****** NOT WORKING CODE.  FOR REFERENCE ONLY

(in-package :common-lisp)

(defvar *look-by-case-sensitive* (make-hash-table :test #'eq))
(defvar *look-by-case-insensitive* (make-hash-table :test #'eq))

(defvar *gather-mts* nil)

(defun read-from-string-w-mts (str)
   (let ((*gather-mts* t))
      (read-from-string str)))

(defun reset-cyc-lookups ()
   (clrhash *look-by-case-sensitive*)
   (clrhash *look-by-case-insensitive*))

(defun case-sensitive-from-insensitive (symb)
   (gethash symb *look-by-case-insensitive*))

(defun case-insensitive-from-sensitive (symb)
   (gethash symb *look-by-case-sensitive*))

(defun allow-cyc-read-macros ()
   
   (set-dispatch-macro-character #\# #\$
    #'(lambda (stream char1 char2)
        (declare (ignore char1 char2))
        (let ((*readtable* (copy-readtable))
              (*package* (find-package :cl-user))
              (return-symb nil)
              (symb nil))
           (setf (readtable-case *readtable*) :preserve)
        (setq symb (read stream t nil t))
           ;;;         (format t "Cyc = ~A~%" symb)
           (unless (setq return-symb (gethash symb *look-by-case-sensitive*))
           (setq return-symb (add-dashes (symbol-name symb)))
              (setf (gethash symb *look-by-case-sensitive*) return-symb)
              (setf (gethash return-symb *look-by-case-insensitive*) symb))
           return-symb)))
   
   (set-dispatch-macro-character #\# #\< 
    ;; input looks like:  #<(#$GroupFn #$IntelligentAgent)> or
    ;; #<AS:<(#$victim #$Y1Stage3-SAAttackOnIran #$Iran)>:#$BaseKB> which I don't understand, or
    ;; #<AS:(#$maleficiary #$USStrikeAgainstIran-1987 #$Iran):#$BaseKB>
    ;; read what's in the parenthesis and then do a test for the close >
    ;; Also peek to see if the 
    #'(lambda (stream char1 char2)
        (declare (ignore char1 char2))
        (let ((result (if (eq (peek-char nil stream nil :eol t) #\a)
                         (read-with-as-block stream *gather-mts*)
                         (read stream))))
           (if (eq (peek-char nil stream nil :eol t) #\>)
              (read-char stream t nil t)
              (error result "Impoperly formatted #<...>"))
           result))))
   
(defvar *as-depth* 0)

(defun read-with-as-block (stream gather-mts?)
   ;; read the AS: and then do the test for < or ( and then read the data then read/ignore the MT
   (incf *as-depth*)
   (read-char stream t nil t)
   (read-char stream t nil t)
   (read-char stream t nil t)
   (let ((result (if (eq (peek-char nil stream nil :eol t) #\<)
                      (read-with-<-block stream)
                      (read stream nil :eof))))
      (cond ((eq (peek-char nil stream nil :eol t) #\:)
             (read-char stream t nil t)
             (if (and gather-mts? (= *as-depth* 1))
                (setq result (cons result (read-mt-from-string stream)))
                (read-mt-from-string stream)))
            (t
             (write "Impoperly formatted AS: within #<...>" *error-output*) 
;;;              (error result "Impoperly formatted AS: within #<...>")
             ))
      (decf *as-depth*)
      result))

(defun read-mt-from-string (stream)
   ;; gather the string until we see a >, then do a read from string
   (do ((cur-char nil (peek-char nil stream nil :eol t))
        (out-string (make-string-output-stream)))
       ((or (eq cur-char :eol)
            (eq cur-char #\>))
        (read-from-string (get-output-stream-string out-string)))
      (write-char (read-char stream t nil t) out-string)))
    
(defun read-with-<-block (stream)
   ;; read the < and then read the data and the ignore the end >
   (read-char stream t nil t)
   (let ((result (read stream)))
      (if (eq (peek-char nil stream nil :eol t) #\>)
           (read-char stream t nil t)
           (error result "Impoperly formatted <...> within #<...>"))
      result))

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

;; Note - two things which don't translate well back to Cyc: 
;; 1) predicates - we always capitalize the first char
;;    e.g.: #$arg1Isa -> arg1-isa -> #$Arg1Isa
;; 2) Multiple upper case in a row - we just upcase the first
;;    e.g.: #$HPKB-User -> hpkb--user -> Hpkb-User

(defun convert-to-cyc (expr)
   ;; takes an arbitrary expression, converts all symbols to cyc-notation, returns the
   ;; converted expression
   (cond ((null expr) nil)
         ((symbolp expr) (transform-symbol-to-cyc expr))
         ((atom expr) expr)
         (t
          (cons (convert-to-cyc (first expr))
            (convert-to-cyc (rest expr))))))

(defun transform-symbol-to-cyc (symb)
   ;; step through the symbol, captilizing everything after a dash (and removing the dash)
   ;;
   (remove-dashes (symbol-name symb)))


(defun remove-dashes (str)
   "Remove the dashes from a case-insensitive form and tries to set the capitalization straight"
   (let ((len (length str))
         (*readtable* (copy-readtable))
         (*package* (find-package :cl-user)))
      (setf (readtable-case *readtable*) :preserve)
      (if (< len 2)
         #+cyc-pound-dollar-sign-ready
         (read-from-string (format nil "#$~A" str) *package*)
         #-cyc-pound-dollar-sign-ready
         (read-from-string (format nil "~A" str) *package*)
         (do ((pos 2 (1+ pos))
              #+cyc-pound-dollar-sign-ready
              (chars (list (char str 0) #\$ #\#))
              #-cyc-pound-dollar-sign-ready
              (chars (list (char str 0)))
              (latest-char (char str 1) (unless (= pos len) (char str pos)))
              (prior-char (char str 0) latest-char))
             ((> pos len)
              (read-from-string (list-to-string (reverse chars)))
              )
            (cond ((null prior-char) nil)
                  ((and (eq prior-char #\-)
                        (eq latest-char #\-))
                   (push #\- chars))
                  ((eq latest-char #\-) nil)
                  ((and (eq prior-char #\-)
                        (digit-char-p latest-char))
                   (push #\- chars)
                   (push latest-char chars))
                  ((eq prior-char #\-)
                   (push latest-char chars))
                  (t
                   (push (char-downcase latest-char) chars)))))))

(defun remove-dashes-plain-case (str)
   "Removes the dashes from a case-insensitive form but leaves the capitalization alone"
   (let ((len (length str)))
      (if (< len 2)
         (read-from-string str)
         (do ((pos 2 (1+ pos))
              (chars (list (char str 0)))
              (latest-char (char str 1) (unless (= pos len) (char str pos)))
              (prior-char (char str 0) latest-char))
             ((> pos len)
              (read-from-string (list-to-string (reverse chars)))
              )
            (cond ((null prior-char) nil)
                  ((and (eq prior-char #\-)
                        (eq latest-char #\-))
                   (push #\- chars))
                  ((eq latest-char #\-) nil)
                  ((and (eq prior-char #\-)
                        (digit-char-p latest-char))
                   (push #\- chars)
                   (push latest-char chars))
                  ((eq prior-char #\-)
                   (push latest-char chars))
                  (t
                   (push latest-char chars)))))))

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

(defparameter *cyc-analogy-name-functions* '(cl-user::|analogymatchfn|
                                             cl-user::|analogymappingfn|
                                             cl-user::|analogycorrespondencefn|
                                             cl-user::|analogyinferencefn|))

(defun convert-from-cyc (expr)
   ;; takes an arbitrary cyc expression, converts all symbols to case-insensitive notation, returns the
   ;; converted expression
   ;;
   ;; note - I added the test to unpack the analogy functions
   (cond ((null expr) nil)
         ((symbolp expr) (transform-symbol-from-cyc expr))
         ((atom expr) expr)
         ((eq (first expr) 'cl-user::isa)
          (convert-isa expr))
         ((member (first expr) *cyc-analogy-name-functions*)
          (intern (second expr) :cl-user))
         (t
          (cons (convert-from-cyc (first expr))
            (convert-from-cyc (rest expr))))))

(defun transform-symbol-from-cyc (symb)
   ;; step through the symbol, captilizing everything after a dash (and removing the dash)
   ;;
   #+cyc-pound-dollar-sign-ready
   (add-dashes (subseq (symbol-name symb) 2))
   #-cyc-pound-dollar-sign-ready
   (add-dashes (symbol-name symb))
   )

(defun convert-isa (expr)
   ;; change (isa <instance> <collection>) to (<collection> <instance>)
   (list (convert-from-cyc (third expr))
     (convert-from-cyc (second expr))))

(defun add-dashes (str)
   (let ((len (length str))
         (*package* (find-package :cl-user)))
      (if (< len 2)
         (read-from-string (string-upcase str) :cl-user)
         (do ((pos 2 (1+ pos))
              (chars nil)
              (latest-char (char str 1) (unless (= pos len) (char str pos)))
              (prior-char (char str 0) latest-char))
          ((> pos len)
           (read-from-string (list-to-string (reverse (cons (char-upcase prior-char) chars)))))
        (cond ((null prior-char) nil)
              ((and (upper-case-p latest-char)
                    (or (lower-case-p prior-char)
                        (digit-char-p prior-char)
                        (eq prior-char #\-)))
               (push (char-upcase prior-char) chars)
               (push #\- chars))
              (t
               (push (char-upcase prior-char) chars)))))))

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

(defun list-to-string (lst-of-chars)
   (do ((result (make-string (length lst-of-chars)))
        (i 0 (1+ i))
        (char-ptr lst-of-chars (rest char-ptr)))
       ((null char-ptr) result)
      (setf (aref result i) (first char-ptr))))



;;;; ---------------------------------------------------------------------------
;;; END OF CODE