;==================================================
;
; свертка/развертка системы текстов
; текст представлен списком
;((Имя Вариант ...)...)
; первое имя в свертке - обозначение системы текстов
;      (Элемент ...)
;      (Имя Лексема (Варианты))
; ((пример (ма (ш н)
;          (ш а) )
;      ( ш н ) )
; ((н ина)) )
;==================================================
; реализация свертки: unic, ass-all, swin, gram, bnf

(defun unic (vac) (remove-duplicates (mapcar ’car vac) ))
;; список уникальных начал

(defun ass-all (Key Vac)
;; список всех вариантов продолжения (что может идти за ключом)
    (cond
       ((Null Vac) Nil)
       ((eq (caar Vac) Key) (cons (cdar Vac)
          (ass-all Key (cdr Vac)) ))
       (T (ass-all Key (cdr Vac)) )
) )

(defun swin (key varl) (cond
;; очередной шаг свертки или снять скобки при отсутствии вариантов
    ((null (cdr varl))(cons key (car varl)))
    (T (list key (gram varl)) )
))

(defun gram (ltext)
;; левая свертка, если нашлись общие начала
    ( (lambda (lt) (cond
        ((eq (length lt)(length ltext)) ltext)
        (T (mapcar
            #’(lambda (k) (swin k (ass-all k ltext ) ))
               lt )
    ) ) ) (unic ltext)
) )

(defun bnf (main ltext binds) (cons (cons main (gram ltext)) binds))
;; приведение к виду БНФ

;===================================================
; реализация развертки: names, words, lexs, d-lex, d-names,
;      h-all, all-t, pred, sb-nm, chain, level1, lang

(defun names (vac) (mapcar ’car vac))
;; определяемые символы

(defun words (vac) (cond
;; используемые символы
    ((null vac) NIL)
    ((atom vac) (cons vac NIL ))
    (T (union (words(car vac)) (words (cdr vac)))) ))
   
(defun lexs (vac) (set-difference (words vac) (names vac)))
;; неопределяемые лексемы

(defun d-lex ( llex)
;; самоопределение терминалов
     (mapcar #’(lambda (x) (set x x) ) llex) )
(defun ( llex)

;; определение нетерминалов
     (mapcar #’(lambda (x) (set (car x )(cdr x )) ) llex) )
    
(defun h-all (h lt)
;; подстановка голов
     (mapcar #’(lambda (a)
        (cond
           ((atom h) (cons h a))
           (T (append h a)) )
      ) lt) )
     
(defun all-t (lt tl)
;; подстановка хвостов
     (mapcar #’(lambda (d)
        (cond
           ((atom d) (cons d tl))
           (T(append d tl))
       ) ) lt) )
       
(defun pred (bnf tl)
;; присоединение предшественников
    (level1 (mapcar #’(lambda (z) (chain z tl )) bnf) ))
    
(defun sb-nm (elm tl)
;; постановка определений имен
(cond
   ((atom (eval elm)) (h-all (eval elm) tl))
   (T (chain (eval elm) tl))
) )

(defun chain (chl tl)
;; сборка цепочек
    (cond
       ((null chl) tl)
       ((atom chl) (sb-nm chl tl))
       
       ((atom (car chl))
           (sb-nm (car chl) (chain (cdr chl) tl) ))
          
       (T (pred (all-t (car chl) (cdr chl)) tl)) ))
       
(defun level1 (ll)
;; выравнивание
(cond
((null ll)NIL)
(T (append (car ll) (level1 (cdr ll)) )) ))

(defun lang ( frm )
;; вывод заданной системы текстов
(d-lex (lexs frm))
(d-names frm)
(pred (eval (caar frm)) ’(())
) )