(defpackage #:minlang
(:use #:cl #:alexandria #:split-sequence)
(:export #:text
#:text*
#:parse-text
#:expand-relations))
(defpackage #:minlang-primitives
(:nicknames #:mlp)
(:export #:imply
#:intersect
#:differ
#:unite
#:equal
#:without
#:relate
#:count
))
(in-package #:minlang)
(defmacro fl (stream control-string &rest arguments)
(let ((last (car (last arguments)))
(lastexp (make-gensym "lastexp")))
`(let ((,lastexp ,last))
(format ,stream ,control-string ,@(butlast arguments) ,lastexp)
,lastexp)))
(defmacro prl (&rest objects)
(let (skip)
(if objects
`(progn
(fl t "~@{~a~^ ~}~%"
,@(mapcar (lambda (obj)
(cond ((symbolp obj)
(prog1
(if skip
obj
`(format nil "~@{~a: ~S~}," ,(symbol-name obj) ,obj))
(setf skip nil)))
((consp obj)
(prog1
(if skip
obj
`(format nil "~@{~a: ~S~}," ,(symbol-name (car obj)) ,obj))
(setf skip nil)))
((stringp obj)
(setf skip t)
obj)
(t (error "Unsupported type"))))
objects)))
`(terpri))))
(defun split-string (string split)
(dotimes (i (length string))
(when (char= (char string i) split)
(return-from split-string
(values (subseq string 0 i) (subseq string (1+ i))))))
string)
(defmacro defadder (name adder)
(with-gensyms (fname fargs body)
`(defmacro ,name (,fname ,fargs &body ,body)
`(,',adder ',,fname (lambda ,,fargs ,@,body)))))
(defparameter *rel-sets*
(make-hash-table :test #'equal))
(defun add-rel-set (name fn)
(setf (gethash name *rel-sets*) fn))
(defadder defrel add-rel-set)
(defparameter *binary* (plist-hash-table '("is" mlp:imply
"or" mlp:differ
"en" mlp:unite
"ic" mlp:equal
"se" mlp:without)
:test #'equal))
(defparameter *sets* nil)
(defparameter *modifiers*
(make-hash-table :test #'equal))
(defun add-modifier (name fn)
(setf (gethash name *modifiers*) fn))
(defadder defmodifier add-modifier)
(defun apply-modifiers (tokens &aux sen)
(do ((token (car tokens) (car rest))
(rest (cdr tokens) (cdr rest)))
((not token) sen)
(if-let ((fn (gethash token *modifiers*)))
(if rest
(push (funcall fn token (pop rest)) rest)
(error "Modifier needs token"))
(push token sen))))
(defun parse-sentence (tokens &aux sen)
(do ((token (car tokens) (car rest))
(rest (cdr tokens) (cdr rest)))
((not token) sen)
(cond ((gethash token *rel-sets*)
(multiple-value-bind (sen0 rest0) (parse-sentence rest)
(push (cons token (reverse sen0)) sen)
(setf rest rest0)))
((gethash token *binary*)
(push token sen))
((or (member token *sets* :test #'equal) nil)
(return-from parse-sentence (values (cons token sen) rest)))
(t (error "Word ~a not allowed" token)))))
(defun parse-sentence-end (tokens &aux binary)
(or
(unless (cdr tokens)
(if (consp (car tokens))
(parse-sentence-end (car tokens))
(car tokens)))
(destructuring-bind (set rel . rest) tokens
(when (gethash set *binary*)
(error "Binary operations not allowed in this context"))
(let ((relation (or (when (gethash set *rel-sets*) 'mlp:relate)
(when-let ((bin (gethash rel *binary*)))
(setf binary t)
bin)
'mlp:intersect))
(set0 (if (listp set) (parse-sentence-end set) set))
(set1 (parse-sentence-end (if binary rest (cons rel rest)))))
(list relation set0 set1)))))
(defvar *whitespaces*
'(#\Space #\Newline #\Backspace #\Tab
#\Linefeed #\Page #\Return #\Rubout))
(defun whitespacep (char)
(member char *whitespaces* :test #'char=))
#+(or)
(defun parse-text (string)
(multiple-value-bind (first rest) (split-string string #\.)
(let ((sentence (parse-sentence (delete 0 (split-sequence-if #'whitespacep first) :key #'length))))
(if (and rest (not (string= rest "")))
`(mlp:intersect ,sentence ,(parse-text rest))
sentence))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun parse-text (string)
(multiple-value-bind (first rest) (split-string string #\.)
(let* ((seq (reverse (apply-modifiers (delete 0 (split-sequence-if #'whitespacep first) :key #'length))))
sen)
(loop
(multiple-value-bind (sen0 seq0) (parse-sentence seq)
(setf sen (if sen (cons sen (reverse sen0)) (reverse sen0))
seq seq0)
(unless seq
(return))))
(setf sen (parse-sentence-end sen))
(if (and rest (not (string= rest "")))
`(mlp:intersect ,sen ,(parse-text rest))
sen)))))
(defmacro text (string)
(parse-text string))
(defun expand-relations (list &optional type)
(if (consp list)
(if (eq (car list) 'mlp:relate)
(destructuring-bind (rel set . rest) (cdr list)
(when rest
(error "Non-binary relations not possible"))
(let ((fn (gethash rel *rel-sets*)))
(if (and (functionp fn)
(or (not type) (eq type rel)))
(expand-relations (funcall fn set) type)
(list (car list) rel (expand-relations set type)))))
(cons (car list) (mapcar (lambda (form) (expand-relations form type)) (cdr list))))
list))
(defmacro text* (string)
(expand-relations (parse-text string)))
(set-dispatch-macro-character #\# #\~ (lambda (stream char s)
(declare (ignore char s))
`(text* ,(read-line stream))))
;;;language
(defun rel-set-modifier (ctok tok)
(let ((ntok (format nil "~a ~a" ctok tok)))
(cond ((gethash tok *rel-sets*)
(setf (gethash ntok *rel-sets*) t))
((gethash tok *modifiers*)
(setf (gethash ntok *modifiers*) #'rel-set-modifier))
(t (error "The modifier ~a before ~a only applies to relative sets" ctok tok)))
ntok))
(dolist (ctok (list "t" "c"))
(add-modifier ctok #'rel-set-modifier))
(defmodifier "n" (n name)
(let ((ntok (format nil "~a ~a" n name)))
(pushnew ntok *sets* :test #'equal)
ntok))
(defmodifier "x" (n name)
(let ((ntok (format nil "~a ~a" n name)))
(pushnew ntok *sets* :test #'equal)
ntok))
(defmodifier "ov" (n name)
(declare (ignore n))
(let ((ntok (parse-integer name :radix 8)))
(pushnew ntok *sets* :test #'equal)
ntok))
(defmodifier "lo" (n name)
(let ((ntok (format nil "~a ~a" n name)))
(pushnew ntok *sets* :test #'equal)
ntok))
(defmodifier "pi" (n name)
(let ((ntok (format nil "~a ~a" n name)))
(pushnew ntok *sets* :test #'equal)
ntok))
(defmodifier "ir" (n name)
(let ((ntok (format nil "~a ~a" n name)))
ntok))
(defmodifier "ar" (n name)
(let ((ntok (format nil "~a ~a" n name)))
ntok))
(defmodifier "uo" (n name)
(declare (ignore n))
(pushnew name *sets* :test #'equal)
name)
;; relative sets
(defrel "l" (set)
set)
(defrel "no" (set)
`(mlp:differ ,set "o"))
(defstruct set-element
(super-set)
(count))
(defrel "a" (set)
`(mlp:unite (make-set-element :super-set ,set :count 1)))
(dolist (rel-set (list "te"
"pa"
"ca" "ci" "co"
"van"
"zu"
"ni" "na"
"if" "pov" "et"
"nun" "sun" "nur" "nec" "inf"
))
(add-rel-set rel-set t))
;; simple sets
(macroexpand-1 '(text* "
no uo o
uo i uo u uo ju uo jo uo vo uo juo
uo tis uo nav
uo ri uo ro uo ra uo faj
uo sej uo go
uo vat uo tat
uo par
or o
"))
;;;printing
(defmethod print-object ((element set-element) stream)
(with-slots (super-set) element
(format stream "[~a]" super-set)))
(defparameter *binary-symbol* (plist-hash-table '(mlp:imply " => "
mlp:differ " >< "
mlp:unite " | "
mlp:equal " = "
mlp:without "\\"
mlp:relate ": "
mlp:intersect " & "
mlp:count "; "
)
:test #'eq))
(defun print-binary (symbol &rest args)
(format nil (format nil "~~{~~a~~^~a~~}" symbol) args))
(defun eval-binary (name rest)
(let ((args (mapcar (lambda (arg)
(if (consp arg)
`(format nil "(~a)" ,arg)
arg))
rest)))
`(print-binary ,(gethash name *binary-symbol*) ,@args)))
(defmacro define-print-macros (&aux result)
(dolist (name (list 'mlp:imply 'mlp:differ 'mlp:unite 'mlp:equal 'mlp:relate 'mlp:intersect 'mlp:without 'mlp:count))
(push
`(defmacro ,name (&rest args)
(eval-binary ',name args))
result))
`(progn ,@result))
(eval '(define-print-macros))