esperanto/esperanto.lisp - Recently Written

esperanto.lisp (6970 bytes)
1 ;; Note: Only works if unicode is supported in symbols, due to espeanto's character
2 ;; set. It is possible to change the code such that this is not longer the case.
3 (defpackage :esperanto
4   (:use :cl :utils)
5   (:nicknames :esp))
6 
7 (in-package :esperanto)
8 
9 (assert (unwind-protect (code-char  (1- 1114112)) nil))
10 
11 (defun inside (from into)
12   (if (eq into from)
13       into
14       (labels ((inside-aux (from into inclusive exclusive stop)
15 		 (if (= exclusive stop)
16 		     nil
17 		     (if (equalp (subseq from inclusive exclusive)
18 				 into)
19 			 into
20 			 (inside-aux from into (1+ inclusive) (1+ exclusive) stop)))))
21 	(inside-aux from into 0 (length into) (1+ (length from))))))
22 
23 (defun concatenate-list (list)
24   (reduce (lambda (x y) (concatenate 'string x y)) list))
25 
26 (defvar *rules* nil
27   "Assign each defrule here so they can be searched.")
28 
29 (defvar *terminals* nil
30   "Alist of terminals classes.")
31 
32 (defun defterminals (class-name class-list)
33   "Define a terminals class."
34   (dolist (term class-list)
35     (setf (symbol-plist term) (list 'terminal t)))
36   (setf *terminals*
37 	(cons (list class-name class-list)
38 	      *terminals*)))
39 
40 (defun terminal? (sym)
41   "Is the symbol a terminal symbol?"
42   (and (symbolp sym)
43        (equal (symbol-plist sym) (list 'terminal t))))
44 
45 (defun terminal-class? (class)
46   "Determine if a class is a terminal class."
47   (some #'(lambda (x)
48 	    (eql class (car x))) *terminals*))
49 
50 (defun token? (class-item)
51   (when (symbolp class-item)
52     (member class-item (list 'unicode-pua-2 'unicode-pua-1 'unicode-pua-3 ''unicode-pua-4))))
53 
54 (defun token-class? (list)
55   "Determine if the class is tokenized (as opposed to being a terminal-class)."
56   (and (listp list)
57        (some #'token? list)))
58 
59 (defun subterminal? (rule)
60   (and (consp rule)
61        (some #'(lambda (item)
62 		 (eq (car rule)
63          item)) (list '^ '+ 'g '*))
64        (every #'terminal-class? (cdr rule))))
65 
66 ;; Notation:
67 ;; Note that this is essentially a lispy BNF.
68 ;; (+ ...) means 1 or more. NIL on failure.
69 ;; (* ...) means 0 or more. Empty string on failure
70 ;; (^ ...) means OR, so like a short circuit +. NIL on failure.
71 ;; (g ...) is a grouping. Like a hybrid between logAND and concatenation.
72 ;; There is an implicit (g ...) in defrule, so (defrule <rulename> (g ...))
73 ;; defterminals are always of the form (defterminals <class> (<terminal> ...))
74 
75 
76 ;; Compile-time functions for rules
77 (defun expand-terminal (class)
78   "Get the expansion of a terminal class."
79   (some #'(lambda (x)
80 	    (if (eql class (car x))
81 		(cadr x))) *terminals*))
82 
83 (defun append-each (lists &optional acc)
84   (if (null lists)
85       acc
86       (append-each (cdr lists) (append acc (car lists)))))
87 
88 (defmacro mappend (function list &rest more-lists)
89   `(append-each (mapcar ,function ,list ,@more-lists)))
90 
91 (defmacro exp-aux (args)
92   "Auxillary function for ex-X macros."
93   (with-gensyms (arg)
94     `(mappend #'(lambda (,arg)
95 		 (cond ((terminal-class? ,arg) (expand-terminal ,arg))
96 		       (t (list ,arg)))) ,args)))
97 ;; These use weird unicode symbols as a gensymmy object code. This could be done
98 ;; better. Also, if an input word is NIL everything breaks.
99 
100 (defmacro exp-^ (args)
101   "Given forms 1 2 3 ... in (^ 1 2 3 ...) expand it."
102   `(cons 'unicode-pua-1 (exp-aux ,args)))
103 
104 (defmacro exp-+ (args)
105   "Expand (+ 1 2 3 ...)"
106   `(cons 'unicode-pua-4 (exp-aux ,args)))
107 
108 (defmacro exp-* (args)
109   "Expand (* 1 2 3 ...)"
110   `(cons 'unicode-pua-3 (exp-aux ,args)))
111 
112 (defmacro exp-g (args)
113   "Expand (* 1 2 3 ...)"
114   `(cons 'unicode-pua-2 (exp-aux ,args)))
115 
116 (defmacro defmatch (name symbol)
117   "Create a true predicate to determine an expanded class's token."
118   (with-gensyms (expanded)
119     `(defpredicate ,name ,(list expanded)
120        (and (listp ,expanded)
121 	    (and (symbolp (car ,expanded))
122 		 (eq (car ,expanded) ',symbol))))))
123 
124 (defmatch ^? unicode-pua-1)
125 (defmatch g? unicode-pua-2)
126 (defmatch *? unicode-pua-3)
127 (defmatch +? unicode-pua-4)
128 
129 (defmacro expand-correct (args)
130   "Auxillary macro for expand. Used for subterminal (operation terminal terminal...)
131    argument."
132   (with-gensyms (once)
133     `(let ((,once ,args))
134        ;; Cond necessary because macros cannot be funcall'd
135        (cond ((eql '^ (car ,once)) (exp-^ (cdr ,once)))
136 	     ((eql '+ (car ,once)) (exp-+ (cdr ,once)))
137 	     ((eql '* (car ,once)) (exp-* (cdr ,once)))
138 	     ((eql 'g (car ,once)) (exp-g (cdr ,once)))))))
139 
140 (defun rule-class? (name)
141   (some #'(lambda (x)
142 	    (eql (car x) name)) *rules*))
143 
144 (defun read-expansion (rule)
145   (labels ((read-expansion-aux (rules*)
146 	     (if (null rules*)
147 		 nil
148 		 (if (eq rule (caar rules*))
149 		     (cadar rules*)
150 		     (read-expansion-aux (cdr rules*))))))
151     (read-expansion-aux *rules*)))
152 
153 (defun expanded-p (rule)
154   (not (null (read-expansion rule))))
155 
156 (defun expand (rule)
157   "Expand a rule."
158   (cond ((null rule) nil)
159 	((rule-class? rule) (read-expansion rule))
160 	((terminal-class? rule)
161 	 (expand-terminal rule))
162 	((subterminal? rule)
163 	 (expand-correct rule))
164 	(t (expand-correct (cons (car rule)
165 				 (mapcar #'expand (cdr rule)))))))
166 
167 (defun make-a-rule (name expansion)
168   "Auxilliary function to defrule."
169   (if (expanded-p name)
170       nil
171        (setf *rules*
172 	     (cons (list name expansion)
173 		   *rules*))))
174 
175 (defmacro defrule (name &rest expansion)
176   `(make-a-rule ',name (expand '(g ,@expansion))))
177 
178 (defrule suffix (^ noun-suffix adverb-suffix adjective-suffix verb-suffix
179 		   oddball-suffixes))
180 
181 ;; English explaination of a polyword:
182 ;; 1) Search if there is a prefix. If there isn't, it is optional, so move on.
183 ;; 2) Search if the term is a member of the root terminal class. If it isn't,
184 ;;    just return it. This will make any subsequent search be looking at an
185 ;;    empty string "".
186 ;; 3) Search if the last part of the term is 1 or more presuffixes followed by
187 ;;    one or more suffixes. If not, search if it is one or more suffixes. If not
188 ;;    , return the search term.
189 ;; When the above returns a match, it will look like (class . "match"). When it
190 ;; is forced to return raw data, it just looks like "$", where $ is the data.
191 ;; The result is contained in a list, like ((class . "match") "$")
192 
193 (defrule polyword (* prefix) (^ root) (^ (g (+ presuffix)
194 					    (+ suffix))
195 					 (+ suffix)))
196 
197 (defrule correlative correlative-prefix correlative-suffix)
198 
199 (defun match-terminal? (word terminal)
200   "Partial predicate which returns whether the word matches the terminal symbol. 
201    Returns either the match or NIL."
202   (awhen (inside (symbol-name word) (symbol-name terminal))
203     (intern it)))
204 
205 (defun match-terminal-class? (word terminal-class)
206   "Partial predicate built over match-terminal?"
207   (some #'(lambda (terminal)
208 	    (match-terminal? word terminal)) terminal-class))
209 
210 (defun operation (word class)
211   "Run the function operation for each class type."
212   (cond ((null class) 'unicode-pua-3)
213 	((atom class) (match-terminal? word class))
214 	((g? class)
215 	 (symb (operation (cadr class)) (operation (cddr class))))
216 	((^? sym)
217 	 )
218 	((*? sym))
219 	((+? sym))
220 	(t )))