;A genetic algorithm to find a melody line that sounds good when played
;forward and backward at the same time.

;the top level function
;actualnotes is used as a loop control variable in creating lists of notes
;prints the number of times the lists have been crossed and the top
;score after each round
;bars is the variable that keeps all of the lists of sequences of notes
;and their scores, etc.
(defun music ()
 (prog () (setq actualnotes (difference numnotes 1))
          (setq stopscore (difference stopscore 1))
   (setq bars (createbars nil))
   (setq crossed 0)
  loop
   (setq crossed (plus crossed 1))
   (setq bars (chucklosers (tackon (analyze (mate bars)) bars)))
   (cond ((greaterp (highscore bars) stopscore) (return bars)))
   (print crossed)
   (print (highscore bars))
  (go loop)
 )
)

(setq randhelp 0)      ;a helping value in the randomize function
(putprop 'a 'b 'next)  ;a circle of note values, used in finding
(putprop 'b 'c 'next)  ;the interval between two notes
(putprop 'c 'd 'next)
(putprop 'd 'e 'next)
(putprop 'e 'f 'next)
(putprop 'f 'g 'next)
(putprop 'g 'a 'next)
(setq checkcadence 16) ;check for a cadence after how many notes?
(setq ll36 3)          ;score for parallel 3rds and 6ths
(setq ll58 -5)         ;score for parallel 5ths and octaves
(setq inchord 2)       ;score for the two notes being in the same chord
(setq beginsI 2)       ;score for beginning on the tonic (C)
(setq endsI 2)         ;score for ending on the tonic
(setq endsV 1)         ;score for ending on the dominant
(setq endsnothing -3)  ;score for ending on something else
(setq VIcadence 3)     ;score for a V-I cadence
(setq IVIcadence 2)    ;score for a IV-I cadence
(setq halfcadence 1)   ;score for a half cadence
(setq deceptivecadence 1)   ;score for a deceptive cadence
(setq reps -2)         ;score for repeating the same note more than numreps
(setq passing 2)       ;score for passing tones
(setq neighboring 1)   ;score for neighboring tones
(setq suspension 3)    ;score for suspensions (any kind)
(setq escape 1)        ;score for escape tones
(setq pedal -2)        ;score for pedal tones
(setq stepwise 4)      ;score for stepwise motion
(setq numreps 2)       ;number of repetitions allowed before punishment
(setq numbars 50)      ;actual number of random sequences generated
(setq numnotes 32)     ;actual number of notes in a sequence
(setq stopscore 1000)  ;score to look for
(setq mutate 150)      ;1 in mutate chance of a mutation
(setq matewho 24)      ;number of sequences to cross-pollinate
                       ;recommended to be high
                       ;can be even or odd

;finds highest score in the list
(defun highscore (ls)
 (cond ((null ls) nil)
       ((null (cdr ls)) (cdar ls))
       (t (highscore (cdr ls)))
 )
)

;the shell function for the mating procedure
(defun mate (tomate)
  (mix (choose tomate))
)

;decides whether matewho is even or odd and calls the appropriate function
(defun mix (maters)
 (cond ((oddp matewho) (oddmate maters nil))
       (t (evenmate maters nil))
 )
)

;crosses two lists at a random point and may include a mutation
(defun intermate (ls1 ls2)
 (prog (left1 left2) (setq rip (randomize actualnotes))
                     (setq ls1 (car ls1))
                     (setq ls2 (car ls2))
  loop
   (cond ((equal (randomize mutate) 0)
          (cond ((zerop (randomize 2))
                 (setq ls1 (append
                            (list (normalizenotes (randomize 7)))
                            (cdr ls1))))
                (t (setq ls2 (append
                              (list (normalizenotes (randomize 7)))
                              (cdr ls2)))))))
   (setq left1 (append left1 (list (car ls1))))
   (setq ls1 (cdr ls1))
   (setq left2 (append left2 (list (car ls2))))
   (setq ls2 (cdr ls2))
   (cond ((zerop rip) (return (list
                               (cons (append left1 ls2) 0)
                               (cons (append left2 ls1) 0)))))
   (setq rip (difference rip 1))
  (go loop)
 )
)

;last mating if matewho is odd. Mates in a round robin
(defun lastmate (ls)
 (prog (left1 left2 left3) (setq rip (randomize actualnotes))
                           (setq ls1 (caar ls))
                           (setq ls2 (caadr ls))
                           (setq ls3 (caaddr ls))
  loop
   (setq left1 (append left1 (list (car ls1))))
   (setq left2 (append left2 (list (car ls2))))
   (setq left3 (append left3 (list (car ls3))))
   (setq ls1 (cdr ls1))
   (setq ls2 (cdr ls2))
   (setq ls3 (cdr ls3))
   (cond ((zerop rip) (return (list
                               (cons (append left1 ls3) 0)
                               (cons (append left2 ls1) 0)
                               (cons (append left3 ls2) 0)))))
   (setq rip (difference rip 1))
  (go loop)
 )
)

;mating function if matewho is even
(defun evenmate (maters final)
 (cond ((null maters) final)
       (t (evenmate (cddr maters) (append
                                   final
                                   (intermate
                                    (car maters)
                                    (cadr maters))))
       ))
)

;mating function if matewho is odd
(defun oddmate (maters final)
 (cond ((equal (length maters) 1) maters)
       ((equal (length maters) 3) (append (lastmate maters) final))
       (t (oddmate (cddr maters) (append
                                  final
                                  (intermate
                                   (car maters)
                                   (cadr maters))))
       ))
)

;mates highest scorers
(defun choose (tomate)
 (cond ((equal (length tomate) matewho) tomate)
       (t (choose (cdr tomate)))))


;used by commented choose to select who will mate
(defun select (ls num)
 (cond ((equal (length ls) 1) (car ls))
       ((or (zerop (difference num (cdar ls)))
            (lessp (difference num (cdar ls)) 0))
        (car ls))
       (t (select (cdr ls) (difference num (cdar ls))))
 )
)

;used by commented choose to sum up the scores of all the lists
(defun totalcount (ls)
 (cond ((null ls) 0)
       (t (plus (cdar ls) (totalcount (cdr ls))))
 )
)

;mates by roulette wheel
;(defun choose (tomate)
; (prog (final) (setq total (totalcount tomate))
;  (cond ((equal matewho 1) (return tomate)))
;  loop
;   (setq ls1 (select tomate (randomize total)))
;   (setq ls2 (select tomate (randomize total)))
;   (cond ((not (equal ls1 ls2)) (setq final (append
;                                             (list ls1 ls2)
;                                             final))))
;   (cond ((equal (length final) matewho) (return final))
;         ((greaterp (length final) matewho) (return (cdr final))))
;  (go loop)
; )
;)

;shell function for inserting a list of lists into bars
(defun tackon (new ls)
 (cond ((null new) ls)
       (t (tackon (cdr new) (insert (car new) ls)))
 )
)

;cdrs off the lowest scorers to keep the same length list
(defun chucklosers (ls)
 (cond ((equal (length ls) numbars) ls)
       (t (chucklosers (cdr ls))))
)

;shell function for musical analysis of lists of notes
(defun analyze (tries)
 (prog (tempbars) (setq moretrash (difference (length tries) 1))
  loop
   (setq tempbars
    (insert
     (scorengine (caar tries) (reverse (caar tries)) 0)
     tempbars))
   (cond ((zerop moretrash) (return tempbars)))
   (setq tries (cdr tries))
   (setq moretrash (difference moretrash 1))
  (go loop)
 )
)

;inserts a new list into a list of lists
;won't insert a list that already exists
;worst score is first for ease of removal
(defun insert (new old)
 (cond
  ((null old) (list new))
  ((lessp (cdr new) (cdar old)) (cons new old))
  ((equal (cdr new) (cdar old))
   (cond ((equal (car new) (caar old)) old)
         (t (cons (car old) (insert new (cdr old))))
         ))
  (t (cons (car old) (insert new (cdr old))))
 )
)

;sums up how many times notes are repeated more than numreps
(defun rephelp (timesrepeated lastnote melody)
 (cond ((null melody) 0)
       ((equal lastnote (car melody))
        (rephelp (plus timesrepeated 1) (car melody) (cdr melody)))
       (t (cond ((greaterp timesrepeated numreps)
                 (plus (difference timesrepeated numreps)
                       (rephelp 1 (car melody) (cdr melody))
                 ))
                (t (rephelp 1 (car melody) (cdr melody)))
          ))
 )
)

;shell function for a tail recursive function
(defun repetition (melody)
 (rephelp 0 nil melody)
)

;finds the interval between two notes
(defun intervalfinder (note1 note2)
 (cond ((equal note2 note1) 1)
         (t (plus (intervalfinder (get note1 'next) note2) 1))
 )
)

;checks for cadences every checkcadence notes
(defun cadences (ls)
 (prog () (setq count 1) (setq tempscore 0)
  loop
   (cond ((equal (remainder (plus count 1) checkcadence) 0)
          (cond ((equal (cadr ls) 'c)
                 (cond ((equal (car ls) 'f)
                        (setq tempscore (plus tempscore IVIcadence)))
                       ((equal (car ls) 'g)
                        (setq tempscore (plus tempscore VIcadence)))
                 ))
                ((equal (cadr ls) 'g)
                 (setq tempscore (plus tempscore halfcadence)))
                ((equal (car ls) 'g)
                 (setq tempscore (plus tempscore deceptivecadence)))
          ))
   )
   (cond ((equal count actualnotes) (return tempscore)))
   (setq ls (cdr ls))
   (setq count (plus count 1))
  (go loop)
 )
)

;the meat of the musical analysis
;co-ordinates the scoring by calling each function that has a part in it
(defun scorengine (melody harmony score)
       ;must return ((item .. item) . number)
 (prog () (setq control actualnotes)
          (setq rosterm melody)
          (setq rosterh harmony)
  (cond ((equal (car melody) 'c) (setq score (plus score beginsI))))
  (cond ((equal (car harmony) 'c) (setq score (plus score endsI)))
        ((equal (car harmony) 'g) (setq score (plus score endsV)))
        (t (setq score (plus score endsnothing))))
  (setq score (plus score (times (repetition melody) reps)))
  (setq score (plus (cadences melody) score))
  (setq score (plus (nonchordal melody harmony) score))
  loop
   (setq interval (intervalfinder (car rosterh) (car rosterm)))
   (cond ((or (equal interval 1) (equal interval 3) (equal interval 5))
          (setq score (plus score inchord))))
   (cond ((null (cdr rosterm)) (return (cons melody score))))
   (setq interval1 (intervalfinder (car rosterm) (cadr rosterm)))
   (setq interval2 (intervalfinder (car rosterh) (cadr rosterh)))
   (cond ((equal interval1 2) (setq score (plus score stepwise))))
   (cond ((equal interval2 2) (setq score (plus score stepwise))))
   (cond ((equal interval1 interval2)
          (cond ((or (equal interval1 3) (equal interval1 6))
                 (setq score (plus score ll36)))
                ((or (equal interval1 5) (equal interval1 1))
                 (setq score (plus score ll58)))
          ))
   )
   (setq rosterm (cdr rosterm))
   (setq rosterh (cdr rosterh))
  (go loop)
 )
)

;shell function for testing for dissonance
(defun nonchordal (melody harmony)
 (plus (nonhelp nil melody harmony) (pedalt melody harmony))
)

;calls all but pedalt in checking for types of non-chordal tones
(defun nonhelp (lastnotes melody harmony)
 (cond ((null melody) 0)
       ((member (intervalfinder (car harmony) (car melody)) '(2 4 6 7))
        (cond ((null lastnotes)
               (plus (susp melody harmony)
                     (nonhelp (cons (car melody) (car harmony))
                              (cdr melody)
                              (cdr harmony))))
              (t (plus (susp melody harmony)
                       (passt lastnotes melody harmony)
                       (neighbort lastnotes melody harmony)
                       (changet lastnotes melody harmony)
                       (escapet lastnotes melody harmony)
                       (nonhelp (cons (car melody) (car harmony))
                                (cdr melody)
                                (cdr harmony))))))
       (t (nonhelp (cons (car melody) (car harmony))
                   (cdr melody)
                   (cdr harmony)))
 )
)

;checks for changing tones
(defun changet (lastn mel har) 0)

;checks for escape tones
(defun escapet (lastn mel har)
  (cond ((equal (length mel) 1) 0)
        ((newequal (list (cdr lastn) (car har) (cadr har)))
         (setq interval1 (intervalfinder (cdr lastn) (car lastn)))
         (setq interval2 (intervalfinder (car har) (car mel)))
         (setq interval3 (intervalfinder (cadr har) (cadr mel)))
         (setq interval4 (intervalfinder (car lastn) (car mel)))
         (setq interval5 (intervalfinder (car mel) (cadr mel)))
         (cond ((and (member interval1 '(1 3 5))
                     (member interval2 '(2 4 6 7))
                     (member interval3 '(1 3 5))
                     (and (not (equal interval4 2))
                          (member interval5 '(2 7))))
                escape)
               (t 0)
         ))
        (t 0)
  )
)

;checks for neighboring tones
(defun neighbort (lastn mel har)
  (cond ((equal (length mel) 1) 0)
        ((newequal (list (cdr lastn) (car har) (cadr har)))
         (setq interval1 (intervalfinder (cdr lastn) (car lastn)))
         (setq interval2 (intervalfinder (car har) (car mel)))
         (setq interval3 (intervalfinder (cadr har) (cadr mel)))
         (setq interval4 (intervalfinder (car lastn) (car mel)))
         (setq interval5 (intervalfinder (car mel) (cadr mel)))
         (cond ((and (member interval1 '(1 3 5))
                     (member interval2 '(2 4 6 7))
                     (member interval3 '(1 3 5))
                     (or (equal (list interval4 interval5) '(7 2))
                         (equal (list interval4 interval5) '(2 7))))
                neighboring)
               (t 0)
         ))
        (t 0)
  )
)

;checks for passing tones
(defun passt (lastn mel har)
  (cond ((equal (length mel) 1) 0)
        ((newequal (list (cdr lastn) (car har) (cadr har)))
         (setq interval1 (intervalfinder (cdr lastn) (car lastn)))
         (setq interval2 (intervalfinder (car har) (car mel)))
         (setq interval3 (intervalfinder (cadr har) (cadr mel)))
         (setq interval4 (intervalfinder (car lastn) (car mel)))
         (setq interval5 (intervalfinder (car mel) (cadr mel)))
         (cond ((and (member interval1 '(1 3 5))
                     (member interval2 '(2 4 6))
                     (member interval3 '(1 3 5))
                     (or (newequal (list interval4 interval5 2))
                         (newequal (list interval4 interval5 7))))
                passing)
               (t 0)
         ))
        (t 0)
  )
)

;checks for suspensions
(defun susp (melody harmony)
  (cond ((equal (length melody) 1) 0)
        ((equal (car harmony) (cadr harmony))
         (setq intervald (intervalfinder (car harmony) (car melody)))
         (setq intervalc (intervalfinder (cadr harmony) (cadr melody)))
         (cond ((or (and (equal intervald 2) (equal intervalc 1))
                    (and (equal intervald 4) (equal intervalc 3))
                    (and (equal intervald 6) (equal intervalc 5)))
                suspension)
               (t 0)
         ))
        (t 0)
  )
)

;checks for pedal tones
(defun pedalt (mel har)
 (prog () (setq count actualnotes)
          (setq tempscore 0)
          (setq last '(nil . nil))
  loop
   (cond ((and (equal (cdr last) (car har))
               (member (intervalfinder (cdr last) (car last)) '(2 4 6 7))
               (member (intervalfinder (car har) (car mel)) '(1 3 5)))
          (setq tempscore (plus tempscore pedal))))
   (cond ((equal count 0) (return tempscore)))
   (setq count (difference count 1))
   (setq last (cons (car mel) (car har)))
   (setq mel (cdr mel))
   (setq har (cdr har))
  (go loop)
 )
)

;sticks together all of the sequences of notes created by createnotes
;recursive - numbars is not recommended to be above 50 or 60
(defun createbars (bar)
 (cond ((equal (length bar) numbars) bar)
       (t (createbars (insert
                       (car (analyze (list (cons (createnotes) 0))))
                       bar))
       ))
)

;creates random sequences of notes
(defun createnotes ()
 (prog (measures) (setq count actualnotes)
  loop
   (setq measures (cons (normalizenotes (randomize 7)) measures))
   (cond ((zerop count) (return measures)))
   (setq count (difference count 1))
  (go loop))
)

;translates numbers into notes
(defun normalizenotes (number)
 (cond
  ((zerop number) 'c)
  ((equal number 1) 'd)
  ((equal number 2) 'e)
  ((equal number 3) 'f)
  ((equal number 4) 'g)
  ((equal number 5) 'a)
  ((equal number 6) 'b)
 )
)

;the randomize function, i know it stinks
(defun randomize (mod)
 (cond
  ((equal (remainder randhelp 3) 0)
   (remainder (cdr (sys_time)) mod))
  ((equal (remainder randhelp 3) 1)
   (remainder (times (cdr (sys_time)) randhelp) mod))
  ((equal (remainder randhelp 3) 2)
   (remainder (abs (minus (car (sys_time)) (cdr (sys_time)))) mod))
 )
)

;homegrown reverse function
(defun reverse (ls)
 (cond ((null ls) nil)
       (t (append (reverse (cdr ls)) (list (car ls))))
 )
)

;homegrown not function
(defun not (nothing)
 (cond (nothing nil)
       (t t)
 )
)

;homegrown odd predicate
(defun oddp (el)
 (cond ((equal (remainder el 2) 1) t)
       (t nil)
 )
)

;wasn't included in lib.lsp
(defun caadr (x) (car (car (cdr x))))

;wasn't included in lib.lsp
(defun caaddr (x) (car (car (cdr (cdr x)))))

;an equal function that can equate whole lists
;useful little devil
(defun newequal (ls)
 (cond ((null ls) nil)
       ((or (equal (length ls) 1) (atom ls)) nil)
       (t (cond ((null (cddr ls))
                 (equal (car ls) (cadr ls)))
                (t (and (equal (car ls) (cadr ls))
                   (newequal (cdr ls))))))))

(music)