#lang scheme/base

;; MPEG4/Quicktime parser

;; ftyp
;; moov
;;   mvhd
;;   trak
;;     tkhd
;;     edts
;;       elst
;;     mdia
;;       mdhd
;;       minf
;;         stbl
;;           stsd
;;           stco
;;           co64
;;           stts
;;           stss
;;           stsc
;;           stsz
;;   trak
;;   trak
;;   ..
;; mdat
;;   [data]
;;   [data]
;;   [...]

(require scheme/control)

(define (read-int n)
  (for/fold ((a 0))
            ((l (bytes->list (read-bytes n))))
    (+ l (* 256 a))))


(define (read-16) (read-int 2))
(define (read-32) (read-int 4))
(define (read-64) (read-int 8))

(define (read-type)
  ;; (define (convert x) x)
  (define (convert x) (string->symbol (bytes->string/utf-8 x)))
  (convert (read-bytes 4)))


;; The following tags contain lists of tagged data.
(define (container? x)
  (case x
    ((moov trak edts mdia minf stbl) #t)  ;; mdat
    (else #f)))

(define (point . n) (apply file-position (current-input-port) n))
(define (scan-stream outer-from to)
  (printf "chunk ~s:~s\n" outer-from to)
  (let loop ((lst '()))
    (let ((from (point)))
      (cond
       ((< from to)
        (let* ((size (read-32))
               (type (read-type)))
          (when (= 1 size) (error 'read-atom-64)) ;; 64-offsets
          (when (= 0 size) (set! size (- to from))) ;; open ended
          (printf "~s=~s (@~s)\n" type size from)
          (loop
           (cons
            (cons type
                  (let ((inner-from (+ from 8))
                        (inner-to   (+ from size)))
                    (when (> inner-to to)
                      (error 'inner-atom-not-contained))
                    (if (not (container? type))
                        (begin
                          (point inner-to) ;; skip data
                          (list inner-from (- inner-to inner-from)))
                        (scan-stream inner-from inner-to))))
            lst))))
       ((> from to)
        (error 'scan-read-too-far
               "from:~s to:~s at:~s"
               from to (point)))
       (else
        (reverse lst))))))
                                   

;; FIXME: contains mutable state (file offset)
(define-struct mpeg4 (header port))

(define (mpeg4-open path)
  (let ((size (file-size path))
        (port (open-input-file path)))
    (parameterize ((current-input-port port))
      (make-mpeg4 (scan-stream 0 size) port))))


;; Turn into globber in zipper form.
(define (tree-path t p [err (lambda () (error 'mpeg4-path))])
  (if (null? p) t
      (let ((rec (assoc (car p) t)))
        (unless rec (err))
        (tree-path (cdr rec)
                   (cdr p)
                   ))))

(define (mpeg4-box mpeg4 path)
  (tree-path (mpeg4-header mpeg4) path
             (lambda () (error 'mpeg4-box-not-found "~s" path))))

(define (mpeg4-reader read)
  (lambda (mpeg4 path)
    (let-values (((start length)
                  (apply values (mpeg4-box mpeg4 path))))
      (parameterize ((current-input-port (mpeg4-port mpeg4)))
        (point start)
        (read length)))))

;; (mpeg4-bytes x '(moov trak tkhd))

(define (test)
  (mpeg4-open "/pub/new/tom/DanAriely_2009.mp4"))

(define x (test))

(define int16 read-16)
(define int32 read-32)
(define int64 read-64)
(define tag   read-type)

(define mpeg4-bytes (mpeg4-reader read-bytes))
  
    

;; A struct is represented by a reader that produces an assoc list.
(define-syntax-rule (define-mpeg4-box name (type field) ...)
  (define name
    (mpeg4-reader
     (lambda _
       `((field . ,(type)) ...)))))

(define-mpeg4-box ftyp
  (tag            brand)
  (int32          version))

(define-mpeg4-box tkhd
  (int32          vflags)
  (int32          created)
  (int32          modified)
  ;; ...
  
)