1 files changed, 158 insertions, 0 deletions
diff --git a/okur.lisp b/okur.lisp
new file mode 100644
index 0000000..3a76f05
--- /dev/null
+++ b/okur.lisp
@@ -0,0 +1,158 @@
+;;; **************************************************
+;;;; 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)))