extract.lisp

#|
 | Event extract script
 |
 | Copyright (c) 2018, LdBeth Wang
 | All rights reserved.
 |
 | Redistribution and use in source and binary forms, with or without
 | modification, are permitted provided that the following conditions are
 | met:
 |
 | Redistribution of source code must retain the above copyright notice,
 | this list of conditions and the following disclaimer.  Redistribution
 | in binary form must reproduce the above copyright notice, this list of
 | conditions and the following disclaimer in the documentation and/or
 | other materials provided with the distribution.  THIS SOFTWARE IS
 | PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY
 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
 | PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
 | CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
 | EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
 | PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
 | PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.)
 |
 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^|#

(ql:quickload :cl21)
(ql:quickload :cl-base64)

(in-package :cl21-user)
(use-package :cl21.re)

;;(defvar *file*)

(defparameter *index-output* #P"~/Desktop/foo.txt")

(defun explain ()
  (format t "~{# ~A~%~}"
          '("这是自动生成的文件，请不要把格式玩坏。"
            "``#'' 号开头的行是参考文本。"
            "请把对应的翻译文本填入两行 ``@'' 号之间。"
            "控制字符请照抄。"
            "整段重复的文本只要填一次，其它地方可直接留空。"
            "有问題找工作群的 @東方記者"))
  (dotimes (i 2)
    (princ #"\n")))

(defmacro safe-1st (array)
  `(if ,array
       (elt (nth-value 1 ,array) 0)
       nil))

(declaim (inline find-name print-name print-name*
                 read-dialog print-dialog
                 search-sep))

(defun find-name (string)
  (safe-1st (#/\s?◆文章 :(.+)：/ string)))

(defun print-name (name)
  (format t "\"~A\"=\"\"~%" name))

(defun print-name* (name)
  (format t "# -- ~A~%" name))

(defun read-dialog (string)
  (safe-1st (#/^[ \|　]{2,}:([^◇]\S+)\s*/ string)))


(defun print-dialog (stream)
  (format t ":\"~A\"~%@~%@~%~%" (get-output-stream-string stream)))

(defun search-sep (string)
  (safe-1st (#/地图(ID: \d+)\s/ string)))

(defun index (filename)
  (declare (inline find))
  (with-open-file (in filename
                      :direction :input)
    (with-open-file (*standard-output* *index-output*
                                       :direction :output
                                       :if-does-not-exist :create
                                       :if-exists :supersede)

      ;; Explain first.
      (explain)

      (let ((name-dic (make-hash-table :test 'equal :size 220))
            *string*
            *state*)
        ;; Make dynamic binding.
        (declare (special *string* *state*))

        (loop for field = (read-line in nil)
              while field
              do (let* ((name (if *state*
                                  nil
                                  (find-name field)))
                        (dialog (if name
                                    nil
                                    (read-dialog field)))
                        (sep (if (not (or name dialog))
                                 (search-sep field))))

                   (cond (sep (format t "# ~A~%# ------~%" sep))
                         (name (if (gethash name-dic name)
                                   (print-name* name)
                                   (progn (setf (gethash name-dic name) t)
                                          (print-name name))))
                         ;; set enter dialog state
                         ((and dialog (not *state*))
                          (setf *state* t)
                          (setf *string* (make-string-output-stream)))
                         ((and *state* (not dialog))
                          (setf *state* nil)
                          (print-dialog *string*)))
                   (when (and *state* dialog)
                     (princ #"${dialog}\n" *string*))))))))



(defparameter *final-output* #P"~/Desktop/pp.txt")

(defparameter *line-width* 40)

(defvar *buffer*)
(defvar *replacement*)
#|
(defclass replace ()
  ((match :initarg :match)
   (content :initarg :content)))

(defclass name-replace (replace) nil)

(defclass content-replace (replace) nil)

(defclass poem-replace (replace) nil)
|#
(defparameter *name-regexp* "◆文章 :(\\S+)：")
(defparameter *name-match-regexp* #/\"(.+)\"=\"(.+)\"/ )
(defparameter *field-match-regexp* #/:\"(\S+).*\"\n@\n(.+)\n@/s )
;; (defparameter *field-base* "(?m)^([         \|　　　 ]):~A\\S*[\\n[\\s\|　]+:\\S+]*")
(defparameter *field-base*
  "(?sm)^([ \|　]+):~A.*?\\n([　]?)◆")
;; (defconstant +context-regexp+ "\\S+[\\n[\\s\|　]+:\\S+]*")
;;(defmethod )
;; (re-replace ":那个莫名其\\S+[\\n[\\s\|　]+:\\S+]*" *buffer* ":ss" :global t)

;; (defconstant)

(defun print-content (indent end list)
  (format nil #"~{${indent}:~A~%~}${end}◆" list))

(defun read-input (infile)
  (with-open-file (in infile
                      :direction :input)
    (let ((content (make-string (file-length in))))
      (read-sequence content in)
      (setf *buffer* (string-right-trim '(#\Null) content))
      (values))))

(defun binary-find-entry (item vector
                          &key
                            (predicate #'<) (test #'eql))
  "Return found entry and index number."
  (declare (simple-vector vector))
  (labels ((find-elt (low up)
             (declare (fixnum low up))
             (let* ((med (ash (+ up low) -1))
                    (cur (elt vector med)))
               (cond
                 ((funcall test item cur)
                  (values cur med))
                 ((= low up)
                  (values nil med))
                 ((funcall predicate item cur)
                  (find-elt low med))
                 (t
                  (find-elt (1+ med) up))))))
    (find-elt 0 (1- (length vector)))))

(defun greedy-wrap (str width)
  (setq str (concatenate 'string str " ")) ; add sentinel
  (do* ((len (length str))
        (lines nil)
        (begin-curr-line 0)
        (prev-space 0 pos-space)
        (pos-space (position #\Space str)
                   (when (< (1+ prev-space)
                            len)
                     (position #\Space str :start (1+ prev-space)))))

       ((null pos-space)
        (progn (push (subseq str begin-curr-line (1- len))
                     lines)
               (nreverse lines)))
    (when (> (- pos-space begin-curr-line) width)
      (push (subseq str begin-curr-line prev-space) lines)
      (setq begin-curr-line (1+ prev-space)))))

(defun vector-to-list (vector)
  (cl:map 'list #'identity vector))

(defun strip-comments (str)
  (re-replace #/#.*$/mg str ""))

(defun parse-dialog-entry (str)
  (let ((table (make-hash-table :test 'equal)))
    (cl:mapc ^(let ((x (nth-value 1 (funcall *field-match-regexp* %))))
                (when (= 2 (length x))
                 (setf (gethash table (elt x 0)) (elt x 1))))
             (ppcre:all-matches-as-strings
              "(?s):\"[^@]*?\n\"\n@\n.+?\n@" str))
    table))

(defun parse-name-entry (str)
  (apply #'hash-table 'equal
         (apply #'(compose vector-to-list concatenate) 'vector
                (cl:map 'list ^(nth-value 1 (funcall *name-match-regexp* %))
                        (ppcre:all-matches-as-strings
                         "\".+\"=\".+\"" str)))))

(defun do-name-replace (str table)
  (ppcre:regex-replace-all *name-regexp*
                           str
                           ^(format nil "◆文章 :~A:" (gethash table %2))
                           :simple-calls t))

(defun do-dialog-replace (str table)
  (let ((var (copy-array str)))
    (cl:maphash
     #'(lambda (key val)
         (setf var (ppcre:regex-replace-all
                    (format nil *field-base* (ppcre:quote-meta-chars key))
                    var
                    ^(print-content
                      %2 %3
                      (flatten
                       (map #'(lambda (x) (ppcre:split "\n" x))
                            (greedy-wrap val *line-width*))))
                    :simple-calls t)))
     table)
    var))

#|
(defun intellectual-wrap-english (str)
  (let ((proper-list ()))
    ;;(setq str (concatenate 'string str " "))
    #|first match if control code, if true then make a index to record property.
    then arrange with greedy-wrap, then recover property, then print|#))

(defun wrap-with-control (string)
  nil)
|#

(defun inject (input source)
  (read-input input)
  (setf *buffer* (strip-comments *buffer*))
  (let ((name-table (parse-name-entry *buffer*))
        (dialog-table (parse-dialog-entry *buffer*)))
    (read-input source)
    (setf *buffer* (do-name-replace *buffer* name-table))
    (setf *buffer* (do-dialog-replace *buffer* dialog-table))
    (with-open-file (*standard-output* *final-output*
                                       :direction :output
                                       :if-does-not-exist :create
                                       :if-exists :supersede)
      (princ *buffer*)))
  nil)




(defun base64-to-utf8 (string)
  (decode-string-from-octets
   (cl-base64:base64-string-to-usb8-array string)
   :external-format :utf-8))

;;  LocalWords:  binding