cl-bcgreek/bcgreek/bcgreek.lisp

;;;; bcgreek.lisp

(in-package #:bcgreek)

(eval-when (:compile-toplevel :execute :load-toplevel)
  (defparameter *decoders* '(decode-misc decode-simple-small decode-small decode-sigma decode-capital decode-catchall)))

(defmacro define-bcgreek-streams ()
  `(defun bcgreek-decode-stream (input-stream output-stream &key (auto-final-sigma t) (j-sigma t) (case :ignore))
     (check-type case (member :ignore :upper :lower))
     (with-bc-setup
       (loop while (or ,@(mapcar #'list *decoders*))))))

(defmacro with-bc-setup (&body body)
  `(let ((*standard-input* input-stream)
         (*standard-output* output-stream)
         (*auto-final-sigma* auto-final-sigma)
         (*j-sigma* j-sigma)
         (*case* case))
     (with-mask
       (with-capital-buffer
         ,@body))))

;;;;;;

(defmacro define-char-macros ()
  (let ((last-read-char-v (gensym "LAST-READ-CHAR-")))
    `(progn

       (defmacro get-char ()
         `(setf ,',last-read-char-v (read-char nil nil)))

       (defmacro unread ()
         `(when ,',last-read-char-v
            (unread-char ,',last-read-char-v)
            (setf ,',last-read-char-v nil)))

       (defmacro with-get-char (&body body)
         `(let (,',last-read-char-v)
            ,@body))
       
       )))

(define-char-macros)

;;;;;;;

(defmacro save-char (result)
  `(write-char ,result))

(defmacro save-string (result)
  `(write-string ,result))

(defmacro define-decoder (name (&key return-type) &body body)
  `(defmacro ,name ()
     (let ((result-v (gensym "RESULT-")))
       `(with-get-char
          (let ((,result-v (progn
                             ,@',body)))
            (if ,result-v
                (,',(if (eq return-type 'string) 'save-string 'save-char) ,result-v)
                (unread)))))))

(define-decoder decode-catchall (:return-type character)
  (get-char))

(defmacro get-normalized-char ()
  '(let ((char (get-char)))
     (if (or (null char)
             (and (eq *case* :lower) (upper-case-p char))
             (and (eq *case* :upper) (lower-case-p char)))
         nil
         (char-downcase char))))

(define-decoder decode-simple-small (:return-type char)
  (simple-small-to-greek (get-normalized-char)))

(define-decoder decode-s-sigma (:return-type char)
  (when (eql (get-normalized-char) #\s)
    (let ((c (get-normalized-char)))
      (cond ((null c) (if *auto-final-sigma*
                           +final-sigma+
                           +medial-sigma+))
            ((char= c #\1) +medial-sigma+)
            ((char= c #\2) +final-sigma+)
            ((char= c #\3) +lunate-sigma+)
            (t
             (unread)
             (if (and *auto-final-sigma* (or (find c (bc-letter-base))
                                             (and *j-sigma* (char= c #\j))))
                 +medial-sigma+
                 +final-sigma+))))))

(define-decoder decode-j-sigma (:return-type character)
  (when *j-sigma*
    (when (eql (get-normalized-char) #\j)
      +final-sigma+)))

(defmacro decode-sigma ()
  '(or (decode-s-sigma)
       (decode-j-sigma)))

(define-decoder decode-small ()
  (prog1
    (let ((base-char (get-normalized-char)))
      (when (and base-char
                 (not (char= base-char #\s))
                 (find base-char (bc-letter-base)))
        (reset-mask)
        (let (decoded)
          (loop for c = base-char then (get-char)
                do
                (add-to-mask c)
                (let ((current-decoded (decode-mask)))
                  (when (null current-decoded)
                    (return))
                  (setf decoded current-decoded)))
          decoded)))
    (unread)))

(defmacro define-capital-buffer-macros ()
  (let ((capital-buffer-v (gensym "CAPITAL-BUFFER-")))
    `(progn

       (defmacro with-capital-buffer (&body body)
         `(let ((,',capital-buffer-v (make-array (capital-buffer-length) :element-type 'base-char :fill-pointer 1)))
            ,@body))

       (defmacro reset-capital-buffer ()
         `(setf (fill-pointer ,',capital-buffer-v) 1
                (char ,',capital-buffer-v 0) +capital-mark+))

       (defmacro add-to-capital-buffer (char)
         `(vector-push-extend ,char ,',capital-buffer-v))

       (defmacro capital-buffer-string ()
         ',capital-buffer-v))))

(define-capital-buffer-macros)

(define-decoder decode-capital (:return-type string)
  (let ((c (get-char)))
    (when (eql c +capital-mark+)
      (reset-capital-buffer)
      (reset-mask)
      (add-to-mask +capital-mark+)
      (let ((result nil))
        (loop
          (let ((c (get-char)))
            (add-to-mask c)
            (let ((decoded (decode-mask)))
              (case decoded
                ((t) (add-to-capital-buffer c))
                ((nil) (unread) (return))
                (otherwise (setf result decoded) (return))))))
        (or result (capital-buffer-string))))))

(define-decoder decode-misc (:return-type char)
  (misc-bc-to-greek (get-char)))

(define-bcgreek-streams)

(defun bcgreek-decode (string &key (start 0) end (auto-final-sigma t) (j-sigma t) (case :ignore))
  (check-type case (member :ignore :upper :lower))
  (with-input-from-string (in string :start start :end end)
    (with-output-to-string (out)
      (bcgreek-decode-stream in out :auto-final-sigma auto-final-sigma :j-sigma j-sigma :case case))))