misc:software:Common Lisp:sbcl:テキストに含まれている角括弧内の情報を展開する

テキストに含まれている角括弧内の情報を展開する

使用例

(mapc #'(lambda (x)
          (print-text-with-expansion x
                                     :pre-text ";;-> "))
      '("http://example.com/[8-10]/"
        "http://example.com/[08-10]/"
        "http://example.com/[008-010]/"))

(progn 
  (princ ";;->")
  (mapc #'(lambda (x)
            (print-text-with-expansion x 
                                       :pre-text " "
                                       :terprip nil))
        '("[あ-の]")))

(progn 
  (princ ";;->")
  (mapc #'(lambda (x)
            (print-text-with-expansion x 
                                       :pre-text " "
                                       :terprip nil))
        '("[A-Z]")))

(progn 
  (princ ";;->")
  (mapc #'(lambda (x)
            (print-text-with-expansion x 
                                       :pre-text " "
                                       :terprip nil))
        '("[a-z]")))

ソース

(ql:quickload :cl-ppcre)

(defun number->string (n &optional (figure 1))
  (format nil "~V,1,,'0@A" figure n))

(defun string->char-code (x)
  (char-code (coerce x 'character)))

(defun char-code->string (n)
  (string (code-char n)))

(defun parse-text-by-square-bracket (text)
  (let ((pattern "^(.*?)\\[(\\d+|\\S)-(\\d+|\\S)\\](.*?)$"))
    (labels ((rec (acc next)
               (cond ((null next) next)
                     ((ppcre:scan pattern next)
                      (ppcre:register-groups-bind (pre start end post)
                          (pattern next)
                        (let* ((number-mode (and (numberp (read-from-string start))
                                                 (numberp (read-from-string end))))
                               (fn-for-start-and-end (if number-mode
                                                         #'read-from-string
                                                         #'string->char-code))
                               (fn-for-each-elem (if number-mode
                                                     #'number->string
                                                     #'(lambda (a b) (char-code->string a)))))
                          (rec (cons (loop for n
                                        from (funcall fn-for-start-and-end start)
                                        to (funcall fn-for-start-and-end end)
                                        collect (funcall fn-for-each-elem n (length start)))
                                     (cons pre acc))
                               post))))
                     (t (reverse (cons next acc))))))
      (rec nil text))))


(defun print-with-expansion (lst &key (terprip t) (pre-text "") (post-text ""))
  ;; scheme ver. http://toro.2ch.net/test/read.cgi/tech/1327819028/241
  ;; cl ver. http://paste.lisp.org/display/128244
  (labels ((rec (acc next)
             (cond
               ((null next)
                (princ pre-text)
                (mapc #'princ (reverse acc))
                (princ post-text)
                (when terprip (terpri)))
               ((consp (car next))
                (mapc (lambda (x)
                        (rec (cons x acc) (cdr next)))
                      (car next)))
               (t
                (rec (cons (car next) acc) (cdr next))))))
    (rec nil lst)))


(defun print-text-with-expansion (text &key (terprip t) (pre-text "") (post-text ""))
  (print-with-expansion (parse-text-by-square-bracket text)
                        :terprip terprip
                        :pre-text pre-text
                        :post-text post-text))

(defmacro aif (test then &optional else)
  `(let ((it ,test))
     (if it ,then ,else)))

(defun member-equal (x lst)
  (member x lst :test #'equal))

(defun next-item (x lst)
  (cadr (member-equal x lst)))

(defun remove-option (lst rm-lst)
    (labels ((rec (acc next)
               (cond
                 ((null next) (reverse acc))
                 ((member-equal (car next) rm-lst)
                  (rec acc (cddr next)))
                 (t (rec (cons (car next) acc) (cdr next))))))
      (rec nil lst)))

(sb-ext:save-lisp-and-die "print-text-with-expansion.exe"
                          :toplevel #'(lambda ()
                                        (let* ((args (cdr sb-ext:*posix-argv*))
                                               (terprip (null (aif (next-item ":no-terpri" args) (read-from-string it))))
                                               (pre-text (aif (next-item ":pre" args) it ""))
                                               (post-text (aif (next-item ":post" args) it "")))
                                          (mapc #'(lambda (x)
                                                    (print-text-with-expansion x
                                                                               :terprip terprip
                                                                               :pre-text pre-text
                                                                               :post-text post-text))
                                                (remove-option args '(":no-terpri" ":pre" ":post")))))
                          :compression t
                          :executable t)