Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- #|
- | 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)
- (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* #/:\"(.{1,5}).*\"\n=\"(.+)\"/ )
- ;; (defparameter *field-base* "(?m)^([ \| ]):~A\\S*[\\n[\\s\| ]+:\\S+]*")
- (defparameter *field-base* "( ):~A\\S*[\\n :\\S+]*?\\n◆")
- ;; (defconstant +context-regexp+ "\\S+[\\n[\\s\| ]+:\\S+]*")
- ;;(defmethod )
- ;; (re-replace ":那个莫名其\\S+[\\n[\\s\| ]+:\\S+]*" *buffer* ":ss" :global t)
- ;; (defconstant)
- (defun print-content (indent list)
- (format nil #"~{${indent}:~A~%~}◆" 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* %))))
- (setf (gethash table (elt x 0)) (elt x 1)))
- (ppcre:all-matches-as-strings
- ":\".*\"\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 (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)
- (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)
- ;; LocalWords: binding
Add Comment
Please, Sign In to add comment