Initial commit.

microdvd.lisp

@@ -0,0 +1,56 @@
+;;; -*- Mode: Lisp -*-
+
+;;; This software is in the public domain and is
+;;; provided with absolutely no warranty.
+
+(in-package #:subtitles.microdvd)
+
+(defun read-integer (stream stop-character)
+  (loop for char = (read-char stream)
+        for digit = (digit-char-p char)
+        while digit
+        for result = digit then (+ (* result 10) digit)
+        finally (progn
+                  (assert (char= stop-character char))
+                  (return result))))
+
+(defun read-frame-number (stream)
+  (assert (char= (read-char stream) #\{))
+  (read-integer stream #\}))
+
+(defun read-text (stream)
+  (read-line stream))
+
+(defun read-frame (stream)
+  (let ((frame (make-instance 'frame)))
+    (with-slots (text start-time end-time) frame
+      (setf start-time (read-frame-number stream)
+            end-time (read-frame-number stream)
+            text (read-text stream))
+      frame)))
+
+(defun write-frame-number (frame stream)
+  (format stream "{~a}{~a}"
+          (start-time frame)
+          (end-time frame)))
+
+(defun write-frame (frame stream)
+  (write-frame-number frame stream)
+  (write-line (text frame) stream))
+
+(defmethod read-subtitles ((type (eql 'microdvd)) stream)
+  (make-instance 'subtitles :contents
+                 (loop while (listen stream)
+                       collect (read-frame stream))))
+
+(defmethod write-subtitles ((type (eql 'microdvd)) subtitles stream)
+  (loop for frame in (contents subtitles)
+        do (write-frame frame stream)))
+
+(defmethod external-format ((type (eql 'microdvd))
+                            &optional (encoding *default-encoding*))
+  (flex:make-external-format encoding :eol-style :crlf))
+
+(register-type 'microdvd
+               (lambda (file-name)
+                 (equalp (pathname-type file-name) "sub")))

packages.lisp

@@ -0,0 +1,25 @@
+;;; -*- Mode: Lisp -*-
+
+(defpackage #:subtitles
+  (:use #:cl)
+  (:export #:subtitles
+           #:frame
+           #:read-subtitles
+           #:write-subtitles
+           #:external-format
+           #:register-type
+           #:load-subtitle
+           #:save-subtitle
+           #:encode-time
+           #:decode-time
+           #:contents
+           #:text
+           #:start-time
+           #:end-time
+           #:*default-encoding*))
+
+(defpackage #:subtitles.subrip
+  (:use #:cl #:subtitles))
+
+(defpackage #:subtitles.microdvd
+  (:use #:cl #:subtitles))

subrip.lisp

@@ -0,0 +1,85 @@
+;;; -*- Mode: Lisp -*-
+
+;;; This software is in the public domain and is
+;;; provided with absolutely no warranty.
+
+(in-package #:subtitles.subrip)
+
+(defun parse-time (string &optional (shift 0))
+  "01:36:54,873 => milliseconds"
+  (let ((spec '((0 2  #\: #.(* 60 60 1000))
+                (3 5  #\: #.(* 60 1000))
+                (6 8  #\, 1000)
+                (9 12 nil 1))))
+    (loop for (start end separator ms) in spec
+          sum (* ms
+                 (parse-integer string
+                                :start (+ start shift)
+                                :end (+ end shift)))
+          while separator
+          do (assert (eql separator (char string (+ end shift)))))))
+
+(defun read-time (stream)
+  (let* ((string (read-line stream))
+         (arrow-end (+ (search " --> " string)
+                       (length " --> "))))
+    (values (parse-time string)
+            (parse-time string arrow-end))))
+
+(defun read-text (stream)
+  (with-output-to-string (result)
+    (loop with prev-char = #\Newline
+          for char = (read-char stream nil)
+          until (or (null char)
+                    (char= prev-char char #\Newline))
+          do (write-char char result)
+          (setf prev-char char))
+    result))
+
+(defun read-frame (stream)
+  (assert (integerp (parse-integer (read-line stream))))
+  (let ((frame (make-instance 'frame)))
+    (with-slots (text start-time end-time) frame
+      (setf (values start-time end-time) (read-time stream)
+            text (read-text stream))
+      frame)))
+
+(defun write-time (ms stream)
+  (multiple-value-bind (h m s ms) (decode-time ms)
+    (let ((spec `((2 #\: ,h)
+                  (2 #\: ,m)
+                  (2 #\, ,s)
+                  (3 nil ,ms))))
+     (loop for (digits separtor value) in spec
+           do (format stream "~v,,,'0@a" digits value)
+           when separtor do (write-char separtor stream)))))
+
+(defun write-timings (frame stream)
+  (write-time (start-time frame) stream)
+  (write-string " --> " stream)
+  (write-time (end-time frame) stream)
+  (terpri stream))
+
+(defun write-frame (frame n stream)
+  (format stream "~a~%" n)
+  (write-timings frame stream)
+  (write-line (text frame) stream)
+  (terpri stream))
+
+(defmethod read-subtitles ((type (eql 'subrip)) stream)
+  (make-instance 'subtitles :contents
+                 (loop while (listen stream)
+                       collect (read-frame stream))))
+
+(defmethod write-subtitles ((type (eql 'subrip)) subtitles stream)
+  (loop for number from 1
+        for frame in (contents subtitles)
+        do (write-frame frame number stream)))
+
+(defmethod external-format ((type (eql 'subrip))
+                            &optional (encoding *default-encoding*))
+  (flex:make-external-format encoding :eol-style :crlf))
+
+(register-type 'subrip
+               (lambda (file-name)
+                 (equalp (pathname-type file-name) "srt")))

subtitles.asd

@@ -0,0 +1,9 @@
+;;; -*- Mode: Lisp -*-
+
+(asdf:defsystem subtitles
+  :serial t
+  :depends-on (flexi-streams)
+  :components ((:file "packages")
+               (:file "subtitles")
+               (:file "subrip")
+               (:file "microdvd")))

subtitles.lisp

@@ -0,0 +1,80 @@
+;;; -*- Mode: Lisp -*-
+
+;;; This software is in the public domain and is
+;;; provided with absolutely no warranty.
+
+(in-package #:subtitles)
+
+(defvar *default-encoding* :utf-8)
+
+(defclass subtitles ()
+  ((contents :initform nil
+             :accessor contents
+             :initarg :contents)))
+
+(defclass frame ()
+  ((text :initform nil
+         :accessor text
+         :initarg :text)
+   (start-time :initform 0
+               :accessor start-time
+               :initarg :start-time)
+   (end-time :initform 0
+             :accessor end-time
+             :initarg :end-time)))
+
+(defgeneric read-subtitles (type stream))
+(defgeneric write-subtitles (type subtitles stream))
+(defgeneric external-format (type &optional encoding))
+
+(defmethod external-format (type &optional (encoding *default-encoding*))
+  (flex:make-external-format encoding))
+
+(defvar *type-mapping* ())
+
+(defun register-type (type function)
+  (let ((acons (assoc type *type-mapping*)))
+    (if acons
+        (setf (cdr acons) function)
+        (push (cons type function) *type-mapping*))))
+
+(defun file-type (file-name)
+  (loop for (type . function) in *type-mapping*
+        when (funcall function file-name) return type))
+;;;
+
+(defun load-subtitle (file-name &optional (type (file-type file-name)))
+  (unless type
+    (error "Couldn't determine type of ~a." file-name))
+  (with-open-file (stream file-name :element-type '(unsigned-byte 8))
+    (let ((flexi (flex:make-flexi-stream stream :external-format
+                                         (external-format type))))
+      (read-subtitles type flexi))))
+
+(defun save-subtitle (file-name subtitle &optional (type (file-type file-name)))
+  (unless type
+    (error "Couldn't determine type of ~a." file-name))
+  (with-open-file (stream file-name :element-type '(unsigned-byte 8)
+                          :direction :output)
+    (let ((flexi (flex:make-flexi-stream stream :external-format
+                                         (external-format type))))
+      (write-subtitles type subtitle flexi))))
+
+;;;
+
+(defun encode-time (hours minutes seconds milliseconds)
+  (+ milliseconds
+     (* 1000 (+ seconds
+                (* 60 (+ minutes
+                         (* 60 hours)))))))
+
+(defun decode-time (time)
+  (flet ((remainder (divisor)
+           (let (remainder)
+             (setf (values time remainder) (truncate time divisor))
+             remainder)))
+    (let ((ms (remainder 1000))
+          (s  (remainder 60))
+          (m  (remainder 60))
+          (h  time))
+      (values h m s ms))))