gac/pc-ops.scm

(require musictypes)

'(define-module (gac pc-ops)
  #:use-module (gac sg1)
  #:use-module (srfi srfi-1)
  #:export (transpositions
            transpose-all
	    inversions
	    reverse-all
            intervals->chord
	    get-sc
	    append-sc
	    cons-sc
	    choose-sc
	    sc1+))

(define
  (transpositions l)
  (define
    (rot o)
    (map
     (lambda (e)
       (remainder (+ o e) 12)) l))
  (map rot (iota 12)))

(define (transpose-all chords)
  (map transpositions chords))

(define inversions
  '((0 . 0)
    (1 . 11)
    (2 . 10)
    (3 . 9)
    (4 . 8)
    (5 . 7)
    (6 . 6)))

;; todo add alpha mappings from morris' composition with pitch classes

(define
  (reverse-all lst)
  (map
   (lambda (x) (reverse x))
   lst))

(define (get-sc setclass position)
  (list-ref setclass position))

(define (append-sc sc1 sc2)
  (append sc1 sc2))

(define (cons-sc sc1 sc2)
  (cons sc1 sc2))

(define (choose-sc setclass)
  (list-ref setclass (random-integer (length setclass))))

;; this can be used with get-sc e.g. (sc1+ (get-sc %trichords 1))

(define (sc1+ setclass)
  (map (lambda (x) (1+ x))
       setclass))

'(defmacro (ntimes n generator)
 (make-list! n (lambda () ())))

(def (tcomplicated)
     (list (make-list! 3 (lambda () (choose-sc %trichords)))
           (make-list! 4 (lambda () (choose-sc %hexachords)))))

(def (t)
     (list (ntimes 3 (choose-sc %trichords))
           (ntimes 4 (choose-sc %hexachords))))


(def progression? (list-of (list-of integer?)))


;; (nrand-progession 3 %trichords 4 %tetrachords 6 %hexachords ...)
(def nrand-progression
     (lambda args -> progression?
        (pmatch
         args
         (pair?
          (let-list ((n chords . args*) args)
                    (append
                     (make-list! n (lambda () (choose-sc chords)))
                     (apply nrand-progression args*))))
         (null?
          '()))))


;; (car-cdr-chord %trichords)
(def (car-cdr-chord chord)
     "'(0 1 2) => '((0) (1 2))"
     (let ((chosen-chord (choose-sc chord)))
       ;; (list (list (car chosen-chord))
       ;;       (cdr chosen-chord))
       `((,(car chosen-chord))
         ,(cdr chosen-chord))))

;; (high-note-rest-chord %trichords)
(def (high-note-rest-chord chord)
     "'(0 1 2) => '((2) (0 1))"
     (let ((chosen-chord (choose-sc chord)))
       (cons (list (last chosen-chord))
             (list (butlast chosen-chord)))))

(def (expand-chord chord)
     "'(0 1 2) => '(-12 1 14)"
     "'(0 1 2 3) => '(-12 1 2 15)"
     (let ((chosen-chord (choose-sc chord)))
       (append (list (- (car chosen-chord) 12))
               (cdr (butlast chosen-chord))
               (list (+ (last chosen-chord) 12)))))

(def (expand-chords chord)
     (append (list (- (car chord) 12))
             (list  (cadr chord))
             (list (+ (last chord) 12))))
;; (def (expand-chord chord)
;;      (let ((chose-chord (choose-sc chord)))
;;        (append (- (car chosen-chord) 12)
;;                (list (cdr)))))

(def (intervals->chord [integer? p0] [pitch-intervals? is])
     ;; (-7 . (-6 -3 1 10))
     (cons p0 (if (null? is)
                  '()
                  (intervals->chord (+ (car is) p0)

                                (cdr is)))))

;; (intervals->chord -7 '(1 3 4 9)) -> (-7 -6 -3 1 10)
;; (intervals->chord -6 '(3 4 9)) -> (-6 -3 1 10)
;; (intervals->chord -3 '(4 9)) -> (-3 1 10)
;; (intervals->chord 1 '(9)) -> (1 10)
;; (intervals->chord 10 '()) -> (10)
;; (-7 -6 -3 1 10)

;; (both chord? (complement null?))
;;  ==
;; (lambda (v)
;;   (and (chord? v)
;;        (not (null? v))))

(def (chord->intervals [(both chord? (complement null?)) c])
     (let-pair ((v0 vs) c)
               (values v0
                       (let rec ((oldv v0)
                                 (vs vs))
                         (if-let-pair ((v vs*) vs)
                                      (cons (- v oldv)
                                            (rec v
                                                 vs*))
                                      '())))))


(TEST
 > (intervals->chord -7 '(1 3 4 9))
 (-7 -6 -3 1 10)
 > (show (chord->intervals #))
 (values -7 (list 1 3 4 9))
 > (show (chord->intervals '(-99 99 99 -99 -99)))
 (values -99 (list 198 0 -198 0)))


;; (intervals->chord 1 '(3 7))
;; (intervals->chord 4 '(7))
;; (intervals->chord 11 '())
;; (11)

;; (cons 0 (cons 1 (cons 4 (cons 11 '()))))
;; (=> '()
;;     (.cons 11)
;;     (.cond 4)
;;     (.cons 1)
;;     (.cons 0))

;; (def (chord-shrink-progression [chord? chord])
;;     ...)

;;(TEST
;; > (chord-shrink-progression '(0 1 2 3))
;; ((0 1 2 3)
;;  (0 1 2)
;;  (0 1)
;;  (0)))

;; (def (chord-shrink-expand-progression [chord? chord])
;;      '(if (= (length chord) 1)
;;          (cons chord '())
;;          (list (cons (car chord)
;;                      (shrink-expand-chord (cdr chord)))))
;;      (let (downwards (chord-shrink-progression))
;;        (append downwards (cdr (reverse downwards)))))


'(def (foo? x)
     (and (number? x)
          (<= 10 x 30)))

;; (TEST
;; > (chord-shrink-expand-progression '(0 1 2 3))
;; ((0 1 2 3)
;;  (0 1 2)
;;  (0 1)
;;  (0)
;;  (0 1)
;;  (0 1 2)
;;  (0 1 2 3)))