;------------------------------------------------------------
; File:  melody.l of domains of clay of clos of lisp of ai

;------------------------------------------------------------
; Enter clos
  ( in-package "pcl" )

;------------------------------------------------------------
; Required stuff
  ( load "/home/blue/ai/lisp/clos/blue.l" )

;------------------------------------------------------------
; Modeling a NOTE

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

  ( defclass note
    () 
    ( ( degree :accessor note-degree :initarg :degree :initform 1 ) 
      ( duration :accessor note-duration
                 :initarg :duration 
                 :initform 4
      )
      ( register :accessor note-register :initarg :register :initform 0 )
      ( amplitude :accessor note-amplitude :initarg :amplitude :initform 0.5 )
    )
  )

  ( defmethod display ( (os t) ( n note ) )
    ( format t "deg = ~A; dur = ~A; reg = ~A; amp = ~A"
      ( note-degree n )
      ( note-duration n )
      ( note-register n )
      ( note-amplitude n )
      os
    )
  )


;------------------------------------------------------------
; Modeling a SCALE

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

  ( defclass scale
    () 
    ( ( key :accessor scale-key :initarg :key :initform 'c ) 
      ( mode :accessor scale-mode
                  :initarg :mode
                  :initform *major*
      )
    )
  )

  ( defmethod display ( (os t)( s scale ) )
    ( format t "key = ~A; mode = ~A"
      ( scale-key s )
      ( scale-mode s )
      os
    )
  )

  ( defmethod size ( ( s scale ) )
    ( length ( mode-intervals ( scale-mode s ) ) )
  )

;------------------------------------------------------------
; Processing NOTEs in the context of SCALES

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

  ( defmethod raise-pitch ( ( n note ) ( s scale ) )
    ( setf ( note-degree n ) 
      ( if ( = ( note-degree n ) ( size s ) )
        1
        ( + ( note-degree n ) 1 ) 
      )
    )
    ( if ( = ( note-degree n ) 1 )
      ( setf ( note-register n ) ( + ( note-register n ) 1 ) )
    )
  )

  ( defmethod lower-pitch ( ( n note ) ( s scale ) )
    ( setf ( note-degree n ) 
      ( if ( = ( note-degree n ) 1 )
        ( size s )
        ( - ( note-degree n ) 1 ) 
      )
    )
    ( if ( = ( note-degree n ) ( size s ) )
      ( setf ( note-register n ) ( - ( note-register n ) 1 ) )
    )
  )

;------------------------------------------------------------
; Modeling a MODE

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

  ( defclass mode
    () 
    ( ( name :accessor mode-name :initarg :name :initform 'major ) 
      ( intervals :accessor mode-intervals
                  :initarg :intervals
                  :initform '( 2 2 1 2 2 2 1 )
      )
    )
  )

  ( defmethod display ( (os t) ( m mode ) )
    ( format t "name = ~A; intervals = ~A"
      ( mode-name m )
      ( mode-intervals m )
      os
    )
  )

;------------------------------------------------------------
; CREATE standard MODES

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

  ( defconstant *major* 
    ( make-instance 'mode :name 'major :intervals '( 2 2 1 2 2 2 1 ) )
  )
  ( defconstant *dorian* 
    ( make-instance 'mode :name 'dorian :intervals '( 2 1 2 2 2 1 2 ) )
  )
  ( defconstant *phrygian* 
    ( make-instance 'mode :name 'phrygian :intervals '( 1 2 2 2 1 2 2 ) )
  )
  ( defconstant *lydian* 
    ( make-instance 'mode :name 'lydian :intervals '( 2 2 2 1 2 2 1 ) )
  )
  ( defconstant *mixolydian* 
    ( make-instance 'mode :name 'mixolydian :intervals '( 2 2 1 2 2 1 2 ) )
  )
  ( defconstant *minor* 
    ( make-instance 'mode :name 'minor :intervals '( 2 1 2 2 1 2 2 ) )
  )
  ( defconstant *locrian* 
    ( make-instance 'mode :name 'locrian :intervals '( 1 2 2 1 2 2 1 ) )
  )
  ( defconstant *wholetone* 
    ( make-instance 'mode :name 'wholetone :intervals '( 2 2 2 2 2 2  ) )
  )
  ( defconstant *pentatonic* 
    ( make-instance 'mode :name 'pentatonic :intervals '( 2 3 2 2 3 ) )
  )
  ( defconstant *ionian* *major* )
  ( defconstant *aeolian* *minor* )

  ( defconstant *modes* 
    ( list *major* *dorian* *phrygian* *lydian*
           *mixolydian* *minor* *locrian* *wholetone* *pentatonic*
           *ionian* *aeolian* 
    )
  )


;------------------------------------------------------------
; the simple commands

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

  ( defmethod |melody>show| ( ( gc green-clay) )
    ( display (clay-output-stream gc) *note* )
  )

  ( defmethod |melody>play| ( ( gc green-clay) &aux os)
    ( setf os (clay-output-stream gc) )
    ( cond
      ( ( < ( note-register *note* ) -4 )
        ( write-line "    PITCH IS TOO LOW" os )
      )
      ( ( > ( note-register *note* ) 4 )
        ( write-line "    PITCH IS TOO HIGH" os )
      )
      ( ( eq *textual-pitch-output-preference* 'functional )
        ( print-functional-pitch os *note* )
        ( if ( eq *textual-duration-output-preference* 'spacial )
          ( print-spacial-duration os *note* )
          ( print-actual-duration os *note* *scale* )
        )
      )
      ( t
        ( print-actual-pitch os *note* *scale* )
        ( if ( eq *textual-duration-output-preference* 'spacial )
          ( print-spacial-duration os *note* )
          ( print-actual-duration os *note* *scale* )
        )
      )
    )
    ( terpri )
  )

  ( defmethod print-functional-pitch ( (os t) ( n note ) )
    ( princ ( note-register-string ( note-register n ) ) os )
    ( princ " " os )
    ( prin1 ( note-degree n ) os )
    ( princ "  " os )
  )

  ( defmethod print-spacial-duration ( (os t) ( n note ) )
    ( princ ( note-duration-string ( note-duration n ) ) os )
  )

  ( defmethod print-actual-pitch ( ( n note ) ( s scale ) &aux key )
    ( princ ( note-register-string ( note-register n ) ) os )
    ( princ " " os )
    ( setf key ( determine-key n s ) )
    ( prin1 key os )
    ( if ( = ( length ( symbol-name key ) ) 1 )
      ( princ " " os )
      ( princ "  " os )
    )
  )

  ( defmethod determine-key ( ( n note ) ( s scale ) 
      &aux d k i hs p x the-key
    )
    ( setf d ( note-degree n ) )
    ( setf k ( scale-key s ) )
    ( setf i ( mode-intervals ( scale-mode s ) ) )
    ( setf hs ( apply #'+ ( subseq i 0 ( - d 1 ) ) ) )
    ( setf p ( position k *physical-key-name-sequence* ) )
    ( setf x ( + p hs ) )
    ( setf the-key ( elt *physical-key-name-sequence* x ) )
    the-key
  )

  ( defmethod print-actual-duration ( (os t) ( n note ) ( s scale ) )
    ( princ ( note-duration n ) os )
  )

  ( defmethod note-register-string ( ( n number ) )
    ( cond
      ( ( = n 0 )
        "    "
      )
      ( ( > n 0 )
        ( concatenate 'string 
          ( subseq ( note-register-string ( - n 1 ) ) 1 ) "H" 
        )
      )
      ( ( < n 0 )
        ( concatenate 'string 
          ( subseq ( note-register-string ( + n 1 ) ) 1 ) "L" 
        )
      )
    )
  )

  ( defmethod note-duration-string ( ( n number ) )
    ( cond
      ( ( = n 0 )
        ""
      )
      ( ( > n 0 )
        ( concatenate 'string 
          ( note-duration-string ( - n 1 ) ) "-" 
        )
      )
      ( ( < n 0 )
        ( error "Negative note duration!" )
      )
    )
  )


  ( defmethod |melody>rest| ( ( gc green-clay) )
    ( princ "       " )
    ( princ ( note-duration-string ( note-duration *note* ) ) )
    ( terpri )
  )

  ( defmethod |melody>rp| ( ( gc green-clay) )
    ( raise-pitch *note* *scale* )
    NIL
  )

  ( defmethod |melody>lp| ( ( gc green-clay) )
    ( lower-pitch *note* *scale* )
    NIL
  )

  ( defmethod |melody>d| ( ( gc green-clay) )
    ( setf ( note-duration *note* ) ( * 2 ( note-duration *note* ) ) )
    NIL
  )

  ( defmethod |melody>h| ( ( gc green-clay) )
    ( setf ( note-duration *note* ) ( / ( note-duration *note* ) 2 ) )
    NIL
  )

  ( defmethod |melody>triple| ( ( gc green-clay) )
    ( setf ( note-duration *note* ) ( * 3 ( note-duration *note* ) ) )
    NIL
  )

  ( defmethod |melody>third| ( ( gc green-clay) )
    ( setf ( note-duration *note* ) ( / ( note-duration *note* ) 3 ) )
    NIL
  )

  ( defmethod |melody>quadruple| ( ( gc green-clay) )
    ( setf ( note-duration *note* ) ( * 4 ( note-duration *note* ) ) )
    NIL
  )

  ( defmethod |melody>quarter| ( ( gc green-clay) )
    ( setf ( note-duration *note* ) ( / ( note-duration *note* ) 4 ) )
    NIL
  )

  ( defmethod |melody>dot| ( ( gc green-clay) )
    ( setf ( note-duration *note* ) ( * 1.5 ( note-duration *note* ) ) )
    NIL
  )

  ( defmethod |melody>undot| ( ( gc green-clay) )
    ( setf ( note-duration *note* ) ( / ( note-duration *note* ) 1.5 ) )
    NIL
  )

  ( defmethod |melody>abstract| ( ( gc green-clay) )
    ( setf *textual-pitch-output-preference* 'functional )
    ( setf *textual-duration-output-preference* 'spacial )
    NIL
  )

  ( defmethod |melody>actual| ( ( gc green-clay) )
    ( setf *textual-pitch-output-preference* 'actual )
    ( setf *textual-duration-output-preference* 'actual )
    NIL
  )


;------------------------------------------------------------
; Set useful SYSTEM OBJECTS

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

  ( setf *physical-key-name-sequence* 
    '( c cd d de e f fg g ga a ab b c cd d de e f fg g ga a ab b c )
  )


;------------------------------------------------------------
; CREATE the FEATURED OBJECTS

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

  ( setf *note* ( make-instance 'note ) )
  ( setf *scale* ( make-instance 'scale ) )


;------------------------------------------------------------
; Set default SYSTEM PARAMETERS

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

  ( setf *textual-pitch-output-preference* 'functional )
  ( setf *textual-duration-output-preference* 'spacial )


;------------------------------------------------------------
; establish the FAMILY

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

  ( setf *domain-family* ( make-instance 'green-clay-command-family ) )
  ( setf ( green-clay-command-family-name *domain-family* ) "melody" ) )
  ( setf ( green-clay-command-family-commands *domain-family* ) '() ) )

  ( setf *new-command* 
    ( make-green-clay-command
      "play" "Render the note sonicly and/or textually and/or graphicly."
    )
  )
  ( push 
    *new-command* ( green-clay-command-family-commands *domain-family* ) 
  )

  ( setf *new-command* 
    ( make-green-clay-command
      "rest" "Play the note silently."
    )
  )
  ( push 
    *new-command* ( green-clay-command-family-commands *domain-family* ) 
  )

  ( setf *new-command* 
    ( make-green-clay-command
      "rp" "Raise the pitch of the note one scale degree."
    )
  )
  ( push 
    *new-command* ( green-clay-command-family-commands *domain-family* ) 
  )

  ( setf *new-command* 
    ( make-green-clay-command
      "lp" "Lower the pitch of the note one scale degree."
    )
  )
  ( push 
    *new-command* ( green-clay-command-family-commands *domain-family* ) 
  )

  ( setf *new-command* 
    ( make-green-clay-command
      "d" "Double the duration of the note."
    )
  )
  ( push 
    *new-command* ( green-clay-command-family-commands *domain-family* ) 
  )

  ( setf *new-command* 
    ( make-green-clay-command
      "h" "Halve the duration of the note."
    )
  )
  ( push 
    *new-command* ( green-clay-command-family-commands *domain-family* ) 
  )

  ( setf *new-command* 
    ( make-green-clay-command
      "triple" "Triple the duration of the note."
    )
  )
  ( push 
    *new-command* ( green-clay-command-family-commands *domain-family* ) 
  )

  ( setf *new-command* 
    ( make-green-clay-command
      "third" "Third the duration of the note."
    )
  )
  ( push 
    *new-command* ( green-clay-command-family-commands *domain-family* ) 
  )

  ( setf *new-command* 
    ( make-green-clay-command
      "quadruple" "Quadruple the duration of the note."
    )
  )
  ( push 
    *new-command* ( green-clay-command-family-commands *domain-family* ) 
  )

  ( setf *new-command* 
    ( make-green-clay-command
      "quarter" "Quarter the duration of the note."
    )
  )
  ( push 
    *new-command* ( green-clay-command-family-commands *domain-family* ) 
  )

  ( setf *new-command* 
    ( make-green-clay-command
      "dot" "Increase by 50% the duration of the note."
    )
  )
  ( push 
    *new-command* ( green-clay-command-family-commands *domain-family* ) 
  )

  ( setf *new-command* 
    ( make-green-clay-command
      "undot" "Decrease by 1/3 the duration of the note."
    )
  )
  ( push 
    *new-command* ( green-clay-command-family-commands *domain-family* ) 
  )

  ( setf 
    ( green-clay-command-family-commands *domain-family* ) 
    ( reverse
      ( green-clay-command-family-commands *domain-family* ) 
    )
  )

  ( order *domain-family* )