(in-package :cl-conllu)

(defparameter *token-fields*

'(id form lemma upostag xpostag feats head deprel deps misc))

(defclass abstract-token ()

((sentence :accessor token-sentence)

(lineno :initarg :lineno

:accessor token-lineno)

(form :initarg :form

:accessor token-form)

(cfrom :initarg :cfrom

:initform -1

:accessor token-cfrom)

(cto :initarg :cto

:initform -1

:accessor token-cto)

(misc :initarg :misc

:initform "_"

:accessor token-misc)))

(defclass token (abstract-token)

((id :initarg :id

:accessor token-id)

(lemma :initarg :lemma

:accessor token-lemma)

(upostag :initarg :upostag

:initform "_"

:accessor token-upostag)

(xpostag :initarg :xpostag

:initform "_"

:accessor token-xpostag)

(feats :initarg :feats

:initform "_"

:accessor token-feats)

(head :initarg :head

:initform "_"

:accessor token-head)

(deprel :initarg :deprel

:initform "_"

:accessor token-deprel)

(deps :initarg :deps

:initform "_"

:accessor token-deps)))

(defclass etoken (abstract-token)

((prev :initarg :prev

:accessor etoken-prev)

(index :initarg :index

:accessor etoken-index)

(lemma :initarg :lemma

:accessor etoken-lemma)

(upostag :initarg :upostag

:initform "_"

:accessor etoken-upostag)

(xpostag :initarg :xpostag

:initform "_"

:accessor etoken-xpostag)

(feats :initarg :feats

:initform "_"

:accessor etoken-feats)

(deps :initarg :deps

:initform "_"

:accessor etoken-deps)))

(defclass mtoken (abstract-token)

((start :initarg :start

:accessor mtoken-start)

(end :initarg :end

:accessor mtoken-end)))

(defclass sentence ()

((start :initarg :start

:initform 0

:accessor sentence-start)

(meta :initarg :meta

:initform nil

:accessor sentence-meta)

(tokens :initarg :tokens

:initform nil

:accessor sentence-tokens)

(mtokens :initarg :mtokens

:initform nil

:accessor sentence-mtokens)

(etokens :initarg :etokens

:initform nil

:accessor sentence-etokens)))

(defmethod print-object ((obj sentence) out)

(print-unreadable-object (obj out :type t)

(format out "~a at ~a"

(sentence-meta-value obj "sent_id")

(slot-value obj 'start))))

(defmethod print-object ((obj token) out)

(print-unreadable-object (obj out :type t)

(format out "~s ~a #~a-~a-~a"

(slot-value obj 'form) (slot-value obj 'upostag)

(slot-value obj 'id) (slot-value obj 'deprel) (slot-value obj 'head))))

(defmethod initialize-instance :after ((obj sentence)

&key tokens &allow-other-keys)

"Sets the TOKEN-SENTENCE slot for each token attributed to the initialize sentence OBJ."

(mapc (lambda (tk) (setf (token-sentence tk) obj))

tokens)

(sentence-fill-offsets obj))

(defun sentence-fill-offsets (sentence)

(with-slots (tokens mtokens) sentence

(loop with cpos = 0

with next = 0

for ltk = nil then tk

for tk in (sort (copy-seq (append tokens mtokens)) #'<= :key #'token-lineno)

for form = (token-form tk)

for spc = (if (search "SpaceAfter=No" (token-misc tk)) 0 1)

for len = (length form)

do (typecase tk

(token (if (> (token-id tk) next)

(setf (token-cfrom tk) cpos

(token-cto tk) (+ len cpos)

cpos (+ cpos len spc))

(setf (token-cfrom tk) (token-cfrom ltk)

(token-cto tk) (token-cto ltk))))

(mtoken (setf (token-cfrom tk) cpos

(token-cto tk) (+ len cpos)

cpos (+ cpos len spc)

next (mtoken-end tk))))

finally (return sentence))))

(defun sentence-matrix (sentence)

(let ((arr (make-array (list (length (sentence-tokens sentence)) 10)))

(tb '(0 id 1 form 2 lemma 3 upostag 4 xpostag 5 feats 6 head 7 deprel 8 deps 9 misc)))

(dolist (tk (sentence-tokens sentence) arr)

(dotimes (v 10)

(setf (aref arr (- (token-id tk) 1) v)

(if (member (getf tb v) '(id head))

(- (slot-value tk (getf tb v)) 1)

(slot-value tk (getf tb v))))))))

(defun sentence-root (sentence)

(find-if (lambda (tk) (and (equal 0 (token-head tk))

(equal "root" (token-deprel tk))))

(sentence-tokens sentence)))

(defun sentence-binary-tree (sentence)

"Based on the idea from [1], it produces a tree view of the

(let* ((pri '("amod" "flat" "compound" "det" "cc"

"appos" "acl" "cop" "dobj" "aux" "xcomp" "nmod"

"advmod" "advcl" "nsubj" "case" "conj" "punct"))

(siz (length pri)))

(labels ((priority (label default)

(or (position label pri) default))

(deep-aux (root)

(let ((children (sort (token-children root sentence)

(lambda (a b)

(< (priority (token-deprel a) (+ 1 siz))

(priority (token-deprel b) (+ 2 siz)))))))

(if (null children)

root

(let* ((c (car children))

(left (list (token-deprel c) root (deep-aux c))))

(dolist (child (cdr children) left)

(setf left

(list (token-deprel child) left (deep-aux child)))))))))

(deep-aux (sentence-root sentence)))))

(defun sentence-hash-table (sentence)

(let* ((tb (alexandria:alist-hash-table (sentence-meta sentence) :test #'equal))

(fields '(id form lemma upostag xpostag feats head deprel deps misc)))

(setf (gethash "tokens" tb)

(mapcar (lambda (tk)

(let ((dt (mapcar (lambda (field)

(cons (symbol-name field) (slot-value tk field)))

fields)))

(alexandria:alist-hash-table dt :test #'equal)))

(sentence-tokens sentence)))

tb))

(defun sentence-meta-value (sentence meta-field)

(cdr (assoc meta-field (sentence-meta sentence) :test #'equal)))

(defun sentence-id (sentence)

(sentence-meta-value sentence "sent_id"))

(defun sentence-text (sentence)

(sentence-meta-value sentence "text"))

(defun sentence->text (sentence &key (ignore-mtokens nil)

(special-format-test #'null special-format-test-supplied-p)

(special-format-function #'identity special-format-function-supplied-p))

"Receives SENTENCE, a sentence object, and returns a string

(assert (or (and special-format-test-supplied-p

special-format-function-supplied-p)

(and (not special-format-test-supplied-p)

(not special-format-function-supplied-p)))

(special-format-test

special-format-function)

"If a special format is intended, then both

specified!")

(assert (functionp special-format-test))

(assert (functionp special-format-function))

(labels ((forma (obj lst)

(let ((obj-form

(if (funcall special-format-test obj)

(funcall special-format-function (slot-value obj 'form))

(slot-value obj 'form))))

(if (search "SpaceAfter=No" (slot-value obj 'misc))

(cons obj-form lst)

(cons " " (cons obj-form lst)))))

(aux (tokens mtokens ignore response)

(cond

((and (null tokens) (null mtokens))

(if (equal " " (car response))

(reverse (cdr response))

(reverse response)))

((and ignore (< (token-id (car tokens)) ignore))

(aux (cdr tokens) mtokens ignore response))

((and ignore (equal (token-id (car tokens)) ignore))

(aux (cdr tokens) mtokens nil response))

((and mtokens (<= (mtoken-start (car mtokens)) (token-id (car tokens))))

(aux tokens (cdr mtokens)

(mtoken-end (car mtokens))

(forma (car mtokens) response)))

(t

(aux (cdr tokens) mtokens ignore (forma (car tokens) response))))))

(format nil "~{~a~}" (aux (sentence-tokens sentence)

(if ignore-mtokens

nil

(sentence-mtokens sentence))

nil nil))))

(defun token-attached (tk sentence)

(labels ((aux (tk q)

(cond

((equal (token-head tk) 0) t)

((member (token-id tk) q :test #'equal) nil)

(t (aux (token-parent tk sentence) (cons (token-id tk) q))))))

(aux tk nil)))

(defun sentence-valid? (sentence)

(and (every (lambda (tk)

(and (not (equal (token-id tk)

(token-head tk)))

(token-attached tk sentence)))

(sentence-tokens sentence))

(sentence-root sentence)

(sentence-meta-value sentence "text")

(equal (sentence-meta-value sentence "text")

(sentence->text sentence))

(sentence-meta-value sentence "sent_id")))

(defun sentence-size (sentence)

(length (sentence-tokens sentence)))

(defun token-children (token sentence &key (fn-filter nil))

(let ((res (remove-if-not (lambda (tk)

(equal (token-head tk) (token-id token)))

(sentence-tokens sentence))))

(if fn-filter (remove-if-not fn-filter res) res)))

(defun token-parent (token sentence)

(when (not (equal 0 (token-head token)))

(nth (- (token-head token) 1)

(sentence-tokens sentence))))

(defun token-hash-features (token)

(alexandria:alist-hash-table

(mapcar (lambda (v)

(let ((xs (cl-ppcre:split "=" v)))

(cons (car xs) (cadr xs))))

(cl-ppcre:split "\\|" (token-feats token))) :test #'equal))

(defun hash-to-features (tb)

(let ((as (sort (alexandria:hash-table-alist tb) #'string<= :key #'car)))

(format nil "~{~a~^|~}"

(loop for p in as collect (format nil "~a=~a" (car p) (cdr p))))))

(defun token-add-feature (token feat val)

(let ((tb (token-hash-features token)))

(setf (gethash feat tb) val)

(setf (token-feats token) (hash-to-features tb))))

(defun token-rem-feature (token feat)

(let ((tb (token-hash-features token)))

(remhash feat tb)

(setf (token-feats token) (hash-to-features tb))))

(defun set-head (sentence id new-head &optional deprel)

(let ((token (find id (sentence-tokens sentence)

:key #'token-id :test #'equal)))

(cond

((is-descendant? new-head id sentence)

(values sentence nil))

((equal id new-head)

(values sentence nil))

(t

(setf (slot-value token 'head) new-head)

(if deprel

(setf (token-deprel 'deprel) deprel))

(values sentence t)))))

(defun is-descendant? (id-1 id-2 sentence &optional alist)

(let ((head-1 (token-head (sentence-get-token-by-id sentence id-1))))

(cond

((equal head-1 0) nil)

((equal head-1 id-2)

(reverse (cons id-2 (cons id-1 alist))))

(t

(is-descendant? head-1 id-2 sentence (cons id-1 alist))))))

(defun adjust-sentence (sentence)

"Receives a sentence and reenumerate IDs and HEAD values of each

(with-slots (tokens mtokens) sentence

(let* ((maps (cons `(0 . 0)

(mapcar (lambda (tk pos)

(cons (token-id tk) (1+ pos)))

tokens (alexandria:iota (length tokens)))))

(no-change (every (lambda (p) (equal (car p) (cdr p))) maps)))

(when (not no-change)

(dolist (tk tokens)

(setf (token-id tk) (cdr (assoc (token-id tk) maps))

(token-head tk) (cdr (assoc (token-head tk) maps))))

(dolist (mtk mtokens)

(setf (mtoken-start mtk) (cdr (assoc (mtoken-start mtk) maps))

(mtoken-end mtk) (cdr (assoc (mtoken-end mtk) maps)))))))

sentence)

(defun simple-deprel (deprel)

(car (ppcre:split ":" deprel)))

(defun token-equal (tk1 tk2 &key (fields *token-fields*) (test #'equal) (simple-dep nil))

(every (lambda (field)

(if (and (equal field 'deprel) simple-dep)

(funcall test

(simple-deprel (slot-value tk1 field))

(simple-deprel (slot-value tk2 field)))

(funcall test

(slot-value tk1 field)

(slot-value tk2 field))))

fields))

(defun mtoken-equal (mtoken-1 mtoken-2)

"Tests if, for each slot, mtoken-1 has the same values as mtoken-2."

(every (lambda (slot)

(equal (slot-value mtoken-1 slot)

(slot-value mtoken-2 slot)))

'(start end form misc)))

(defun sentence-equal (sent-1 sent-2)

"Tests if, for each slot, sent-1 has the same values as sent-2.

(and (every

(lambda (slot)

(equal (slot-value sent-1 slot)

(slot-value sent-2 slot)))

'(start meta))

(if (equal (length (sentence-tokens sent-1))

(length (sentence-tokens sent-2)))

(dotimes (x (length (sentence-tokens sent-1)) t)

(unless (token-equal

(nth x (sentence-tokens sent-1))

(nth x (sentence-tokens sent-2)))

(return nil))))

(if (equal (length (sentence-mtokens sent-1))

(length (sentence-mtokens sent-2)))

(dotimes (x (length (sentence-mtokens sent-1)) t)

(unless (mtoken-equal

(nth x (sentence-mtokens sent-1))

(nth x (sentence-mtokens sent-2)))

(return nil))))))

(defun token-misc-value (token misc-key)

"Assume token's MISC is a list of key-value pairs, return value

(let* ((misc-str (token-misc token))

(misc-elems (split-sequence:split-sequence #\| misc-str))

(misc-pairs (mapcar (alexandria:curry #'split-sequence:split-sequence #\=) misc-elems)))

(mapc (lambda (pair) (when (not (cdr pair))

(format *error-output*

"token-misc-value: MISC field not a key-value pair: ~a"

(car pair))))

misc-pairs)

(second (assoc misc-key misc-pairs :test #'string=))))

(defun sentence-get-token-by-id (sentence id)

(nth (1- id) (sentence-tokens sentence)))

(defun sentence-by-id (id filename)

(find-if (lambda (s) (equal id (sentence-id s))) (read-conllu filename)))