#|
sbcl --script "$0" "${@:1}"
exit
|#

(defun ffmpeg (&rest args)
  (run-program "ffmpeg" (list* "-hide_banner" "-loglevel" "info" (mapcar #'princ-to-string args))
               :search T :error *error-output*))

(defun ffprobe (&rest args)
  (with-output-to-string (out)
    (run-program "ffprobe" (list* "-hide_banner" "-loglevel" "error" (mapcar #'princ-to-string args))
                 :search T :output out :error *error-output*)))

(defun parameters (in)
  (let ((data (ffprobe "-i" (native-namestring in)
                       "-of" "flat=s=-"
                       "-show_streams")))
    (with-input-from-string (stream data)
      (loop for line = (read-line stream NIL)
            while line
            collect (let ((eq (position #\= line)))
                      (cons (intern (string-upcase (subseq line 0 eq)) "KEYWORD")
                            (read-from-string (subseq line (1+ eq)))))))))

(defun video-parameters (in)
  (let ((parameters (parameters in)))
    (list :width (cdr (assoc :streams-stream-0-width parameters))
          :height (cdr (assoc :streams-stream-0-height parameters))
          :framerate (read-from-string (cdr (assoc :streams-stream-0-r_frame_rate parameters)))
          :bitrate (read-from-string (cdr (assoc :streams-stream-0-bit_rate parameters)))
          :duration (cdr (assoc :streams-stream-0-duration parameters)))))

(defun gif (in &key (out (make-pathname :type "gif" :defaults in))
                    width fps (start "00:00:00") end
                    (scaling "lanczos"))
  (let* ((palette "/tmp/gif-palette.png")
         (params (video-parameters in))
         (fps (or fps (getf params :framerate)))
         (width (or width (getf params :width)))
         (end (or end (getf params :duration))))
    (format T "Creating gif...~%")
    (ffmpeg "-y"
            "-ss" start
            "-to" end
            "-i" (native-namestring in)
            "-vf" (format NIL "fps=~d,scale=~d:-1:flags=~a,palettegen" fps width scaling)
            (native-namestring palette))
    (ffmpeg "-y"
            "-ss" start
            "-to" end
            "-i" (native-namestring in)
            "-i" (native-namestring palette)
            "-filter_complex" (format NIL "fps=~d,scale=~d:-1:flags=~a[x];[x][1:v]paletteuse" fps width scaling)
            (native-namestring out))))

(defun main (&rest args)
  (let (width fps (start "0.0") end
        (scaling "lanczos")
        (in NIL)
        (out NIL))
    (loop for arg = (pop args)
          while arg
          do (cond ((or (string= "-w" arg) (string= "-width" arg))
                    (setf width (parse-integer (pop args))))
                   ((or (string= "-f" arg) (string= "-fps" arg))
                    (setf fps (parse-integer (pop args))))
                   ((or (string= "-s" arg) (string= "-scaling" arg))
                    (setf scaling (pop args)))
                   ((or (string= "-ss" arg) (string= "-start" arg))
                    (setf start (pop args)))
                   ((or (string= "-e" arg) (string= "-end" arg))
                    (setf end (pop args)))
                   ((string= "-o" arg)
                    (setf out (pop args)))
                   (in
                    (format T "Multiple input files not possible!~%")
                    (exit :code 1))
                   (T
                    (setf in arg))))
    (if in
        (gif in :width width :fps fps :scaling scaling
                :start start :end end
                :out (or out (make-pathname :type "gif" :defaults in)))
        (format T "gif [-w WIDTH] [-f FPS] [-ss START] [-e END] [-s SCALING] [-o OUTPUT] input~%"))))

(apply #'main (rest *posix-argv*))