;;; -*- Mode:LISP; Package:(COMPOSER GLOBAL); Readtable:CL; Base:10 -*-

(defconst *truenote-octaves* 8)

(defconst *truenote-table* nil
  "Table of defstructs for truenotes.")

(defstruct (truenote (:print-function print-truenote))
  string-for-printing	    ; i.e. "A7"
  level			    ; i.e. 7
  key-symbol		    ; i.e. :A
  table-backpointer	    ; points back to including table
  )

(defun print-truenote (structure stream printdepth)
  printdepth
  (format stream "#<Truenote ~A>" (truenote-string-for-printing structure)))

(defconst *key-symbols*
	  '(:C :C\#/D@ :D :D\#/E@ :E :F :F\#/G@ :G :G\#/A@ :A :A\#/B@ :B))

(defun init-truenote-table ()
  (setq *truenote-table* (make-array '(8 12)))
  (dotimes (octave *truenote-octaves*)
    (do ((l *key-symbols* (cdr l))
	 (count 0 (add1 count)))
	((null l))
      (aset (make-truenote
	      :string-for-printing (format nil "~a ~D" (car l) octave) 
	      :level octave
	      :key-symbol (car l)
	      :table-backpointer *truenote-table*)
	    *truenote-table*
	    octave
	    count))))

(defstruct (note (:type :list) :named predicate)
  value			    ; Points to a truenote
  duration		    ; a positive integer (1 2 4 8 16 ...)
  grace-note		    ; Cons (<type> . <cons like for value>)
  accent		    ; Cons (<type> . (<spec1> <spec2> ...))
  attributes		    ; An Alist of attributes ((<attribute> . (<spec1> <spec2> ...)) ...)
  )

(defstruct (note-group (:type :list)
		       :named
		       (:constructor INTERNAL-MAKE-NOTE-GROUP)
		       :predicate)
  type			    ; A keyword symbol describing what type of grouping it is
  note-list		    ; A list of NOTE structures
  property-list		    ; Type-specific Properties
  )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Note group type specifications
;;;
;;;

(defconst *standard-note-group-properties*
	  `((:upper-length-limit . (integer 1))
	    (:lower-length-limit . (integer 1))))

(defconst *note-group-element-type-spec*
	 `(or (satisfies note-group-p)
	      (satisfies note-p)))

(defmacro define-note-group (symbol &body group-properties)
  "Define a note group type."
  (check-type symbol symbol)
  (let (real-properties)
    (dolist (prop group-properties)
      (typecase prop
	(list (if (and (eq (length prop) 2)
		       (typep (second prop)
			      (cdr (assq (car prop) *standard-note-group-properties*))))
		  (push prop real-properties)
		(compiler:warn 'invalid-property-spec :error
			       "Invalid note group designator: ~s"
			       prop)))
	(t (compiler:warn 'invalid-property-spec :error
			  "Invalid note group property spec entry: ~S"
			  prop))))
    `(progn 'compile
	    (putprop ',symbol
		     ',(cons :note-group-properties real-properties)
		     :note-group-properties))))
	
;;; here are the actual definitions

(define-note-group triplet
  (:upper-length-limit 3)
  (:lower-length-limit 3))

(define-note-group doublet
  (:upper-length-limit 2)
  (:lower-length-limit 2))

(define-note-group run)

(define-note-group slur)

(define-note-group chord)

(define-note-group trill
  (:upper-length-limit 1)
  (:lower-length-limit 1))

(defun make-note-group (note-list type)
  (check-type type symbol)
  (let ((plist (get type :note-group-properties)))
    (check-arg type plist "a defined note group type")
    (check-arg note-list (and (if (get plist :upper-length-limit)
				  (<= note-list (get plist :upper-length-limit))
				t)
			      (if (get plist :lower-length-limit)
				  (<= note-list (get plist :lower-length-limit))
				t))
	       "within the number of notes limit defined by the note group type")
    (dolist (elem note-list)
      (unless (typep elem *note-group-element-type-spec*)
	(ferror nil "Invalid note-group element: ~S" elem)))
    (internal-make-note-group :type type :note-list note-list)))