rktplayer/playlist.rkt

#lang racket

(require racket/class
         "music-library.rkt"
         racket-sound
         "utils.rkt"
         racket-sprintf
         keystore/class
         )

(provide track%
         playlist%
         )

(define the-displayln displayln)
(define list-for-each for-each)
(define list-length length)
  
(define next-track-id 0)

(define track%
  (class object%
    (init-field
     [file #f]
     [title ""]
     [artist ""]
     [album ""]
     [length 0]
     [number 0]
     )

    (define/public (displayln)
      (the-displayln (format "~a - ~a - ~a - ~a"
                             number
                             title
                             album
                             length)))

    (define my-id (begin
                    (set! next-track-id (+ next-track-id 1))
                    (when (> next-track-id 10000000)
                      (set! next-track-id 1))
                    next-track-id))

    (define/public (get-file) file)
    (define/public (get-title) title)
    (define/public (get-artist) artist)
    (define/public (get-album) album)
    (define/public (get-number) number)
    (define/public (get-length) length)
    (define/public (get-id) my-id)

    (define (read-tags)
      (let* ((f (if (path? file) (path->string file) file))
             (tags (id3-tags f))
             (tmpfile #f))
        (unless (tags-valid? tags)
          (let ((nfile (make-temporary-file "rktplayer-~a" #:copy-from f)))
                (set! tags (id3-tags nfile))
                (set! tmpfile nfile)
                ))
        (unless (eq? tmpfile #f)
          (delete-file tmpfile))
        tags
        )
      )

    (define/public (image->file* to-file)
      #f)
    
    (define/public (image->file to-file*)
      (let ((to-file (format "~a" to-file*))
            (tags (read-tags)))
        (dbg-rktplayer "image->file ~a" to-file)
        (let ((image-from-tags (λ ()
                                 (if (tags-valid? tags)
                                     (let ((ext (tags-picture->ext tags)))
                                       (if (eq? ext #f)
                                           #f
                                           (let ((path (string-append to-file "." (symbol->string ext))))
                                             (if (tags-picture->file tags path)
                                                 path
                                                 #f)
                                             )
                                           )
                                       )
                                     #f)
                                 )
                               )
              )
          (let ((path (image-from-tags)))
            (dbg-rktplayer "image-from-tags: ~a" path)
            (if (eq? path #f)
                (let* ((bd (basedir file))
                       (files (filter
                              (λ (f)
                                (let ((file (build-path bd f)))
                                  (file-exists? file)))
                              (list "cover.jpg" "cover.png" "folder.jpg" "folder.png"))))
                  (if (null? files)
                      #f
                      (let ((file (string-append to-file (bytes->string/utf-8 (path-get-extension (car files))))))
                        (copy-file (build-path bd (car files)) file #:exists-ok? #t)
                        (dbg-rktplayer "image from basedir: ~a" file)
                        (format "~a" file))
                      ))
                path))
          )
        )
      )

    (define/public (image->mimetype*)
      #f)
    
    (define/public (image->mimetype)
      (let ((tags (read-tags)))
        (if (tags-valid? tags)
            (tags-picture->mimetype tags)
            'no-mimetype)))

    (super-new)

    (begin
      (let ((use-tags #t))
        (if use-tags
            (unless (eq? file #f)
              (let ((tags (read-tags)))
                (if (tags-valid? tags)
                    (begin
                      (set! title (tags-title tags))
                      (set! artist (tags-artist tags))
                      (set! album (tags-album tags))
                      (set! number (tags-track tags))
                      (set! length (tags-length tags))
                      )
                    (begin
                      (set! title "invalid tags")
                      (set! artist "invalid tags")
                      (set! album "invalid tags")
                      (set! number number)
                      (set! length -1)
                      )
                    )
                )
              )
            (unless (eq? file #f)
              (set! title (format "~a" file))
              (set! number 0))
            )
        )
      )
    )
  )

(define list-len length)
(define orig-for-each for-each)

(define playlist%
  (class object%
    (init-field
     [start-map #f]
     [max-tracks 100]
     [name "Default"]
     [id #f]
     [settings #f]
     )

    (define store (new keystore% [file 'rktplayer]))
    (define tracks '())

    (define (can-add? file)
      (and (<= (list-len tracks) max-tracks)
           (is-music-file? file)))

    (define (add-track* file)
      (let  ((track (new track% [file file])))
        (set! tracks (append tracks (list track)))))

    (define (read-tracks-internal dir)
      ;(displayln (format "dir = ~a" dir))
      (if (> (list-len tracks) max-tracks)
          'done
          (if (file-exists? dir)
              (when (can-add? dir)
                (add-track dir))
              (if (directory-exists? dir)
                  (let ((content (directory-list dir)))
                    (orig-for-each (λ (entry)
                                (let ((p (build-path dir entry)))
                                  (if (directory-exists? p)
                                      (read-tracks-internal p)
                                      (when (and (file-exists? p) (can-add? p))
                                        ;(displayln (format "Adding ~a" p))
                                        (add-track* p)))))
                              content))
                  'no-file-or-dir
                  )
              )
          )
      )

    ;(define/public (set-name! n)
    ;  (set! name n))

    ;(define/public (set-id! id*)
    ;  (set! id id*))

    ;(define/public (get-id)
    ;  id)

    ;(define/public (get-name)
    ;  name)

    (define/public (tabs)
      (map (λ (k)
             (if (string? k)
                 (string->symbol k)
                 k))
           (send store get 'tabs '(tabkey-default)))
      )
    
    (define/public (tab-count)
      (list-length (tabs)))

    (define/public (make-tab-key)
      (string->symbol
       (format "tabkey-~a-~a" (current-milliseconds) (random 10000))))

    (define/public (get-tab-name idx)
      (let* ((t (tabs))
             (entry (list-ref t idx)))
        (let ((v (send store get entry (list (format "Playlist-~a" idx) '()))))
          (car v))))

    (define/public (set-tab-name! idx name)
      (let* ((t (tabs))
             (entry (list-ref t idx))
             (v (send store get entry (list (format "Playlist-~a" idx) '())))
             )
        (send store set! entry (list name (cadr v)))
        )
      )

    (define/public (tab-id idx)
      (let ((t (tabs)))
        (list-ref t idx)))

    (define/public (tab-index id)
      (let ((t (tabs)))
        (letrec ((f (λ (t idx)
                      (if (null? t)
                          #f
                          (if (eq? (car t) id)
                              idx
                              (f (cdr t) (+ idx 1)))))))
          (f t 0))))

    (define/public (drop-tab! idx)
      (let* ((t (tabs))
             (entry (list-ref t idx))
             )
        (send store set! 'tabs (list-drop! t idx))
        (send store drop! entry)
        ))

    (define/public (add-tab!)
      (let* ((t (tabs))
             (new-entry (send this make-tab-key)))
        (send store set! 'tabs (append t (list new-entry)))
        )
      )

    (define/public (save-tab!)
      (let* ((entry id)
             (idx (send this tab-index entry))
             )
        (dbg-rktplayer "entry id = ~a, ~a" entry idx)
        (if (eq? idx #f)
          (err-rktplayer "Cannot get tab for id ~a" entry)
          (let ((value (list (send this get-tab-name idx)
                             (map (λ (track)
                                    (send track get-file))
                                  tracks))))
            (send store set! entry value)
            )
          )
        )
      )

    (define/public (load-tab idx)
      (let* ((t (tabs))
             (entry (list-ref t idx))
             )
        (dbg-rktplayer "loading ~a" entry)
        (set! id entry)
        (set! tracks '())
        (let ((value (send store get entry (list "Default" '()))))
          (set! name (car value))
          (list-for-each (λ (file)
                           (send this add-track file #f))
                         (cadr value))
          )
        )
      #t
      )

    (define/public (read-tracks)
      (set! tracks '())
      (read-tracks-internal start-map)
      (send this save-tab!)
      )

    (define/public (length)
      (list-len tracks))

    (define/public (add-track file . args)
      (add-track* file)
      (when (null? args)
        (send this save-tab!))
      )

    (define/public (track i)
      (list-ref tracks i))

    (define/public (display-tracks)
      (orig-for-each (λ (track)
                  (send track displayln))
                tracks))

    (define/public (for-each f)
      (let ((idx 0))
        (orig-for-each (λ (track)
                    (f idx track)
                    (set! idx (+ idx 1)))
                       tracks)
        )
      )

    (define/public (track-id i)
      (string->symbol (format "track-~a" (+ i 1))))

    (define/public (index id)
      (- (string->number (substring (symbol->string id) 6)) 1))

    (define/public (to-html)
      (define (formatter row)
        (let* ((track-idx (car row))
               (track (track track-idx)))
          (list
           (list 'td (list (list 'class "number"))
                 (format "~a." (send track get-number)))
           (list 'td (list (list 'class "title"))
                 (send track get-title))
           (list 'td (list (list 'class "album"))
                 (send track get-album))
           (list 'td (list (list 'class "length"))
                 (let* ((length-s (send track get-length))
                        (hour (quotient length-s 3600))
                        (min (quotient (remainder length-s 3600) 60))
                        (sec (remainder (remainder length-s 3600) 60)))
                   (sprintf "%02d:%02d:%02d" hour min sec)))
           )))

      (letrec ((f (λ (i N)
                    (if (< i N)
                        (cons (list (send this track-id i) i) (f (+ i 1) N))
                        '()))))
        (let ((rows (f 0 (send this length))))
          (mktable rows 'tracks formatter))))

    (super-new)
    
    (begin
      (if (eq? start-map #f)
          (send this load-tab 0)
          (set! id (send this tab-id id)))
      )
    )
  )