-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathgeneric.lisp
181 lines (161 loc) · 7.59 KB
/
generic.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
;; -*- mode: Lisp; coding: utf-8-unix; -*-
;; Copyright (c) 2024, April & May
;; SPDX-License-Identifier: 0BSD
(in-package aprnlp)
;; Words
(defstruct word id form lemma upos xpos head deprel suffix prefix)
(export '(word
word-id word-form word-lemma word-upos word-xpos
word-head word-deprel word-suffix word-prefix
make-word copy-word word-p))
(defpackage pos/words)
(defun word-shape (word)
(let ((form (word-form word)))
(when (symbolp form) (setq form (symbol-name form)))
(when (stringp (word-form word))
(coerce (iter (for char :in-string form)
(collect (cond ((digit-char-p char) #\D)
((upper-case-p char) #\U)
((lower-case-p char) #\L)
((punct-char-p char) char))))
'string))))
(defun general-form (word)
(let ((str (symbol-name (word-form word))))
(cond ((numericp str) :number)
((ordinalp str) :ordinal)
((and (= (length str) 1)
(member str '(#\( #\[ #\{ #\<)))
:left-pair)
((and (= (length str) 1)
(member str '(#\) #\] #\} #\>)))
:right-pair)
;((punctp str) :punct)
((and (find #\@ str) (find #\. str)) :email)
(t (word-form word)))))
(defun copy-sentence (sentence)
(let ((result (make-array (length sentence) :element-type 'word)))
(iter (for word :in-vector sentence :with-index i)
(setf (aref result i) (copy-word word)))
result))
(defun copy-sentences (sentences)
(let ((result (make-array (length sentences) :element-type 'vector)))
(iter (for sentence :in-vector sentences :with-index i)
(setf (aref result i) (copy-sentence sentence)))
result))
(export '(copy-sentence copy-sentences))
;; Processor
(defclass perceptron-processor ()
((name :initform "Unnamed Processor"
:initarg :name
:accessor processor-name)
(update-count :initform 0)
(weights :initform (make-hash-table :test #'eq)
:accessor processor-weights)
(last-updates :initform (make-hash-table :test #'eq))
(living-weights :initform (make-hash-table :test #'eq))))
(export '(perceptron-processor name weights processor-name processor-weights))
;; Helping functions
(defun get-weight (table feature class)
(declare (optimize (safety 0) (speed 3) (space 0))
(inline get-weight))
(apply #'href-default 0 table (append feature (list class))))
(defun add-weight (table feature class val)
(declare (optimize (safety 0) (speed 3) (space 0)))
(destructuring-bind (type specializer value) feature
(prog (type-table specializer-table value-table)
(if-let (table (gethash type table))
(progn
(setq type-table table)
(if-let (table (gethash specializer table))
(progn
(setq specializer-table table)
(if-let (table (gethash value table))
(progn
(setq value-table table)
(go set-value))
(go create-value-table)))
(go create-specializer-table)))
(go create-type-table))
create-type-table
(setq type-table (setf (gethash type table) (make-hash-table :test #'eq)))
create-specializer-table
(setq specializer-table (setf (gethash specializer type-table) (make-hash-table :test #'eq)))
create-value-table
(setq value-table (setf (gethash value specializer-table) (make-hash-table :test #'eq)))
set-value
(incf (gethash class value-table 0) val))))
(defun set-weight (table feature class val)
(declare (optimize (safety 0) (speed 3) (space 0)))
(destructuring-bind (type specializer value) feature
(prog (type-table specializer-table value-table)
(if-let (table (gethash type table))
(progn
(setq type-table table)
(if-let (table (gethash specializer table))
(progn
(setq specializer-table table)
(if-let (table (gethash value table))
(progn
(setq value-table table)
(go set-value))
(go create-value-table)))
(go create-specializer-table)))
(go create-type-table))
create-type-table
(setq type-table (setf (gethash type table) (make-hash-table :test #'eq)))
create-specializer-table
(setq specializer-table (setf (gethash specializer type-table) (make-hash-table :test #'eq)))
create-value-table
(setq value-table (setf (gethash value specializer-table) (make-hash-table :test #'eq)))
set-value
(setf (gethash class value-table) val))))
(defun find-best (processor features)
(declare (optimize (safety 0) (speed 3) (space 0)))
(let ((scores (make-hash-table :test #'eq)))
(iter (for feature :in-vector features)
(awhen (apply #'href-default nil (slot-value processor 'weights) feature)
(iter (for (class weight) :in-hashtable it)
(incf (gethash class scores 0.0) weight))))
(iter (for (class weight) :in-hashtable scores)
(finding class :maximizing weight))))
;; Methods
(defgeneric update (processor truth guess features)
(:method (processor truth guess features)
(declare (optimize (speed 3) (space 0) (safety 0)))
(with-slots (update-count weights last-updates living-weights) processor
(flet ((upd (feature class val)
(declare (inline upd))
(let* ((last-update (get-weight last-updates feature class))
(lived-cycle (- update-count last-update)))
(add-weight living-weights feature class
(* lived-cycle (get-weight weights feature class)))
(set-weight last-updates feature class update-count)
(add-weight weights feature class val))))
(incf update-count)
(unless (eq truth guess)
(iter (for feature :in-vector features)
(upd feature truth 1)
(upd feature guess -1)))))))
(defgeneric average-weights (processor)
(:method (processor)
(declare (optimize (space 0) (speed 3) (safety 0) (float 0)))
(with-slots (update-count weights last-updates living-weights) processor
(iter (for (type type-table) :in-hashtable weights)
(iter (for (specializer specializer-table) :in-hashtable type-table)
(iter (for (value value-table) :in-hashtable specializer-table)
(iter (for (class nil) :in-hashtable value-table)
(let* ((feature (list type specializer value))
(last-update (get-weight last-updates feature class))
(lived-cycle (- update-count last-update)))
(add-weight living-weights feature class
(* lived-cycle (get-weight weights feature class)))
(let ((living-weight (get-weight living-weights feature class)))
(set-weight weights feature class
(float (/ living-weight update-count))))))))))))
(defgeneric process (processor sentence))
(defgeneric train (processor sentences &key cycles save-dir))
(defgeneric test (processor sentences))
(defgeneric test-training (processor-class))
(defgeneric save-processor (processor directory))
(defgeneric load-processor (class file))
(export '(process train test test-training load-processor save-processor))