Разбор (парсинг) строки.

oldlisper· original author: Paul.Alkhimov24.01.2011 12:29

Есть такой текстовый формат, OBJ.Я разбираю строку формата "f v1/vt1/vn1 v2/vt2/vn2 v3/vt3/vn3 ..." (в статье это называется "Vertex/texture-coordinate/normal"). Делаю я это вручную следующим кодом:
(defun parse-line (line prefix &key (type 'single-float))
  (and line
       (< (length prefix) (length line))
       (setf line (string-trim '(#\Space #\Tab)
                               (subseq line 0 (position #\# line))))
       (string/= "" line)
       (string= line prefix :end1 (length prefix) :end2 (length prefix))
       (let ((value (map 'list
                         #'(lambda(x)(when (numberp x) (coerce x type)))
                         (mapcar #'(lambda(x)(if (symbolp x)
                                                 (read-from-string (subseq (symbol-name x) 0 (position #\/ (symbol-name x))))
                                                 X))
                                 (read-from-string (concatenate 'string "(" (subseq line (length prefix) nil) ")"))))))
         (let ((value (delete-if #'null value)))
           (if (= 3 (length value))
               value
               (values (subseq value 0 3) ;; this splits quad 0-1-2-3 on tri 0-1-2 + tri 0-2-3
                      (list (car value) (caddr value) (cadddr value))))))))
Если интересно, вот код вызова.
У меня следующий вопрос к сообществу:
я в ужасе от читабельности и понятности кода, хотя этот код корректный.
Создавался код итеративно через REPL, постепенно усложняясь, отсюда и нагромождение вложенный вызовов.
Вопрос в следующем: как лучше решить такую задачу?
Меня интересует методика и, если можно, пример.
(Пожалуйста, не отсылайте меня в сторону таких примеров без комментариев. Я пробовал применить этот подход, но именно в этом примере доступ осуществляется на основе такой специфики данных, которой у меня нет: фиксированного размера полей и доступа к элементам строки через subseq. У меня размер, количество, и формат полей плавающий, поэтому я не могу так просто подойти к решению задачи.)

oldlisper· original author: Paul.Alkhimov24.01.2011 12:43

Какие-то товарищи применили ещё вот такой подход. Если коротко, подход такой (let ((sexp (read (sexp-stream line))))
     (case (car sexp)
           (v (dolist (x (cdr sexp)) ...)
           (f (dolist (x (cdr sexp)) ...)
           ...
Этот подход более простой за счёт того, что обрабатывает один частный случай данных. Мне он не подходит.

oldlisper· original author: archimag24.01.2011 12:46

> я в ужасе от читабельности и понятности кода
Выдели несколько вспомогательный функций, вместо map и mapcar юзай iterate, используй let* вместо let, делай правильные переносы, а не впихивай всё выражение в одну строчку. Читабельность улучшится.
А вообще, что у кода на базе s-выражений есть проблемы с читабельностью, как бы не секрет и всем об этом говорят, но некоторые пытаются отрицать ))

oldlisper· original author: Paul.Alkhimov24.01.2011 12:51

в одну строчку делал для сайта. у меня больше строк

oldlisper· original author: allchemist24.01.2011 20:23

> А вообще, что у кода на базе s-выражений есть проблемы с читабельностью, как бы не секрет и всем об этом говорят, но некоторые пытаются отрицать ))

Ну от формы записи зависит далеко не все, можно и на, образно говоря, брейнфаке написать понятно, а можно и на лиспе запутать так, что получится сплошной брейнфак. :)

В любом случае, вычленение функций / разбиение на части / отступы и переносы сильно улучшают читабельность.

> в одну строчку делал для сайта. у меня больше строк

То есть, чтобы форумчяне помучились? _(шутка)

oldlisper· original author: Ander Skirnir25.01.2011 01:31

Я бы сделал как-то так:
(defun nths (list &rest positions)
  (mapcar (lambda (n) (nth n list))
          positions))
(defun parse-line (line prefix &key (type 'single-float))
  (let ((prefix-len (length prefix)))
    (when (and line (< prefix-len (length line)))
      (setq line
            (string-trim '(#\Space #\Tab)
                         (subseq line 0
                                 (position #\# line))))
      (when (and (string/= "" line)
                 (string= line prefix
                          :end1 #1=prefix-len
                          :end2 #1#))
        (let ((value
               (mapcan (lambda (x)
                         (when (symbolp x)
                           (setq x (read-from-string
                                    (subseq #2=(symbol-name x) 0
                                            (position #\/ #2#)))))
                         (when (numberp x)
                           (list (coerce x type))))
                       (read-from-string
                        (concatenate 'string "("
                                     (subseq line prefix-len nil)
                                     ")")))))
          (if (= (length value 3)) value
              (values (nths value 0 1 2)
                      (nths value 0 2 3))))))))
В алгоритм не вдумывался, набросал субъективные чисто-стилистические соображения.
Частое iterate - очень на любителя. Кстати, там дыра есть - он генерирует tagbody с interned-символами.

oldlisper· original author: archimag25.01.2011 11:11

Та всё равное не очень ) Этот код без привлечения абстракций более высокого уровня "читаемым" не сделаешь.

> Кстати, там дыра есть - он генерирует tagbody с interned-символами.
И?

oldlisper· original author: Paul.Alkhimov25.01.2011 14:16

> То есть, чтобы форумчяне помучились?та просто мне показалось, что вертикальная колбаса - это некрасиво. короче, минутная слабость :) а потом просто забыл поправить.

oldlisper· original author: Paul.Alkhimov25.01.2011 14:21

Ну... да, я понял идею. Но это всё, как мне кажется, почти одно и то же.Вот моя текущая версия, кстати:
(defun parse-line (line prefix &key (type 'single-float))
  (flet ((crop-line (source &key (end #\/))
           (if (symbolp source)
               (read-from-string (subseq (symbol-name source)
                                         0
                                         (position end (symbol-name source))))
               source))
         (line-to-list (line)
           (read-from-string (concatenate 'string
                                          "("
                                          (subseq line (length prefix))
                                          ")")))
         (cast_number (x)
           (if (numberp x)
               (coerce x type)
               x)))
    (and line
         (< (length prefix) (length line))
         (setf line (string-trim '(#\Space #\Tab) (crop-line line :end #\#)))
         (string/= "" line)
         (string= line prefix :end1 (length prefix) :end2 (length prefix))
         (let ((value (delete-if #'null (map 'list #'cast_number (mapcar #'crop-line (line-to-list line))))))
           (if (= 3 (length value)) ;; this splits quad 0-1-2-3 on tri 0-1-2 + tri 0-2-3
              value
               (values (subseq value 0 3)
                       (list (car value) (caddr value) (cadddr value))))))))
Я хочу найти подход, принципиально укорачивающий код.

oldlisper· original author: LinkFly25.01.2011 14:41

Между делом про форматирование:
Это
((value (delete-if #'null (map 'list #'cast_number (mapcar #'crop-line (line-to-list line))))))
Лучше смотрелось бы так:

((value (delete-if #'null
                   (map 'list
                        #'cast_number
                        (mapcar #'crop-line
                                (line-to-list line))))))
Логику может быть попозже разберу.

oldlisper· original author: Paul.Alkhimov25.01.2011 17:39

Вот последняя версия. Всё, что я смог придумать - это две вещи: обработка слэша "/" как пробела (set-syntax-from-char) и управление логикой с помощью typecase:
(defun parse-line (line prefix &key (type 'single-float))
  (declare (optimize (debug 3)))
  (flet ((unpack (str &key (char #\/))
           (let ((*readtable* (copy-readtable)))
             (when char ;; we make the given char a delimiter (space)
              (set-syntax-from-char char #\Space))
             (typecase str
               (number (coerce str type))
               (list (car str))
               (symbol (car (read-from-string (concatenate 'string
                                                           "(" (symbol-name str) ")"))))
               (string (read-from-string (concatenate 'string
                                                      "(" str ")")))))))
    (and line
         (setf line (string-trim '(#\Space #\Tab)
                                 (subseq line 0 (position #\# line))))
         (< (length prefix) (length line))
         (string= line prefix :end1 (length prefix) :end2 (length prefix))
         (setf line (subseq line (length prefix)))
         (let ((value (delete-if #'null
                                 (map 'list
                                      #'unpack
                                      (mapcar #'unpack
                                              (unpack line :char nil))))))
           (if (= 3 (length value)) ;; this splits quad 0-1-2-3 on tri 0-1-2 + tri 0-2-3
              value
               (values (subseq value 0 3)
                       (list (car value)
                             (caddr value)
                             (cadddr value))))))))
При этом побочным эффектом стало усложнение внутреннего протокола: для некоторых случаев внутренняя функция unpack возвращает список, для некоторых же - значение.Короче говоря, это мне кажется пределом.
Что же касается логики, то она следующая:
есть строка вида "v 0 1 2 #comment".
я отрезаю комментарий, потом отрезаю префикс, если он совпадает, а потом разбираю строку
строка может быть "0 1 2", а может быть "0/0/0 1/1/1 2/2/2"
в первом случае, значения меня устраивают, а во втором мне надо отгрызть первые числа из каждой группы со слэшами. То есть для группы 123/432/17645 я должен получить 123.
Собственно, я читаю остаток строки, где нет комментария и префикса с помощью read-from-string и для обычного случая уже получаю результат, а для случая со слэшами получаются символы, где я заново запускаю тот же разбор на строковое имя символа, но при этом подменяю слэш пробелом. Как-то так...

oldlisper· original author: Paul.Alkhimov25.01.2011 18:10

Рекурсия победила:
(defun parse-line (line prefix &key (type 'single-float))
  (declare (optimize (debug 3)))
  (labels ((rfs (what)
             (read-from-string (concatenate 'string "(" what ")")))
           (unpack (str &key (char #\/) (n 0))
             (let ((*readtable* (copy-readtable)))
               (when char ;; we make the given char a delimiter (space)
                (set-syntax-from-char char #\Space))
               (typecase str
                 ;; string -> list of possibly symbols.
                ;; all elements are preserved by (map). nil's are dropped
                (string (delete-if #'null
                                    (map 'list
                                         #'unpack
                                         (rfs str))))
                 ;; symbol -> list of values
                (symbol (unpack (rfs (symbol-name str))))
                 ;; list -> value (only the requested one)
                (list (unpack (nth n str)))
                 ;; value -> just coerce to type
                (number (coerce str type))))))
    (and line
         (setf line (string-trim '(#\Space #\Tab)
                                 (subseq line 0 (position #\# line))))
         (< (length prefix) (length line))
         (string= line prefix :end1 (length prefix) :end2 (length prefix))
         (setf line (subseq line (length prefix)))
         (let ((value (unpack line :char nil)))
           (case (length value)
               (3 value)
               (4 (values (subseq value 0 3) ;; split quad 0-1-2-3 on tri 0-1-2 + tri 0-2-3
                         (list (car value)
                                (caddr value)
                                (cadddr value)))))))))
Однако, вопрос остался. Можно ли это сделать как-то проще?
Принципиально проще.

oldlisper· original author: treep26.01.2011 15:53

> Вопрос в следующем: как лучше решить такую задачу?
> Меня интересует методика и, если можно, пример.
Обычно (когда вещей вроде ручных subseq или регулярок уже не хватает) используют какую-либо библиотеку генераторов парсеров - на основе LALR, PEG и тому подобных грамматик. Например есть cl-yacc (и пример там же), с его использованием разбор таких строк будет выглядеть примерно так:
;;;; (ql:quickload "yacc")
;;;; (require :yacc)

(defpackage #:obj-format
  (:use     #:common-lisp
            #:yacc)
  (:export #:lexer
            #:*parser*
            #:obj-repl))
(in-package #:obj-format)
;;;; The lexer.
;;; lexer conditions
;;;
(define-condition obj-lexer-error (yacc-runtime-error)
  ((character :initarg :character :reader lexer-error-character))
  (:report (lambda (e stream)
             (format stream "OBJ lexing failed~@[: unexpected character ~S~]"
                     (lexer-error-character e)))))
(defun obj-lexer-error (char)
  (error (make-condition 'obj-lexer-error :character char)))
;;; special readers
;;;
(defun maybe-unread (char stream)
  (when char
    (unread-char char stream)))
(defun read-integer (stream)
  (let (result)
    (loop
      (let ((char (read-char stream nil nil)))
        (when (or (null char) (not (digit-char-p char)))
          (maybe-unread char stream)
          (when (null result)
            (obj-lexer-error char))
          (return-from read-integer result))
        (setf result (+ (* (or result 0) 10)
                        (- (char-code char) (char-code #\0))))))))
(defun skip-commentaries (stream)
  (loop
    (let ((char (read-char stream nil nil)))
      (when (or (char= char #\Newline) (null char))
        (return-from skip-commentaries)))))
;;; lexer main function
;;;
(defun lexer (&optional (stream *standard-input*))
  (loop
    (let ((char (read-char stream nil nil)))
            ;; skip whitespaces
     (cond ((member char '(#\Space #\Tab)))
            ;; newlines and EOF
           ((member char '(nil #\Newline))
             (return-from lexer (values nil nil)))
            ;; commentaries
           ((char= char #\#)
             (skip-commentaries stream)
             (return-from lexer (values nil nil)))
            ;; slash (`/') delimiter
           ((member char '(#\/))
             (let ((symbol (intern (string char) '#.*package*)))
               (return-from lexer (values symbol symbol))))
            ;; `f' prefix
           ((char= char #\f)
             (return-from lexer (values 'f #\f)))
            ;; and numbers
           ((digit-char-p char)
             (unread-char char stream)
             (return-from lexer (values 'number (read-integer stream))))
            ;; error situation there
           (t
             (obj-lexer-error char))))))
;;;; The parser.

;;; semantic rules
;;;
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun expression (expression)
    `(:expression ,expression))
  (defun face-definition (f tokens)
    (declare (ignore f))
    (labels ((flatten-this (list)
               (if (atom (first list))
                   (when list
                     (list list))
                   (if (atom (first (first list)))
                       (cons (first list) (flatten-this (rest list)))
                       (flatten-this (first list))))))
      `(:face-definition ,@(flatten-this tokens))))
  (defun vertex (vertex)
    `(:vertex ,vertex))
  (defun vertex/texture-coordinate (vertex /1 texture-coordinate)
    (declare (ignore /1))
    `(:vertex/texture-coordinate ,vertex ,texture-coordinate))
  (defun vertex/texture-coordinate/normal (vertex /1 texture-coordinate /2 normal)
    (declare (ignore /1 /2))
    `(:vertex/texture-coordinate/normal ,vertex ,texture-coordinate ,normal))
  (defun vertex/normal (vertex /1 /2 normal)
    (declare (ignore /1 /2))
    `(:vertex/normal ,vertex ,normal))
) ;;; semantic rules
;;; define parser
;;;
(define-parser *parser*
  (:start-symbol expression)
  (:terminals (number / f)) ;; and others

  (expression
   (face-definition #'expression)
   ;; etc.
  )
  (face-definition
   (f face-definition-1 #'face-definition)
   (f face-definition-2 #'face-definition)
   (f face-definition-3 #'face-definition)
   (f face-definition-4 #'face-definition))
  (face-definition-1
   (vertex face-definition-1)
   vertex)
  (face-definition-2
   (vertex/texture-coordinate face-definition-2)
   vertex/texture-coordinate)
  (face-definition-3
   (vertex/texture-coordinate/normal face-definition-3)
   vertex/texture-coordinate/normal)
  (face-definition-4
   (vertex/normal face-definition-4)
   vertex/normal)
  (vertex
   (number #'vertex))
  (vertex/texture-coordinate
   (number / number #'vertex/texture-coordinate))
  (vertex/texture-coordinate/normal
   (number / number / number #'vertex/texture-coordinate/normal))
  (vertex/normal
   (number / / number #'vertex/normal)))
;;;; Simple REPL.

(defun obj-repl (&optional (stream *standard-input*))
  (let ((*standard-input* stream))
    (format t "Type an obj-expression.~%~%")
    (loop
      (with-simple-restart (abort "Return to OBJ-REPL toplevel.")
        (format t "> ")
        (let ((obj-expr (parse-with-lexer #'lexer *parser*)))
          (when (null obj-expr)
            (return-from obj-repl))
          (format t "< ~A~%" obj-expr))))))
;;;; Examples.
#|
OBJ-FORMAT> (obj-repl)
Type an obj-expression.
> q
OBJ lexing failed: unexpected character #\q
   [Condition of type OBJ-LEXER-ERROR]
Unexpected terminal NIL (value NIL). Expected one of: (F)
   [Condition of type YACC-PARSE-ERROR]
> f
Unexpected terminal NIL (value NIL). Expected one of: (NUMBER)
   [Condition of type YACC-PARSE-ERROR]
> f 1
< (EXPRESSION (FACE-DEFINITION (VERTEX 1)))
> f 1 2 3
< (EXPRESSION (FACE-DEFINITION (VERTEX 1) (VERTEX 2) (VERTEX 3)))
> f 1/2 3/4
< (EXPRESSION
    (FACE-DEFINITION (VERTEX/TEXTURE-COORDINATE 1 2)
                     (VERTEX/TEXTURE-COORDINATE 3 4)))
> f 1 1/2
Unexpected terminal / (value /). Expected one of: (NUMBER NIL)
   [Condition of type YACC-PARSE-ERROR]
Unexpected terminal NUMBER (value 2). Expected one of: (F)
   [Condition of type YACC-PARSE-ERROR]
Unexpected terminal NIL (value NIL). Expected one of: (F)
   [Condition of type YACC-PARSE-ERROR]
> f 1/2/3 4/5/6 # comments...
< (EXPRESSION
    (FACE-DEFINITION (VERTEX/TEXTURE-COORDINATE/NORMAL 1 2 3)
                     (VERTEX/TEXTURE-COORDINATE/NORMAL 4 5 6)))
|#
и дальше расширять до полного парсера этих OBJ файлов тоже довольно легко - просто добавляются правила в грамматику и/или новые условия к лексеру. И таким способом (LALR(1) грамматики + лексер) можно разбирать довольно большой класс языков (уровня Си, например).

oldlisper· original author: treep26.01.2011 16:03

oldlisper· original author: Paul.Alkhimov26.01.2011 16:47

Вот это уже очень интересно.Мне кажется, что этот вариант самый многообещающий для DSL c отличным от лиспа синтаксисом.
Хотя стартовые затраты впечатляют...
Попробую разобраться.
Спасибо!