japonca/okur.lisp

;;; **************************************************
;;;; Kelimeler dosyasındaki tanımlı kelimeleri okuma *
;;; **************************************************
(in-package :japonca)

(defclass okur ()
  ((dosya :accessor dosya :initarg :dosya)
   (metin :accessor metin)
   (durum :accessor durum :initform :baş)
   (i :accessor i :initform 0)
   (kelimeler :accessor kelimeler
              :initform (make-array 10 :adjustable t :fill-pointer 0))))

(defmethod metni-yükle ((okur okur))
  (setf (metin okur)
        (dosya-metni-oku (dosya okur))))

(defmethod metin-bitti? ((okur okur))
  (eq :son (durum okur)))

(defmethod ++kar ((okur okur))
  (incf (i okur))
  (if (array-in-bounds-p (metin okur) (i okur))
      (i okur)
      (setf (durum okur) :son)))

(defmethod kar++ ((okur okur))
  (let ((i (i okur)))
    (++kar okur)
    i))

(defmethod kar-oku ((okur okur))
  (unless (metin-bitti? okur)
    (char (metin okur) (kar++ okur))))

(defmethod kar-bak ((okur okur))
  (char (metin okur) (i okur)))

(defmethod boşluğa-kadar ((okur okur))
  (loop :until (or (metin-bitti? okur)
                   (char= #\Space (kar-bak okur)))
        :do (++kar okur)))

(defmethod boşluk-geç ((okur okur))
  (loop :until (metin-bitti? okur)
        :do (let ((kar (kar-bak okur)))
              (if (char= #\Space kar)
                  (kar-oku okur)
                  (return)))))

(defmethod yeni-satıra-geç ((okur okur))
  (loop :until (metin-bitti? okur)
        :do (let ((kar (kar-oku okur)))
              (when (char= #\Newline kar)
                (return)))))
;; (setf (durum okur) :yeni-satır)

;; (defparameter +öbek-son-ch+ '(#\Space #\Newline #\; #\, #\、))
(defmethod sonraki-öbek ((okur okur) son-kar)
  (let ((baş (i okur)))
    (loop :until (metin-bitti? okur)
          :do (let ((kar (kar-bak okur)))
                (if (find kar son-kar :test #'char=)
                    (loop-finish)
                    (++kar okur)))
          :finally (loop :while (char= #\Space
                                       (char (metin okur)
                                             (- (i okur) 1)))
                         :do (decf (i okur))))
    (make-array (- (i okur) baş)
                :element-type 'character
                :displaced-to (metin okur)
                :displaced-index-offset baş)))

(defmethod kanji-oku ((okur okur))
  (let ((öbek (sonraki-öbek okur '(#\Space))))
    (unless (string= "-" öbek)
      öbek)))

(defmethod kana-oku ((okur okur))
  (let ((öbek (sonraki-öbek okur '(#\Space #\、))))
    (boşluk-geç okur)
    (cons öbek
          (when (char= #\、 (kar-bak okur))
            (kar-oku okur)
            (boşluk-geç okur)
            (kana-oku okur)))))

(defmethod anlam-oku ((okur okur))
  (let ((öbek (sonraki-öbek okur '(#\, #\Newline #\; #\|))))
    (boşluk-geç okur)
    (cons öbek
          (when (and (not (metin-bitti? okur))
                     (char= #\, (kar-bak okur)))
            (kar-oku okur)
            (boşluk-geç okur)
            (anlam-oku okur)))))

(defmethod kelime-oku ((okur okur))
  (let (kanji kana anlam grup altgrup)
    (setf kanji (kanji-oku okur))
    (boşluk-geç okur)
    (setf kana (kana-oku okur))
    (setf anlam (anlam-oku okur))
    (when (and (not (metin-bitti? okur))
               (char= #\| (kar-bak okur)))
      ;; (yeni-satıra-geç okur)
        (kar-oku okur)
        (boşluk-geç okur)
        (setf grup (sonraki-öbek okur '(#\Newline #\Space #\; #\,)))
        (cond ((or (string= grup "fiil")
                   (string= grup "sıfat"))
               (boşluk-geç okur)
               (setf altgrup (sonraki-öbek okur '(#\Newline #\Space #\;))))
              ((char= #\, (kar-bak okur))
               (kar-oku okur)
               (boşluk-geç okur)
               (push (sonraki-öbek okur '(#\Newline #\Space #\;)) grup))))
    (make-instance 'kelime :kanji kanji :kana kana :anlam anlam
                           :grup grup :altgrup altgrup)))

(defmethod işle ((okur okur))
  (unless (eq :baş (durum okur))
    (error "Okur zaten işlenmiş"))
  (loop :until (metin-bitti? okur)
        :do (case (kar-bak okur)
              (#\; (yeni-satıra-geç okur))
              (#\Newline (yeni-satıra-geç okur))
              (#\Space (boşluk-geç okur))
              (otherwise (vector-push-extend (kelime-oku okur)
                                             (kelimeler okur)))))
  (kelimeler okur))

(defmacro okurla ((isim dosya-ismi) &body beden)
  `(let ((,isim (make-instance 'okur :dosya ,dosya-ismi)))
     ,@beden))

;; (defparameter *okur* nil)

;; (defun test-okuru-yap ()
;;   (setf *okur*
;;         (make-instance 'okur :dosya "/home/riton/projects/japonca/örnek.txt"))
;;   (metni-yükle *okur*))



;; (buffer :accessor buffer :initform (make-array 1028 :element-type 'character
;;                                                :fill-pointer 0))

;; (defmethod yeni-satır ((okur okur))
;;   (let* ((yeni-poz (position #\Newline (metin okur) :start (i okur)))
;;          (fark (- yeni-poz (i okur))))
;;     (setf (fill-pointer (buffer okur)) fark)
;;     (replace (buffer okur) (metin okur)
;;              :start1 0 :end1 fark
;;              :start2 (i okur) :end2 yeni-poz)
;;     (setf (i okur) (+ yeni-poz 1))
;;     (buffer okur)))