;; TODO
;;
;; 1. handy post-filters for (fingers...): includes these steps
;; 2. handy pre-filters for (place-chord...): allow mutes, fix mutes, bla

;; a constant list with note names. if a note has two names - both are given
(define *note-aliases*
  '#(("C" "B#") ("C#" "Db") ("D") ("D#" "Eb")
     ("E" "Fb") ("F" "E#") ("F#" "Gb") ("G")
     ("G#" "Ab") ("A") ("A#" "Bb") ("B" "Cb")))

;; convert half tone value into note alias[es] 
(define (note-aliases ht)
  (vector-ref *note-aliases* 
              (modulo ht 12)))

;; convert the note alias into halftone value
(define (note-value alias)
  (let rec ((i 0)
        (l (vector->list *note-aliases*)))
    (if (null? l)
        #f
        (if (member alias (car l))
            i
            (rec (+ 1 i)
              (cdr l))))))

(define *standard-tuning* 
  (map note-value '("E" "B" "G" "D" "A" "E")))

(define *tuning* *standard-tuning*)
(define *max-fret#* 16)

(define *chords-repo*
  '(("7" (4 3 3))
    ("m7" (3 4 4))
    ("M7" (4 3 4))))

(define (chord-intervals name)
  (cadr (assoc name *chords-repo*)))

;; given the root (half tone number) and the intervalic formula of the 
;; chord (a list of ints) build the instance of the chord 
;; (a list of half tone values of the notes)
(define (chord-notes root intervals)
  (reverse
   (let rec ((notes (list root))
             (current root)
             (i intervals))
     (if (null? i)
         notes
         (let ((n (modulo (+ current (car i)) 12)))
           (rec (cons n notes) n (cdr i)))))))

;; return the list of lists of fret numbers, one list for each 
;; string in *tuning*, up to *max-fret#*
(define (place-chord chord)
  (define (place-chord-1 open-note)
    (reverse
    (let rec ((fret# 0)
              (frets ()))
      (if (> fret# *max-fret#*)
          frets
          (if (memq (modulo (+ fret# open-note) 12) chord)
              (rec (+ fret# 1) (cons fret# frets))
              (rec (+ fret# 1) frets))))))
  (map place-chord-1 *tuning*))

(define *standard-tuning* 
  (map note-value '("E" "B" "G" "D" "A" "E")))

;; FIXME: this should build in the order eBGDAE for barre detection to work
(define (finger-fit? partial fret)
  (or (equal? fret "x")
      (eq? fret 0)
      (let* ((frets (cons
                       fret
                       (filter (lambda (x)
                                 (and (not (equal? x "x"))
                                      (not (eq? x 0))))
                               partial)))
             (max (apply max frets))
             (min (apply min frets))
             (d (- max min))
             (n-fingers
              (let count ((n 0)
                          (barre #t)
                          (barre-counted #f)
                          (frets (cons fret partial)))
                (if (null? frets)
                    n
                    (let* ((cur (car frets))
                           (finger (and (number? cur) 
                                        (> cur 0)))
                           (count-finger (and finger
                                              (or (> cur min)
                                                  (and barre 
                                                       (not barre-counted))))))
                      (count
                       (if count-finger
                           (+ n 1)
                           n)
                       (and barre 
                            (or (not (number? cur)) 
                                (> cur 0)))
                       (or barre-counted
                           (and finger 
                                barre 
                                (= cur min)))
                       (cdr frets)))))))
        (and (< n-fingers 5)
             (< d (cond ((= min 1) 4)
                        ((< min 6) 5)
                        (else 6)))))))

(define *good-fret?* finger-fit?)
;;       ,,,
;;      (o o)
;; --ooO-(_)-Ooo--
;; Wot? no filter?
(define (filter predicate list)
  (let rec ((result ())
            (rest list))
    (if (null? rest)
        (reverse result)
        (if (predicate (car rest))
            (rec (cons (car rest) result) (cdr rest))
            (rec result (cdr rest))))))

;; given a partial chord and a bunch of potential other frets 
;; find the combinations using '*good-fret?*' helper
;; (good-fret? partial fret) returns true if fret may be added to partial 
;; chord partial. e.g. 'finger-fit?' above
(define (combine-frets fret-space)  
  (let combine ((partial ())
                (fret-space fret-space))
    (if (null? fret-space)
        (list (reverse partial))
        (apply append 
               (map (lambda (cur)
                      (combine
                       (cons cur partial) 
                       (cdr fret-space)))
                  (filter 
                   (lambda (fret)
                     (or (null? partial)
                         (*good-fret?* partial fret)))
                   (car fret-space)))))))

;; join 'good-fret?' predicates of the list by logical and
(define (make-and-good-fret list)
  (lambda (partial fret)
    (let cont ((list list))
      (if (null? list)
          #t
          (if (not ((car list) partial fret))
              #f
              (cont (cdr list)))))))

(define (make-has-steps chord-notes steps)
  (lambda (fingering)
    (let ((finger-notes 
           (map (lambda (f o) 
                  (if (number? f)
                      (modulo (+ f o) 12)
                      f))
                fingering
                *tuning*))
          (required-notes 
           (map (lambda (i) (list-ref chord-notes i)) steps)))
      (let rec ((req required-notes))
        (cond
          ((null? req) #t)
          ((not (memq (car req) finger-notes)) #f)
          (else (rec (cdr req))))))))

;; (chord root formula)
;; root: root note name or value
;; formula: chord name or list of intervals
(define (chord root formula)
  (let ((root (if (string? root)
                  (note-value root)
                  root))
        (formula (if (string? formula)
                     (chord-intervals formula)
                     formula)))
    (chord-notes root formula)))

(define (allow-mutes frets-space)
  (map (lambda (string) (cons "x" string))
       frets-space))