wordcut.lisp

(ql:quickload 'str)

(defpackage #:cl-wordcut
  (:use #:cl)
  (:import-from #:str :join))

(in-package #:cl-wordcut)

(declaim (optimize (speed 3) (debug 0) (safety 0)))
(defconstant +default-dix-ptr-size+ 1024)

(defstruct node-key
  (row-no 0 :type integer)
  (offset 0 :type integer)
  (ch #\0 :type character))

(defstruct node-ptr
  (row-no 0 :type integer)
  (is-final nil :type boolean)
  payload)

(defun init-prefix-tree ()
  (make-hash-table :test #'equalp))

(defun make-prefix-tree (sorted-words-with-payload)
  (let ((prefix-tree (init-prefix-tree))
	 (i 0))
    (loop for word-payload in sorted-words-with-payload
	  do
	     (destructuring-bind (word payload)
		 word-payload			       
	       (let* ((row-no 0)
		      (ch-list (coerce word 'list))
		      (ch-len (length ch-list))
		      (j 0))
		 (loop for ch in ch-list
		       do
			  (let ((node-key (make-node-key :row-no row-no :offset j :ch ch)))
			    (let ((ex-node-ptr (gethash node-key prefix-tree)))
			      (if ex-node-ptr
				  (setq row-no (node-ptr-row-no ex-node-ptr))
				  (let* ((is-final (= (+ j 1) ch-len))
					 (node-ptr (make-node-ptr :row-no i :is-final is-final :payload (when is-final payload))))
				    (setf (gethash node-key prefix-tree) node-ptr)
				    (setq row-no i))))
			    (incf j)))))
	     (incf i))
    prefix-tree))

(defun lookup (prefix-tree row-no offset ch)
  (gethash (make-node-key :row-no row-no :offset offset :ch ch)
	   prefix-tree))

(defconstant +unk+ 1)
(defconstant +dict+ 2)
(defconstant +init+ 3)
(defconstant +latin+ 4)
(defconstant +punc+ 5)

(defstruct link
  (p-idx 0 :type integer)
  (w 0 :type integer)
  (unk 0 :type integer)
  (kind 0 :type integer))

(defun betterp (l r)
  (or (< (link-unk l)
	 (link-unk r))
      (< (link-w l)
	 (link-w r))))

(defconstant +waiting+ 1)
(defconstant +activated+ 2)
(defconstant +completed+ 3)

(defgeneric update (transducer ch i ch-vec))

(defclass latin-transducer ()
  ((s :accessor s :initform 0 :type integer)
   (e :accessor e :initform 0 :type integer)
   (state :accessor state :initform +waiting+ :type integer)
   (link-kind :accessor transducer-link-kind :initform +latin+)))

(defconstant +cap-a-code+ (char-code #\A))
(defconstant +cap-z-code+ (char-code #\Z))
(defconstant +a-code+ (char-code #\a))
(defconstant +z-code+ (char-code #\z))

(defun latin-p (ch)
  (let ((code (char-code ch)))
    (or (and (>= code +cap-a-code+)
	     (<= code +cap-z-code+))
	(and (>= code +a-code+)
	     (<= code +z-code+)))))

(defmethod update ((transducer latin-transducer) (ch character) (i integer) (ch-vec vector))
  (if (eq +waiting+ (state transducer))
      (if (latin-p ch)
	  (progn
	    (setf (slot-value transducer 's) i)
	    (setf (slot-value transducer 'state) +activated+)
	    (when (or (eq (length ch-vec) (+ i 1))
		    (not (latin-p (aref ch-vec (+ i 1)))))
	      (progn
		(setf (slot-value transducer 'e) (+ i 1))
		(setf (slot-value transducer 'state) +completed+)))))
      (if (latin-p ch)
	  (when (or (eq (length ch-vec) (+ i 1))
		    (not (latin-p (aref ch-vec (+ i 1)))))
	      (progn
		(setf (slot-value transducer 'e) (+ i 1))
		(setf (slot-value transducer 'state) +completed+)))
	  (setf (slot-value transducer 'state) +waiting+))))

;;(defparameter *l* (make-instance 'latin-transducer))
;;(update *l*  #\a 0 #(#\a))
;;(e *l*)

(defclass punc-transducer ()
  ((s :accessor s :initform 0 :type integer)
   (e :accessor e :initform 0 :type integer)
   (state :accessor state :initform +waiting+ :type integer)
   (link-kind :accessor transducer-link-kind :initform +punc+)))

(defun punc-p (ch)
  (eq #\space ch))

(defmethod update ((transducer punc-transducer) (ch character) (i integer) (ch-vec vector))
  (if (eq +waiting+ (state transducer))
      (if (punc-p ch)
	  (progn
	    (setf (slot-value transducer 's) i)
	    (setf (slot-value transducer 'state) +activated+)
	    (when (or (eq (length ch-vec) (+ i 1))
		    (not (punc-p (aref ch-vec (+ i 1)))))
	      (progn
		(setf (slot-value transducer 'e) (+ i 1))
		(setf (slot-value transducer 'state) +completed+)))))
      (if (punc-p ch)
	  (when (or (eq (length ch-vec) (+ i 1))
		    (not (punc-p (aref ch-vec (+ i 1)))))
	      (progn
		(setf (slot-value transducer 'e) (+ i 1))
		(setf (slot-value transducer 'state) +completed+)))
	  (setf (slot-value transducer 'state) +waiting+))))

(defstruct dix-ptr
  (s 0 :type integer)
  (row-no 0 :type integer)
  (is-final t :type boolean))

(defun build-path (dix s)
  (let* ((left-boundary 0)
	 (s-len (length s))
	 (ch-list (coerce s 'list))
	 (ch-vec (make-array s-len :element-type 'character :initial-contents ch-list))
	 (path (make-array (+ s-len 1)))
	 (dix-ptrs (make-array +default-dix-ptr-size+ :fill-pointer 0))
	 (i 0)
	 (transducers (list (make-instance 'punc-transducer)
			   (make-instance 'latin-transducer))))
    (setf (aref path 0) (make-link :p-idx 0 :w 0 :unk 0 :kind +init+))
    (loop for ch in ch-list
	  do
	     (vector-push-extend (make-dix-ptr :s i :row-no 0 :is-final nil) dix-ptrs)
	     (let* ((unk-link (aref path left-boundary))
		    (link (make-link :p-idx left-boundary :w (+ (link-w unk-link))
				     :unk (+ (link-unk unk-link) 1) :kind +unk+))
		    (j 0))
	       (vector-push-extend (make-dix-ptr :s i :row-no 0 :is-final nil) dix-ptrs)
	       (loop while (< j (length dix-ptrs))
		     do
			(let* ((dix-ptr (aref dix-ptrs j))
			       (offset (- i (dix-ptr-s dix-ptr)))
			       (row-no (dix-ptr-row-no dix-ptr))
			       (child (lookup dix row-no offset ch)))
			  (if child
			      (progn
				(setf (aref dix-ptrs j)
				      (make-dix-ptr :s (dix-ptr-s dix-ptr)
						    :row-no (node-ptr-row-no child)
						    :is-final (node-ptr-is-final child)))
				(incf j))
			      (if (eq (+ j 1) (length dix-ptrs))
				  (progn
				    (incf j)
				    (vector-pop dix-ptrs))
				  (setf (aref dix-ptrs j) (vector-pop dix-ptrs))))))
	       (loop for dix-ptr across dix-ptrs
		     do
			(when (dix-ptr-is-final dix-ptr)
			  (let* ((new-s (dix-ptr-s dix-ptr))
				 (dix-link (aref path new-s))
				 (new-link (make-link :p-idx new-s
						      :w (link-w dix-link)
						      :unk (link-unk dix-link)
						      :kind +dict+)))
			    (when (betterp new-link link)
			      (setq link new-link)))))
	       (loop for transducer in transducers
		     do
			(update transducer ch i ch-vec)
			(when (eq (state transducer) +completed+)
			  (let* ((s (s transducer))
				 (prev-link (aref path s))
				 (new-link (make-link :p-idx s
						      :w (+ (link-w prev-link) 1)
						      :unk (link-unk prev-link)
						      :kind (transducer-link-kind transducer))))
			    (when (betterp new-link link)
			      (setq link new-link)))))
	       (setf (aref path (+ i 1)) link)
	       (incf i)))
    path))


;; (defparameter *x* (make-array 8 :fill-pointer 0))
;;  (vector-push-extend (make-dix-ptr :s 1 :row-no 0 :final nil) *x*)

;; (build-path (make-prefix-tree '(("กา" 1) ("กาม" 2)))
;; 	    "กากาม")
;; (build-path (make-prefix-tree '(("กา" 1) ("กาม" 2)))
;; 	    "KAKA")
;; (build-path (make-prefix-tree '(("กา" 1) ("กาม" 2)))
;; 	    "A B")
;; (lookup (make-prefix-tree '(("A" 1))) 0 0 #\A)
;; (lookup (make-prefix-tree '(("กา" 1) ("กาม" 2))) 0 0 #\ก)
;; (lookup (make-prefix-tree '(("กา" 1) ("กาม" 2))) 0 1 #\ก) ;; nil
;; (lookup (make-prefix-tree '(("กา" 1) ("กาม" 2))) 0 1 #\า)
;; (alexandria:hash-table-alist (make-prefix-tree '(("กา" 1) ("กาม" 2))))

(defstruct range
  (s 0 :type integer)
  (e 0 :type integer))

(defun path-to-ranges (path)
  (let ((e (- (length path) 1))
	(ranges nil))
    (loop while (> e 0)
	  do
	     (let* ((link (aref path e))
		    (s (link-p-idx link))
		    (r (make-range :s s :e e)))
	       (setq ranges (cons r ranges))
	       (setq e s)))
    ranges))

;; (path-to-ranges (build-path (make-prefix-tree '(("กา" 1) ("กาม" 2)))
;; 			    "กากาม"))

(defun ranges-to-toks (ranges str)
  (loop for r in ranges
	collect
	(subseq str (range-s r) (range-e r))))

;; (ranges-to-toks
;;  (path-to-ranges (build-path (make-prefix-tree '(("กา" 1) ("กาม" 2)))
;; 			     "กากาม"))
;;  "กากาม")

(defun tokenize (dix str)
  (ranges-to-toks (path-to-ranges (build-path dix str))
		  str))

;; (tokenize (make-prefix-tree '(("กา" 1) ("กาม" 2))) "กากาม")

(defun tokenize-with-delim (dix str delim)
  (join delim (tokenize dix str)))

;; (tokenize-with-delim (make-prefix-tree '(("กา" 1) ("กาม" 2))) "กากาม" "|")


(defparameter *dix*
  (make-prefix-tree
   (with-open-file (f #P"../../wordcut-bench/thai.txt" :external-format :utf-8)
     (loop for line = (read-line f nil nil)
	   while line
	   collect (list line 1)))))


(defun bench1 ()
  (time
   (with-open-file (f #P"../../wordcut-bench/wik100k.txt" :external-format :utf-8)
     (loop for line = (read-line f nil nil)
	   while line
	   do (tokenize-with-delim *dix* line "|")))))


(bench1)